プログラミング言語Schemeの学び方

これに触発されてみた。
調簡易なHTTPサーバーをR7RS＋SRFIで作ってSchemeを学ぼうという話。スライド145にある項目をとりあえず列挙

• Socketの扱い
• 正規表現
• リソースの開放
• 並行処理
• 文字列の扱い

【Socketの扱い】
Scheme標準にはないのでSRFI-106を使う。サーバーSocketはこう作る。

(define server-socket (make-server-socket "8080"))

そして、こんな風に待ち受ける。

(let loop ()
  (let ((socket (socket-accept server-socket)))
    (loop))

特に何もしないソケットがリークしまくるサーバーの出来上がり。

【正規表現】
Scheme標準にはないのでSRFI-115を使う。HTTPリクエストの最初の一行をパースする正規表現はこんな感じで書ける。

(define first-line
  '(: "GET" (+ space)
      (-> path (: "/" (+ ascii))) (+ space)
      "HTTP/" (: num "." num)))

こんな感じで使う

(cond ((regexp-matches first-line line) =>
       (lambda (m)
         (let ((path (regexp-match-submatch m 'path)))
           ;; get the content of the path
           ))))

サブマッチに名前は付ける必要はないが、あるとわかりやすい。

【リソースの開放】
Schemeに便利な汎用リソース開放構文というのはないので、都度用途に合わせて作ったり標準にあるものを用いる。例えば、ポートの開放はclose-portを使い、call-with-portを使えば、正常処理後にはポートを閉じてくれる。Socketの開放はsocket-shutodownやsocket-closeを用いる。
サーバをであれば、以下のようなものが便利に使えなくもない。

(define (finish)
  (close-port in)
  (close-port out)
  (socket-shutdown socket *shut-rdwr*)
  (socket-close socket))

inとoutはソケットポートである。

【並行処理】
Scheme標準にはないのでSRFI-18を使う。SRFI-18はプリミティブなスレッドとミューテックスしか提供しないので、高度なものが必要であれば自分で作る必要がある。
投げっぱなしスレッドは以下のように作れる。

(thread-start! (make-thread (lambda () (handle-request socket))))

処理系によってはスレッドの作成は高価な場合があるので、可能であればスレッドプール等は作っておきたいところ。R6RS処理系かつSRFI-18をサポートしているのであれば、拙作の(util concurrent)が使える。

【文字列の扱い】
スライドにあるような便利なものはない。連結したければstring-append等を使う必要がある。文字列操作は高価な場合があるので(例：参照にO(n)かかる)、使える場面ではポートを使いたいところ。

さて、上記全てを踏まえて非常に簡易なGETリクエストのみに対応したHTTPサーバは以下になる。R7RSではバイナリポートと文字ポートは分かれていて、処理系によっては厳しく分けてあつかう(特にR6RS/R7RSな処理系、Sagittariusなど)ので、I/Oの部分がどうしても煩雑になる。例えば、出力の際には文字列を一旦バイナリに変換している。

(import (scheme base)
        (scheme write)
        (scheme file)
        (srfi 18)
        (srfi 106)
        (srfi 115))

;; Assume all ASCII
(define (read-binary-line in)
  (let ((out (open-output-string)))
    (let loop ((b (read-u8 in)))
      (case b
        ((#x0d)
         (case (peek-u8 in)
           ((#x0a) (read-u8 in) (get-output-string out))
           (else (write-char (integer->char b) out) (loop (read-u8 in)))))
        (else (write-char (integer->char b) out) (loop (read-u8 in)))))))

(define (handle-request socket)
  (define in (socket-input-port socket))
  (define out (socket-output-port socket))
  (define first-line
    '(: "GET" (+ space)
        (-> path (: "/" (+ ascii))) (+ space)
        "HTTP/" (: num "." num)))
  (define (finish)
    (close-port in)
    (close-port out)
    (socket-shutdown socket *shut-rdwr*)
    (socket-close socket))
  (define (http-error status e)
    (define message (string->utf8 "Not okay"))
    (report-error e)
    (write-bytevector (string->utf8 "HTTP/1.1 ") out)
    (write-bytevector (string->utf8 (number->string status)) out)
    ;; laziness...
    (write-bytevector (string->utf8 " BOO\r\n") out)
    (write-bytevector (string->utf8 "Content-Type: text/plain\r\n") out)
    (write-bytevector (string->utf8 "Content-Length: ") out)
    (write-bytevector (string->utf8
                       (number->string (bytevector-length message))) out)
    (write-bytevector (string->utf8 "\r\n\r\n") out)
    (write-bytevector message out)
    (finish))
    
  (guard (e (else (http-error 500 e)))
    (let ((line (read-binary-line in)))
      (cond ((regexp-matches first-line line) =>
             (lambda (m)
               (let ((path (regexp-match-submatch m 'path))
                     (bout (open-output-bytevector)))
                 (guard (e (else (http-error 404 e)))
                   (let ((file (string-append "." path)))
                     (call-with-port (open-binary-input-file file)
                       (lambda (in)
                         (define buf (make-bytevector 1024))
                         (let loop ((n (read-bytevector! buf in)))
                           (write-bytevector buf bout 0 n)
                           (when (= n 1024)
                             (loop (read-bytevector! buf in))))))))
                 (write-bytevector (string->utf8 "HTTP/1.1 200 OK\r\n") out)
                 (write-bytevector (string->utf8 "Content-Type: text/plain\r\n") out)
                 (let ((bv (get-output-bytevector bout)))
                   (write-bytevector (string->utf8 "Content-Length: ") out)
                   (write-bytevector (string->utf8
                                          (number->string
                                           (bytevector-length bv))) out)
                   (write-bytevector (string->utf8 "\r\n\r\n") out)
                   (write-bytevector bv out)
                   (finish)))))
            (else (http-error 403 #f))))))

(define server-socket (make-server-socket "8080"))

(display "Starting server on port 8080") (newline)
(let loop ()
  (let ((socket (socket-accept server-socket)))
    (thread-start! (make-thread (lambda () (handle-request socket))))
    (loop))

もう少し簡単に書きたいと思ったら、Sagittariusに付属している(net server)を使うか、拙作Paellaを使うと簡単にHTTPサーバが書ける。後者はサーバというよりはWebアプリが簡単に書けると言うべきか。