LINUX.ORG.RU

Помогите кроваво пропатчить

 , ,


1

2

С помощью модуля (web client) (guile 2.2.4) запрашиваю некий сервер и тот оставляет мусор в заголовке:

scheme@(guile-user)> (define myx (http-get site))
web/http.scm:479:8: In procedure parse-non-negative-integer:
Bad non-negative-integer header component: 0; must-revalidate; no-cache


Entering a new prompt.  Type `,bt' for a backtrace or `,q' to continue.
scheme@(guile-user) [1]> ,bt
In current input:
   678:12  6 (_)
In web/client.scm:
   386:24  5 (http-request _ #:body _ #:port _ #:method _ #:version _ #:keep-alive? _ # _ # _ …)
In web/response.scm:
   200:48  4 (read-response #<input-output: string 560a19106b60>)
In web/http.scm:
   225:33  3 (read-headers #<input-output: string 560a19106b60>)
   195:11  2 (read-header #<input-output: string 560a19106b60>)
   529:23  1 (lp _)
    479:8  0 (parse-non-negative-integer "0; must-revalidate; no-cache" _ _)
scheme@(guile-user) [1]> 

На первый взгляд косяк элементарный, но я в схеме новичок и поэтому читаю этот http.scm с данными из бэктрейса и не могу понять куда впатчить предварительную обработку строки.

★★★★★

1) Функция http-get возвращает 2 значения, поэтому правильно делать так:

(define-values (res body)
  (http-get site))

2) Попробовал сейчас у себя — с http все ок, с https выдаёт ошибку. Возможно какой-то косяк при работе с SSL в самом guile.

xerx ()
Ответ на: комментарий от ados

А задачу принципиально надо решить на Guile? Я помню тыкал его год назад — спотыкался обо что-нибудь каждые 5 минут, да ещё и фиг что нагуглишь. С другими схемками таких проблем не было.

xerx ()

Глянул по-быстрому. Если кроваво, то проще всего будет пропатчить здесь

(define (read-header port)
  "Read one HTTP header from PORT. Return two values: the header
name and the parsed Scheme value. May raise an exception if the header
was known but the value was invalid.

Returns the end-of-file object for both values if the end of the message
body was reached (i.e., a blank line)."
  (let ((line (read-header-line port)))
    (if (or (string-null? line)
            (string=? line "\r"))
        (values *eof* *eof*)
        (let* ((delim (or (string-index line #\:)
                          (bad-header '%read line)))
               (sym (string->header (substring line 0 delim))))  ;;;; <--------- Символ cache-control из заголовка
          (values
           sym
           (parse-header
            sym
            (read-continuation-line
             port
             (string-trim-both line char-set:whitespace (1+ delim)))))))))  ;;;; <-------- ТУТ привязывается значение

Т.е. перед тем как совать в парсер можно его подменить. Как вариант чуть менее кровавого патча - сделать декоратор для parse-header.

no-such-file ★★★★★ ()
Последнее исправление: no-such-file (всего исправлений: 1)
Ответ на: комментарий от monk

Вот кусок кода, где, похоже, ошибка:

(declare-key-value-list-header! "Cache-Control"
  (lambda (k v-str)
    (case k
      ((max-age min-fresh s-maxage)
       (parse-non-negative-integer v-str))
      ((max-stale)
       (and v-str (parse-non-negative-integer v-str)))
      ((private no-cache)
       (and v-str (split-header-names v-str)))
      (else v-str)))
  (lambda (k v)
    (case k
      ((max-age min-fresh s-maxage)
       (non-negative-integer? v))
      ((max-stale)
       (or (not v) (non-negative-integer? v)))
      ((private no-cache)
       (or (not v) (list-of-header-names? v)))
      ((no-store no-transform only-if-cache must-revalidate proxy-revalidate)
       (not v))
      (else
       (or (not v) (string? v)))))
  (lambda (k v port)
    (cond
     ((string? v) (default-val-writer k v port))
     ((pair? v)
      (put-char port #\")
      (write-header-list v port)
      (put-char port #\"))
     ((integer? v)
      (put-non-negative-integer port v))
     (else
      (bad-header-component 'cache-control v)))))
monk ★★★★★ ()
Ответ на: комментарий от no-such-file

Вот правильный заголовок:

Cache-Control: no-cache,no-store,max-age=0,must-revalidate

Если надо вариант с «max-age=0; must-revalidate», то надо заменять в http.scm

(define* (parse-key-value-list str #:optional
                               (val-parser default-val-parser)
                               (start 0) (end (string-length str)))
  (let lp ((i start))
    (if (not (< i end))
        '()
        (let* ((i (skip-whitespace str i end))
               (eq (string-index str #\= i end))
               (comma (string-index str #\, i end))
               (delim (min (or eq end) (or comma end)))
               (k (string->symbol
                   (substring str i (trim-whitespace str i delim)))))
          (call-with-values
              (lambda ()
                (if (and eq (or (not comma) (< eq comma)))
                    (let ((i (skip-whitespace str (1+ eq) end)))
                      (if (and (< i end) (eqv? (string-ref str i) #\"))
                          (parse-qstring str i end #:incremental? #t)
                          (values (substring str i
                                             (trim-whitespace str i
                                                              (or comma end)))
                                  (or comma end))))
                    (values #f delim)))
            (lambda (v-str next-i)
              (let ((v (val-parser k v-str))
                    (i (skip-whitespace str next-i end)))
                (unless (or (= i end) (eqv? (string-ref str i) #\,))
                  (bad-header-component 'key-value-list
                                        (substring str start end)))
                (cons (if v (cons k v) k)
                      (lp (1+ i))))))))))

на что-то вроде

(define* (parse-key-value-list str #:optional
                               (val-parser default-val-parser)
                               (start 0) (end (string-length str)))
  (let lp ((i start))
    (if (not (< i end))
        '()
        (let* ((i (skip-whitespace str i end))
               (eq (string-index str #\= i end))
               (comma (min (string-index str #\, i end) (string-index str #\; i end)))
               (delim (min (or eq end) (or comma end)))
               (k (string->symbol
                   (substring str i (trim-whitespace str i delim)))))
          (call-with-values
              (lambda ()
                (if (and eq (or (not comma) (< eq comma)))
                    (let ((i (skip-whitespace str (1+ eq) end)))
                      (if (and (< i end) (eqv? (string-ref str i) #\"))
                          (parse-qstring str i end #:incremental? #t)
                          (values (substring str i
                                             (trim-whitespace str i
                                                              (or comma end)))
                                  (or comma end))))
                    (values #f delim)))
            (lambda (v-str next-i)
              (let ((v (val-parser k v-str))
                    (i (skip-whitespace str next-i end)))
                (unless (or (= i end) (eqv? (string-ref str i) #\,) (eqv? (string-ref str i) #\;))
                  (bad-header-component 'key-value-list
                                        (substring str start end)))
                (cons (if v (cons k v) k)
                      (lp (1+ i))))))))))

monk ★★★★★ ()
Ответ на: комментарий от monk

он хочет считать, что после Cache-Control: max-age= должно идти только число и больше ничего.

Да, и сервер таки отдаёт правильную строку. Guile где-то max-age режет. Вон господин сверху говорит, что это известная баг «фича».

PS: зря ТС схемку взял, там всё полумёртвое, кроме разве что ракетки и chez. Да и те полуживые.

no-such-file ★★★★★ ()
Ответ на: комментарий от no-such-file

S: зря ТС схемку взял, там всё полумёртвое, кроме разве что ракетки и chez.

Выходит что даже стандарт 30-летней давности живее?

Меня guile заинтересовал неплохо так ещё потому что на его базе разрабатывается guixsd, который тоже меня интересует. Ну нельзя же просто так такие разработки вести на дохлых технологиях.

ados ★★★★★ ()
Последнее исправление: ados (всего исправлений: 1)
Ответ на: комментарий от ados

даже стандарт 30-летней давности живее?

До такого стандарта схемке как до Китая раком. Например ООП, как я понимаю, стандартного так и нет. А вообще практика решает, ИМХО в CL хоть какое-то шевеление есть, а на тот же guile похоже вообще забили и он есть только для галочки. Ну как Hurd и т.п. памятники светлым мечтам о будущем.

no-such-file ★★★★★ ()
Последнее исправление: no-such-file (всего исправлений: 1)
Ответ на: комментарий от no-such-file

Например ООП, как я понимаю, стандартного так и нет.

Guile же задумывался как «скриптота для всего» в GNU.

Значит guile - тоже своего рода стандарт. Не в граните как CL, но всё же.

ados ★★★★★ ()
Ответ на: комментарий от ados

своего рода стандарт

Для GNU, да. К сожалению такого признания как gcc он не получил, поэтому такой себе стандарт, но внутри GNU конечно они его везде суют.

no-such-file ★★★★★ ()
Последнее исправление: no-such-file (всего исправлений: 1)
Ответ на: комментарий от ados

Как-то так похоже:

(module-define!
 (resolve-module '(web http))
 'parse-key-value-list
 (lambda* (parse-key-value-list str #:optional
                                (val-parser default-val-parser)
                                (start 0) (end (string-length str)))
   (let lp ((i start))
     (if (not (< i end))
         '()
         (let* ((i (skip-whitespace str i end))
                (eq (string-index str #\= i end))
                (comma (min (string-index str #\, i end) (string-index str #\; i end)))
                (delim (min (or eq end) (or comma end)))
                (k (string->symbol
                    (substring str i (trim-whitespace str i delim)))))
           (call-with-values
               (lambda ()
                 (if (and eq (or (not comma) (< eq comma)))
                     (let ((i (skip-whitespace str (1+ eq) end)))
                       (if (and (< i end) (eqv? (string-ref str i) #\"))
                           (parse-qstring str i end #:incremental? #t)
                           (values (substring str i
                                              (trim-whitespace str i
                                                               (or comma end)))
                                   (or comma end))))
                     (values #f delim)))
             (lambda (v-str next-i)
               (let ((v (val-parser k v-str))
                     (i (skip-whitespace str next-i end)))
                 (unless (or (= i end) (eqv? (string-ref str i) #\,) (eqv? (string-ref str i) #\;))
                   (bad-header-component 'key-value-list
                                         (substring str start end)))
                 (cons (if v (cons k v) k)
                       (lp (1+ i)))))))))))
ados ★★★★★ ()
Последнее исправление: ados (всего исправлений: 1)
Ответ на: комментарий от ados

стандарт CL с gcc сравни

А в чём проблема? Как бы сегодня говоря лисп имеют в виду именно CL, а не guile какой-нибудь. Остальные лиспы или вообще называются не лиспами, или уточняется что за лисп имеется в виду. Всё как с gcc.

no-such-file ★★★★★ ()
Ответ на: комментарий от no-such-file

PS: зря ТС схемку взял, там всё полумёртвое, кроме разве что ракетки и chez. Да и те полуживые.

Тут понятно, что это я придираюсь к словам, но есть ли разница между полумёртвым и полуживым.

ados ★★★★★ ()
Ответ на: комментарий от xerx

Я наспех посмотрел схемы в том треде и меня guile ещё привлёк тем, что у него ядро в libguile-*.so, что, я думаю, играет положительную роль когда на достаточно небогатой на ресурсы системе крутится множество краткосрочно живущих процессов, с достаточно разнообразными задачами.

ados ★★★★★ ()
Последнее исправление: ados (всего исправлений: 1)
Ответ на: комментарий от ados

Вообще, можно, но в данном случае надо же ещё внутри этого кода юзеать код из его пакета. Лучше в этом же пакете определить новую функцию, а импортировать его с другим именем в свой модуль. А тот зашадовить.

turtle_bazon ★★★★ ()
Ответ на: комментарий от ados

Я честно скажу, что 2.4 я не пробовал, но на 2.2 много всяких мелких ерундовин неприятных, которых в 2.4 нет. Правда, не факт, что в 2.4 других мелких неприятных ерундовин нет.

turtle_bazon ★★★★ ()
Ответ на: комментарий от turtle_bazon

Я пробовал guile, racket, chicken, gambit и gerbil (остальные даже не трогал, потому что проекты мертвые). Остановился на последнем.

У Racket шикарная документация, но в процессе работы в какой-то момент я почувствовал, что язык игрушечный. То есть много фич есть «для галочки», но использовать их в реальных ситуациях нереально.

Chicken прикольный тем, что у него самое живое и дружелюбное комьюнити, а также много библиотек. Но меня не зацепило почему то.

Gambit не такой дружелюбный, но он как автомат Калашникова — надежный и не подведёт в трудную минуту. Мне не хватило готовых либ.

Gerbil — это такой Gambit на максималках. В Gambit’е много фич, которые крутые, но сложные. Gerbil делает их удобными.

xerx ()
Ответ на: комментарий от no-such-file

Да, и сервер таки отдаёт правильную строку

Неправильную. В rfc 2616 указано, что разделителем должна быть запятая.

$ HEAD ya.ru | grep Cache
Cache-Control: no-cache,no-store,max-age=0,must-revalidate

А этот недосервер даёт

Cache-Control: max-age=0; must-revalidate; no-cache

Естественно, это трактуется как: установить в max-age значение «0; must-revalidate; no-cache». А max-age обязан быть числом.

monk ★★★★★ ()
Ответ на: комментарий от no-such-file

Например ООП, как я понимаю, стандартного так и нет.

Он там не нужен. При наличии замыканий и макросов ООП вообще мало где нужен. И в Guile есть GOOPS, чем не стандарт?

а на тот же guile похоже вообще забили и он есть только для галочки.

Версии выходят не реже, чем раз в полгода. Для сравнения clisp последний раз обновлялся в 2010, а sbcl поддерживает только linux-amd64. На windows только 1.4.14 полугодовой давности, на MacOS/*BSD вообще 2015 года.

monk ★★★★★ ()
Ответ на: комментарий от xerx

У Racket шикарная документация, но в процессе работы в какой-то момент я почувствовал, что язык игрушечный. То есть много фич есть «для галочки», но использовать их в реальных ситуациях нереально.

Например? Вроде по сравнению с C++ количество фич «для галочки» в нём исчезающе мало (я только с plumber не смогу придумать нормального примера).

monk ★★★★★ ()
Последнее исправление: monk (всего исправлений: 1)
Ответ на: комментарий от turtle_bazon

А я вот решил голову не ломать и использовать CL на sbcl.

Я ушёл с CL на Racket после нескольких попыток прикрутить к CL нормальные модули, систему сборки и корутины. Корутины в принципе сейчас появились через libuv, а вот с модулями, системой сборки (и, как оказалось, макросами) всё по-прежнему плохо.

monk ★★★★★ ()
Ответ на: комментарий от turtle_bazon

Нормальные модули должны позволять переименовывать импортируемые символы. Попытка сделать их в CL: https://github.com/Kalimehtar/advanced-readtable

Нормальное решение в Racket:

(require 
  (prefix-in a: very-long-package-name) 
  (rename-in package-name 
    (long-name-to-list-directory ls)
    (long-name-to-count-words wc)))

Нормальная система сборки — которая не требует перед комитом в гит удалять fasl'ы и пересобирать на всякий случай. Попытка сделать в CL: https://www.cliki.net/xcvb. Нормальное решение в Racket: каждый модуль компилируется независимо и побочные эффекты процесса компиляции не распространяются за пределы этого процесса.

monk ★★★★★ ()
Ответ на: комментарий от monk

Нормальные модули должны позволять переименовывать импортируемые символы. ...

Ты умный парень (это на полном серьёзе), но иногда несёшь такую Х@#НЮ, причём в элементарных, базовых вопросах - просто поразительно... Пару лет назад пришлось показать тебе множественное наследование в CLOS, теперь элементарный способ создания коротких псевдонимов.

CL-USER> (defpackage #:test1
           (:use #:cl)
           (:export #:var-test11
                    #:var-test12))
#<PACKAGE "TEST1">
CL-USER> (in-package #:test1)
#<PACKAGE "TEST1">
TEST1> (defvar var-test11 11)
VAR-TEST11
TEST1> (defvar var-test12 12)
VAR-TEST12
TEST1> (defpackage #:test2
         (:use #:cl)
         (:local-nicknames (#:t1 #:test1)))
#<PACKAGE "TEST2">
TEST1> (in-package #:test2)
#<PACKAGE "TEST2">
TEST2> (define-symbol-macro vt11 t1:var-test11)
VT11
TEST2> vt11
11
TEST2> t1:var-test12
12
TEST2> 

Макрос rename-in, который аргументы попарно оборачивает в define-symbol-macro сам напишешь?

.

local-nicknames уже стандарт де-факто. пруф см. в комментах

I am now confident to say that package local nicknames have been tested and behave the same way on SBCL, ABCL, and CCL.

ECL has them too : )

anonymous ()
Ответ на: комментарий от monk

Нормальная система сборки — которая не требует перед комитом в гит удалять fasl'ы и пересобирать на всякий случай.

Не знаю конкретики твоих проблем с фаслами (у меня таких не возникало), но уверен, что существует простое решение (см. предыдущий пост).

...каждый модуль компилируется независимо и побочные эффекты процесса компиляции не распространяются за пределы этого процесса.

Побочные эффекты в CL «не баг, а фича» (ц). Иногда требования конкретного проекта заставляют сменить язык. А иногда находится возможность не только не только обойти ограничения, но и использовать себе во благо. Опять же, не зная конкретики...

anonymous ()
Ответ на: комментарий от anonymous

Пару лет назад пришлось показать тебе множественное наследование в CLOS, теперь элементарный способ создания коротких псевдонимов.

...
TEST2> (symbol-value 'vt11)
The variable VT11 is unbound.
   [Condition of type UNBOUND-VARIABLE]

Дырявая абстракция. Более-менее нормально сделано в advanced-readtable, но ценой изнасилования таблицы чтения и переопределения функций из CL.

Кроме-того rename-in обычно нужен, чтобы импортировать пакет (в смысле use), но несколько символов переименовать для короткого доступа или для разрешения конфликта. В CL приходится для этого писать в двух местах: shadow + symbol-macro.

monk ★★★★★ ()
Ответ на: комментарий от anonymous

Побочные эффекты в CL «не баг, а фича» (ц).

Из-за этого запуск скомпилированной программы происходит не в той среде, в которой компиляция и запуск. И неожиданные ошибки.

monk ★★★★★ ()

Вот файл кровавого патча:


(use-modules (web http))

(define skip-whitespace (@@ (web http) skip-whitespace))
(define trim-whitespace (@@ (web http) trim-whitespace))
(define parse-qstring (@@ (web http) parse-qstring))
(define bad-header-component (@@ (web http) bad-header-component))
(define (default-val-parser k val)
  val)

(module-define!
 (resolve-module '(web http))
 'parse-key-value-list
 (lambda* (str #:optional
               (val-parser default-val-parser)
               (start 0) (end (string-length str)))
   (let lp ((i start))
     (if (not (< i end))
         '()
         (let* ((i (skip-whitespace str i end))
                (eq (string-index str #\= i end))
                (comma (let ((q1 (string-index str #\, i end))
                             (q2 (string-index str #\; i end)))
                         (if (and q1 q2)
                             (min q1 q2)
                             (or q1 q2))))
                (delim (min (or eq end) (or comma end)))
                (k (string->symbol
                    (substring str i (trim-whitespace str i delim)))))
           (call-with-values
               (lambda ()
                 (if (and eq (or (not comma) (< eq comma)))
                     (let ((i (skip-whitespace str (1+ eq) end)))
                       (if (and (< i end) (eqv? (string-ref str i) #\"))
                           (parse-qstring str i end #:incremental? #t)
                           (values (substring str i
                                              (trim-whitespace str i
                                                               (or comma end)))
                                   (or comma end))))
                     (values #f delim)))
             (lambda (v-str next-i)
               (let ((v (val-parser k v-str))
                     (i (skip-whitespace str next-i end)))
                 (unless (or (= i end)
                             (eqv? (string-ref str i) #\,)
                             (eqv? (string-ref str i) #\;))
                   (bad-header-component 'key-value-list
                                         (substring str start end)))
                 (cons (if v (cons k v) k)
                       (lp (1+ i)))))))))))

Заставил её работать. Всем спасибо за помощь.

ados ★★★★★ ()