httpをcall-with-input系アクセスする。スレッドを使うかどうかを切り替えられるように。

call-with-input-http.scm

; スレッドを使わずにcall-with-input-httpを実装してみる
; スレッドを使うかどうかを切り替えられるように。

(use rfc.http)
(use gauche.generator)
(use gauche.uvector)
(use sxml.ssax) 
(use gauche.vport)

(use inverter)
;(use htmlprag)
;(use pretty-print)
;(use web-helper)

(define (call-with-input-chunk port chunk-size size proc) 
  (let1 chunk (make-u8vector chunk-size)
    (cond
      [ (eqv? size 0) #t ]
      [ (not size) 
       (until (read-block! chunk port 0 chunk-size) eof-object? => len
         (proc (uvector-alias <u8vector> chunk 0 len) ) ; hook 
         ) ]
      [ (> size 0) 
       (let loop [ (total size) 
                  (len (read-block! chunk port 0 (min size chunk-size)) )]
         (unless (eof-object? len)
           (proc (uvector-alias <u8vector> chunk 0 len)) ; hook
           (let1 n (- total len)
             (unless (= n 0) 
             (loop n (read-block! chunk port 0 (min n chunk-size) ) ) ) ) ) ) ]
      ) ) )


(define (http-hook-receiver proc :key (chunk-size 8000) )
  (lambda (code hdrs total retr)
    (let loop [ ]
      (receive (port size) (retr) 
        ;#?= (port-buffering port)
        (cond
          [ (eqv? size 0) #t]
          [ (or (not size) (> size 0))
           (call-with-input-chunk port chunk-size size proc)
           (loop)]
          ) ) ) ) )

; http-getをよび、データを仮想ポート経由で読む。
; http-param ..... http-getのパラメータリスト
; proc .... 仮想ポートを引数とする手続き
; keyword 
;   :buffer-size .... 転送に使うバッファサイズ
;   :inverter    .... イテレータを反転する手続き、省略時は限定継続を使うgenerate
(define (call-with-input-http http-param proc 
                              :key 
                              (buffer-size 8000) 
                              (inverter (generator-inverter) ))
  (inverter
    ;producer
    (^(yield)
      (apply http-get 
             (append 
               http-param 
               `(:receiver 
                  ,(http-hook-receiver (^x (yield (u8vector-copy x) ) ) :chunk-size buffer-size) ) ) )
      (yield (eof-object) ) ) 
    ;
    ;consumer
    (^(u8v-g) 
      ( let1 inp (make <buffered-input-port> 
                        :buffer-size buffer-size
                        :fill (^(u8v-dst)
                                (let1 u8v-src (u8v-g)  
                                  (if (eof-object? u8v-src)
                                    0
                                    (let* [(ndst (uvector-length u8v-dst))
                                           (nsrc (uvector-length u8v-src))]
                                      (if (>= ndst nsrc )
                                        (begin 
                                          (u8vector-copy! u8v-dst 0 u8v-src ) 
                                          ;#?= u8v-src
                                          ;#?= u8v-dst
                                          nsrc )
                                        (begin 
                                          ; ここには来ないはずだが念の為
                                          (error "ndst < nsrc") ) ) ) ) ) ) ) 
             (proc inp)
             ) )     
    ) )

;(define (call-with-input-http-uri uri proc :key (queue-size 100))
;  (receive (host path) (uri->param uri)
;    (call-with-input-http 
;      (list host path) proc :queue-size queue-size )))

(define (main args)
  (call-with-input-http 
    (cdr args)
    (^p
      ;(print (port->string p))
      (print (ssax:xml->sxml p '() ) )
      ;(print (html->sxml p))
      )
    :inverter (mtgenerator-inverter :queue-size 3)
    )

  )