webアクセスに使う小物群。

web-helper.scm

(define-module web-helper
  (use rfc.http)
  (use rfc.uri)
  (use sxml.ssax)
  (use komono)

  (use gauche.threads)
  (use gauche.generator)
  (use util.queue)
  (use gauche.vport)
  
  (export
    string-xml->sxml
    uri->param
    simple-http-get
    simple-http-head
    redirect-chain 
    ;
    http-hook-receiver
    call-with-input-http-uri
    ) 
  )
(select-module  web-helper)

; xml文字列をssaxでsxmlにする
(define (string-xml->sxml xml :optional (ns '()) )
  (call-with-input-string xml (cut ssax:xml->sxml <> ns ) ) )

; uriをhttp-get系に渡せるようなパラメータにする
(define (uri->param uri
      :key
        (pass values ) ; 成功時の継続 ホスト、パスの２つ
        (fail (^(uri) (values #f #f))) ; 失敗時の継続
        )
  (receive (_ _ host port path query _) (uri-parse uri)   
    (if host
      (pass
        (if port  (format "~a:~a" host port)  host )
        (if path
          (if query 
            (format "~a?~a" path query)
            path)
          "/" ) )
      (fail uri)
    )))

; uri指定、http-getで取得する。
(define (simple-http-get uri 
    :key 
      ; これでいいのかどうか。とにかくbodyを返すのが標準に。
      (pass-success      (^(status header body) body) ) ; 成功時の継続
      ;
      ; http status 1xx 時の継続
      ; とりあえず、つけた。
      (pass-informational(^(status header body) #t) ) 
      ;
      ; http status 3xx 時の継続 (http-getでredirectの処理をするので実は冗長なのだがとりあえずつけた)
      (pass-redirection  (^(status header body) #t) ) 
      ; 
      ;------------------------------------------------------------
      ; 失敗時はとにかく#fを返すのが標準。調べたいときにcpsを使う。
      (fail-uri          (^(uri) #f) ) ; uri解析失敗時の継続 
      (fail-client       (^(status header body) #f) ) ; http status 4xx 時の継続 
      (fail-server       (^(status header body) #f) ) ; http status 5xx 時の継続 
      (fail-http-get     (^(status header body) #f) ) ; http-get失敗時の継続 
    )
  (receive (param-host param-path) (uri->param uri)
    ;(format (standard-error-port) "param-host=~a , param-path=~a\n" param-host param-path)
    (if param-host
      (receive (status header body) (http-get param-host param-path) 
        (case (string-ref status 0) 
          [ (#\1) (pass-informational status header body) ]
          [ (#\2) (pass-success       status header body) ]
          [ (#\3) (pass-redirection   status header body) ]
          [ (#\4) (fail-client        status header body) ]
          [ (#\5) (fail-server        status header body) ]
          [ else  (fail-http-get      status header body) ]
        ) )
      (fail-uri uri) 
    );if
  );receive 
) 

; uri指定、http-headで取得する。
; http-headでredirectの処理をしない。
(define (simple-http-head uri 
    :key 
      ; CPS
      (pass-success      (^(status header ); 成功時の継続
        ;(format (standard-error-port) "pass-success\n") 
        header) ) 
      (pass-informational(^(status header ) ; http status 1xx 時の継続
        ;(format (standard-error-port) "pass-informational\n") 
        header) ) 
      (pass-redirection  (^(status header ) ; http status 3xx 時の継続
        ;(format (standard-error-port) "pass-redirection\n") 
        header) ) 
      ; 
      (fail-uri          (^(uri) ; uri解析失敗時の継続 
        ;(format (standard-error-port) "fail-uri ~a\n" uri)
        #f) ) 
      (fail-client       (^(status header ) ; http status 4xx 時の継続 
        ;(format (standard-error-port) "fail-client ~a : ~a\n" status  header)
        #f) ) 
      (fail-server       (^(status header ) ; http status 5xx 時の継続 
        ;(format (standard-error-port) "fail-server ~a : ~a\n" status header)
        #f) ) 
      (fail-http-get     (^(status header ) ; http-get失敗時の継続
        ;(format (standard-error-port) "fail-http-get ~a : ~a\n" status header)
        #f) )  
    )
  (receive (param-host param-path ) (uri->param uri)    
    (if param-host
      (begin
        ;(format (standard-error-port) "host:~a , path:~a\n" param-host param-path)
        (receive (status header body) (http-head param-host param-path :no-redirect #t ) 
          (case (string-ref status 0) 
            [ (#\1) (pass-informational status header ) ]
            [ (#\2) (pass-success       status header ) ]
            [ (#\3) (pass-redirection   status header ) ]
            [ (#\4) (fail-client        status header ) ]
            [ (#\5) (fail-server        status header ) ]
            [ else  (fail-http-get      status header ) ]
          ) ) )
      (fail-uri uri) 
    );if
  );receive 
)

; リダイレクトの連鎖を追跡する。最終的な場所のuriを返す。
(define (redirect-chain uri 
    :key
      (pass values)
      (fail (^x #f) ) 
      (hook  (^(uri) 
          ;(format (standard-error-port) "-->~a\n" uri) 
        ) ) 
    )
  ;(format (standard-error-port) "uri=~a\n" uri)
  (let1 head (simple-http-head uri)
    (cond 
      [(not head) (fail uri) ]
      [(assoc "location" head) => (.$ redirect-chain (peek$ hook) cadr) ]       
      [ else (pass uri) ] ) ) )

; http-getのreciever API用receiver
; 生のデータにフック
(define (http-hook-receiver proc) 
  (lambda (code hdrs total retr)
    (let loop [ ]
      (receive (port size) (retr) 
        (cond
          [ (eqv? size 0) #t]
          [ (or (not size) (> size 0) )
           (let loop-rb [(data (read-block size port) ) 
                         (req-size  size) ]
             
             (proc data) ; hook
             (let1 nrest (- req-size (string-length data))
               (if (= nrest 0)
                 (loop)
                 (loop-rb (read-block nrest port) nrest ) ) ) ) ]
          ) ) ) ) )

; uri指定、仮想ポートをつくってprocを呼ぶ
(define (call-with-input-http-uri uri proc :key (queue-size 4096))
  (define qr (make-mtqueue :max-length queue-size))
  
  (define (make-producer uri)
    ;#?= uri
    (receive (host path) (uri->param uri)
      ;#?= host
      ;#?= path
      (^ []
        (http-get host path 
                  :receiver (http-hook-receiver
                              (^(xp) 
                                ;#?= xp
                                (enqueue/wait! qr xp) ) ) )
        (enqueue/wait! qr (eof-object))
        ) ) )

  (define (make-consumer proc)
    (^ []
      (let* [( g ($ gconcatenate 
                   $ gmap string->generator 
                   $ generate (^(yield)
                                (let loop [(xc (dequeue/wait! qr))]
                                  (if (eof-object? xc)
                                    (yield (eof-object))
                                    (begin
                                      ;#?= xc
                                      (yield xc)
                                      (loop (dequeue/wait! qr) ) ) ) ) ) ) )
             ( vp (make <virtual-input-port> :getc g ) )
             ]
        (proc vp)
        ) ) )    
   
  (and-let* [ ( final-uri (redirect-chain uri))
              ( c (make-thread (make-consumer proc) ) )
              ( p (make-thread (make-producer final-uri)))]
    ;(debug-print c)
    ;(debug-print p)
    (let [(tc (thread-start! c))
          (tp (thread-start! p))
          ]
      ;(debug-print tc)
      ;(debug-print tp)
      (thread-join! tp) 
      (thread-join! tc) ; <----コンシューマの値を返す。 
      ) ) )