httpd.scm

(use gauche.net)
(use util.match)
(use rfc.822)
(use rfc.uri)
(use text.tree)
(use text.html-lite)
(use www.cgi)

(define (main args)
  (let ((server-port (make-server-socket 'inet 8080 :reuse-addr? #t)))
    (guard (e [else (socket-close server-port) (raise e)])
      (let loop ((client (socket-accept server-port)))
        (handle-request (get-request (socket-input-port client))
                        (socket-output-port client))
        (socket-close client)
        (loop (socket-accept server-port))))))

(define (get-request iport)
  (rxmatch-case (read-line iport)
    [test eof-object? 'bad-request]
    [#/^GET\s+(\S+)\s+HTTP\/\d+\.\d+$/ (_ abs-path)
     (cons abs-path (rfc822-header->list iport))]
    [#/^(OPTIONS|HEAD|POST|PUT|DELETE|TRACE)/ () 'not-implemented]
    [else 'bad-request]))

(define (handle-request request oport)
  (match request
    ['bad-request     (display "HTTP/1.1 400 Bad Request\r\n\r\n" oport)]
    ['not-implemented (display "HTTP/1.1 501 Not Implemented\r\n\r\n" oport)]
    [(abs-path . headers)
     (receive (auth path q frag) (uri-decompose-hierarchical abs-path)
       (let1 content
           (tree->string
            (generate-content path (cgi-parse-parameters :query-string (or q ""))))
         (display "HTTP/1.1 200 OK\r\n" oport)
         (display "Content-Type: text/html\r\n" oport)
         (display #`"Content-Length: ,(string-length content)\r\n" oport)
         (display "\r\n" oport)
         (display content oport)))]))

(define (generate-content path params)
  (html:html
   (html:head (html:title "Hi"))
   (html:body (html:h1 "Welcome to simple httpd")
              (html:p "Path : " (html-escape-string path))
              (map (lambda (p)
                     (html:p (html-escape-string (car p)) " : "
                             (html-escape-string (cdr p))))
                   params))))