[日記] バレエ発表会

年末恒例のバレエ発表会が終った。娘は幼稚園組の真ん中で踊って、わずからがらソロもあった。よくがんばった。フレンチカンカンは楽しくてよかった。

ま、あと関係ないジャンクコードだけど

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :bordeaux-threads)
  (require :usocket)
  (require :cl-ppcre)
  (require :puri)
  (require :flexi-streams)
  (require :quek))

(defun start ()
  "プロキシサーバを開始する。"
  ;; スレッドで
  (threads:make-thread
   (lambda ()
     ;; ポート5555でリッスンする
     (usocket:with-socket-listener (socket "localhost" 5555)
       (loop
         ;; アクセプト
        (usocket:with-connected-socket (stream-socket
                                        (usocket:socket-accept
                                         socket
                                         :element-type '(unsigned-byte 8)))
          ;; ソケットとストリームを取り出してアクセプト時の処理を呼び出す
          (accept-handler (usocket:socket stream-socket)
                          (flexi-streams:make-flexi-stream
                           (usocket:socket-stream stream-socket)))))))
   ;; スレッドに名前を付けおく
   :name "プロキシで遊んでいるスレッド"))

(defun accept-handler (socket stream)
  "アクセプト時の処理"
  (declare (ignorable socket stream))
  ;; GET http://li31-15.members.linode.com/ HTTP/1.1 みたいなのを取り出す
  (ppcre:register-groups-bind (command url version)
      ("(.*) (.*) (.*)" (rcv-line stream))
    (declare (ignore version))
    ;; ヘッダをパースして
    (let ((headers (series:choose-if
                    (lambda (header)
                      (not (member (car header) '("Keep-Alive"
                                                  "Proxy-Connection")
                                   :test #'string=)))
                    (parse-header stream))))
      ;; リクエストを処理。めんどうなので HTTP/1.0 で
      (request command (puri:parse-uri url) "HTTP/1.0" headers stream))))

(defun parse-header (stream)
  "ヘッダをパースする"
  (#M(lambda (line)
       (ppcre:register-groups-bind (var value) ("(.*?): (.*)" line)
         (cons var value)))
     (read-header-part stream)))

(defun read-header-part (stream)
  "空行までのヘッダ部分を読み込む"
  (series:scan
   (series:collect ;  collect を入れないと scan-stream で何故かブロックしてしまう。
       (series:until-if
        (lambda (x) (string= x ""))
        (series:scan-stream stream #'rcv-line)))))

(defun request (command uri version headers client-stream)
  "本来のサーバにリクエストを投げてクライアントにレスポンスを返す"
  (let ((port (or (puri:uri-port uri) 80))
        (path (compute-path uri))
        (host (puri:uri-host uri)))
    (usocket:with-client-socket (server-socket
                                 server-stream
                                 host
                                 port
                                 :element-type '(unsigned-byte 8))
      (let ((server-stream (flexi-streams:make-flexi-stream server-stream)))
        ;; リクエストを送信
        (request-send server-stream command path version headers)
        ;; レスポンスを読み込みながらクライアントに返す
        (request-recieve server-stream client-stream)))))

(defun compute-path (uri)
  (q:string+
   (or (puri:uri-path uri) "/")
   (q:awhen (puri:uri-fragment uri)
     (q:string+ "#" q:it))
   (q:awhen (puri:uri-query uri)
     (q:string+ "?" q:it))))

(defun request-send (stream command path version headers)
  ;; 標準出力にもはきたいのでサーバのストリームに標準出力をくっつける
  (let ((out (make-broadcast-stream stream *standard-output*)))
    ;; GET / HTTP/1.1 みたいなのをサーバに送信
    (snd-line #"""#,command #,path #,version""" out)
    ;; ヘッダをサーバに送信
    (write-headers out headers)
    ;; ヘッダの終りを送信
    (snd-line "" out)
    ;; POST の場合
    (when (string-equal command "POST")
      nil)
    ;; ストリームをフラッシュ
    (force-output out)))

(defun request-recieve (server-stream client-stream)
  "サーバから受信してクライアントにそのまま送信する"
  ;; 標準出力にもはきたいのでクライアントのストリームに標準出力をくっつける
  (let ((out (make-broadcast-stream client-stream *standard-output*)))
    ;; レスポンスを読み込みながらクライアントに返す
    (snd-line (rcv-line server-stream) out) ; ステータス
    (let ((headers (parse-header server-stream)))
      (write-headers out headers)       ; ヘッダ
      (snd-line "" out)
      (if (text-content-p headers)
          ;; テキスト
          (series:collect-stream
           out (series:scan-stream server-stream #'read-char) #'write-char)
          ;; バイナリ
          (series:collect-stream
           client-stream (series:scan-stream server-stream #'read-byte)
           #'write-byte)))
    ;; ストリームをフラッシュ
    (force-output out)))

(defun write-headers (stream headers)
  (series:collect-stream stream
                         (#M(lambda (x)
                              #"""#,(car x): #,(cdr x)""")
                            headers)
                         #'snd-line))

(defun snd-line (value stream)
  "1行出力"
  (princ value stream)
  (princ #\Return stream)
  (princ #\Newline stream))

(defun rcv-line (stream &optional (eof-error-p nil) eof-value)
  "1行入力"
  (let ((line (read-line stream eof-error-p eof-value)))
    (when line
      (string-trim '(#\Return #\Newline) line))))

(defun text-content-p (headers)
  "内容がテキストか否か"
  nil)
;;  (q:awhen (series:collect-first
;;            (series:choose-if (lambda (x) (string= (car x) "Content-Type"))
;;                              headers))
;;    (member (cdr q:it)
;;            '("text")
;;            :test #'q:string-start-p)))