[Gauche] 簡易HTTPサーバ

Gaucheで簡易HTTPサーバをつくってみました。以下の特徴があります。

• GETしかできません（というか、メソッドを判断していません）。
• セキュリティに配慮していません。

ソースコードは、以下の通りです。

#! gosh

(use file.util)
(use gauche.fcntl)
(use gauche.interactive)
(use gauche.net)
(use gauche.selector)

(define (ghttpd-process-request sock document-root)
  (let* (
      (read-port (socket-input-port sock)) 
      (write-port (socket-output-port sock))
      (columns (string-split (read-line read-port) char-whitespace?))
      (path (ref columns 1))
      (real-path (substring path 1 (string-size path)))
      (abs-path (build-path document-root real-path)))
    (guard (e (else 
        (display "HTTP/1.0 404 Not Found\r\nConnection: close\r\n\r\n" write-port)
        (print e)
        (flush)))
      (let ((file-port (open-input-file abs-path)))
        (define (copy-port from to)
          (let ((buffer (read-block 10240 from)))
            (if (eof-object? buffer)
              #t
              (begin
                (display buffer to)
                (copy-port from to)))))

        (display "HTTP/1.0 200 OK\r\nConnection: close\r\n\r\n" write-port)
        (copy-port file-port write-port)
        (close-input-port file-port)
        (close-output-port write-port)
        (close-input-port read-port)))))

(define (main args)
  (let (
      (sock (make-server-socket 'inet 10080)) 
      (terminated #f) 
      (document-root "."))
    (define (mainloop sock)
      (let ((selector (make <selector>)))
        (define (accept-client fd flags)
          (let accept ((sock sock))
            (guard (e
              ((<system-error> e) 
                (let ((errno (ref e 'errno))) 
                  (if (or (equal? errno EAGAIN) (equal? errno ENETDOWN) (equal? errno EPROTO) (equal? errno ENOPROTOOPT) (equal? errno EHOSTDOWN) (equal? errno ENONET) (equal? errno EHOSTUNREACH) (equal? errno EOPNOTSUPP) (equal? errno ENETUNREACH))
                    (accept sock)
                    (raise e)))))
                (let ((client-sock (socket-accept sock)))
                  (if (equal? (class-of client-sock) <socket>)
                    (begin
                      (ghttpd-process-request client-sock document-root)
                      (socket-close client-sock))
                    (accept sock))))))

        (selector-add! selector (socket-fd sock) accept-client '(r))
        (selector-select selector 1000000)
        (if (not terminated)
          (mainloop sock)
          #t)))

    (set-signal-handler! SIGTERM (lambda (sig) (set! terminated #t)))
    (set-signal-handler! SIGPIPE #f)
    (let ((fd (socket-fd sock)))
      (sys-fcntl fd F_SETFD (logior O_NONBLOCK (sys-fcntl fd F_GETFD))))
    (mainloop sock)
    (socket-close sock)))

;; vim: tabstop=2 shiftwidth=2 expandtab softtabstop=2

所感

先日のトークライブ (id:SumiTomohiko:20080312:1205337867) で、「Schemeの書き方は、手続き型言語とは違う」といった旨の話がありましたが、どういうのがSchemeっぽい書き方なのかつかめません。上のHTTPサーバも、手続き型言語と同じような考え方で書いてしまいました。