The standalone Gerbil httpd (mighty-gerbils#1141)

This brings to life the standalone httpd.

TODO:
- [x] testing
- [x] add ensemble support
- [x] unit tests

Follow up:
- [ ] documentation/tutorial

src/gerbil/main.ss

@@ -67,6 +67,7 @@ package: gerbil
     ("tags"        "gxtags")
     ("prof"        "gxprof")
     ("ensemble"    "gxensemble")
+    ("httpd"       "gxhttpd")
     ("interactive" "gxi")
     ("compile"     "gxc")))
 
@@ -81,6 +82,7 @@ package: gerbil
     ("tags"        "gxtags" "-h")
     ("prof"        "gxprof" "-h")
     ("ensemble"    "gxensemble" "help")
+    ("httpd"       "gxhttpd" "-h")
     ("interactive" "gxi" "-h")
     ("compile"     "gxc" "-h")))
 
@@ -106,6 +108,7 @@ package: gerbil
   (displayln "  tags                             create emacs tags (gxtags)")
   (displayln "  prof                             profile a dynamic executable module (gxprof)")
   (displayln "  ensemble                         invoke the gerbil actor ensemble manager (gxensemble)")
+  (displayln "  httpd                            invoke the gerbil httpd (gxhttpd)")
   (displayln "  interactive                      invoke the gerbil interpreter (gxi)")
   (displayln "  compile                          invoke the gerbil compiler (gxc)")
   (displayln "  help <cmd>                       display help for a tool command")

src/misc/http-perf/hellod.ss

@@ -3,7 +3,8 @@
         :std/cli/getopt
         :std/misc/threads
         :std/net/httpd
-        :std/sugar)
+        :std/sugar
+        :gerbil/runtime/thread)
 (export main)
 
 (def (run-server address count)

src/std/build-spec.ss

@@ -313,6 +313,7 @@
     (gxc: "net/httpd/handler"  ,@(include-gambit-sharp))
     "net/httpd/server"
     "net/httpd/file"
+    "net/httpd/logger"
     "net/httpd/api"
     "net/httpd"
     "net/sasl"

src/std/io/file.ss

@@ -15,8 +15,7 @@
         default-file-writer-flags)
 (declare (not safe))
 
-(defstruct file-io (fd closed?)
-  )
+(defstruct file-io (fd closed?))
 
 (defstruct (input-file-io file-io) ()
   final: #t)

src/std/mime/types.ss

@@ -6,9 +6,12 @@
 
 (def (get-mime-type name) (hash-get mime-types name))
 (def (extension->mime-type ext) (hash-get mime-extensions ext))
+
 (def (path-extension->mime-type-name path)
-  (def mt (extension->mime-type (string-trim (path-extension path) #\.)))
-  (and mt (mime-type-name mt)))
+  (alet (ext (path-extension path))
+    (let (ext (substring ext 1 (string-length ext)))
+      (alet (mt (extension->mime-type ext))
+        (&mime-type-name mt)))))
 
 (define-mime-types
   "./mime.types"

src/std/net/httpd/api.ss

@@ -1,24 +1,28 @@
 ;;; -*- Gerbil -*-
 ;;; ̧© vyzo
 ;;; httpd api
-(import ./base
+(import :std/interface
+        ./base
         ./control
         ./mux
         ./handler
         ./file
+        ./logger
         ./server)
 (export start-http-server!
         stop-http-server!
         remote-stop-http-server!
         current-http-server
         http-register-handler
 
+        (interface-out Mux)
         make-default-http-mux
         make-recursive-http-mux
         make-static-http-mux
         make-recursive-static-http-mux
         make-custom-http-mux
 
+        http-request
         http-request?
         http-request-method http-request-url http-request-path http-request-params
         http-request-proto http-request-client http-request-headers
@@ -41,6 +45,8 @@
         http-response-write-condition
         condition-handler
 
+        make-request-logger
+
         Continue
         Switching-Protocols
         OK

src/std/net/httpd/file.ss

@@ -12,12 +12,11 @@
 (declare (not safe))
 
 (def (http-response-file res headers path)
-  (let (reader (open-file-reader path))
-    (using (reader :- Reader)
-      (try
-       (http-response-write-file res headers reader)
-       (finally
-        (reader.close))))))
+  (using (reader (open-file-reader path) :- Reader)
+    (try
+     (http-response-write-file res headers reader)
+     (finally
+      (reader.close)))))
 
 (def (http-response-write-file res headers reader)
   (using (reader :- Reader)

src/std/net/httpd/handler.ss

@@ -16,6 +16,7 @@
                     :std/misc/string))
 
 (export http-request-handler
+        http-request
         http-request?
         http-request-method http-request-url http-request-path http-request-params
         http-request-proto http-request-client http-request-headers
@@ -44,7 +45,7 @@
 (defstruct http-response (buf sock output close?)
   final: #t )
 
-(def (http-request-handler sock get-handler)
+(def (http-request-handler sock get-handler request-logger)
   (using (sock :- StreamSocket)
     (def ibuf (get-input-buffer sock))
     (def obuf (get-output-buffer sock))
@@ -71,6 +72,9 @@
              (http-response-write res 400 [] #f)
              (raise 'abort)))
 
+          (when request-logger
+            (request-logger req))
+
           (let* ((method  req.method)
                  (path    req.path)
                  (proto   req.proto)
@@ -180,7 +184,9 @@
              (else
               (error "Bad response body; expected string, u8vector, or #f" body))))
            (headers
-            (cons (cons "Content-Length" (number->string len)) headers))
+            (if (assoc "Content-Length" headers)
+              headers
+              (cons (cons "Content-Length" (number->string len)) headers)))
            (headers
             (if res.close?
               (cons '("Connection" . "close") headers)

src/std/net/httpd/logger.ss

@@ -0,0 +1,151 @@
+;;; -*- Gerbil -*-
+;;; © vyzo
+;;; embedded HTTP/1.1 server; (rotating) request logger
+(import :std/sugar
+        :std/contract
+        :std/io
+        (only-in :std/os/fcntl O_CREAT O_APPEND)
+        :std/net/address
+        :std/misc/process
+        :gerbil/gambit
+        ./handler)
+(export make-request-logger)
+(declare (not safe))
+
+(def (make-request-logger path rotate: (rotate-size (expt 2 22)))
+  (let (logger-thread
+        (spawn/name 'http-request-logger request-logger path rotate-size))
+    (lambda (req)
+      (thread-send logger-thread (cons (##current-time-point) req)))))
+
+(def (request-logger path rotate-size)
+  (let*  ((exists? (file-exists? path))
+          (current-size
+           (if exists?
+             (file-info-size (file-info path))
+             0))
+          (output
+           (open-file-writer path flags: (if exists? O_APPEND O_CREAT)))
+          (writer
+           (open-buffered-writer output)))
+
+    (using ((output :- Writer)
+            (writer :- BufferedWriter))
+
+      (def (write-ip4-address ip)
+        (let loop ((i 0) (wr 0))
+          (let (next (u8vector-ref ip i))
+            (cond
+             ((fx< next 10)
+              (writer.write-u8 (fx+ next 48))
+              (if (fx< i 3)
+                (begin
+                  (writer.write-char #\.)
+                  (loop (fx+ i 1) (fx+ wr 2)))
+                (fx+ wr 1)))
+             ((fx< next 100)
+              (writer.write-u8 (fx+ (fxquotient next 10) 48))
+              (writer.write-u8 (fx+ (fxremainder next 10) 48))
+              (if (fx< i 3)
+                (begin
+                  (writer.write-char #\.)
+                  (loop (fx+ i 1) (fx+ wr 3)))
+                (fx+ wr 2)))
+             (else
+              (writer.write-u8 (fx+ (fxquotient next 100) 48))
+              (let (next (fxremainder next 100))
+                (writer.write-u8 (fx+ (fxquotient next 10) 48))
+                (writer.write-u8 (fx+ (fxremainder next 10) 48))
+                (if (fx< i 3)
+                  (begin
+                    (writer.write-char #\.)
+                    (loop (fx+ i 1) (fx+ wr 4)))
+                  (fx+ wr 3))))))))
+
+      (def (write-ip6-address ip)
+        ;; TODO optimize this
+        (writer.write-string (ip6-address->string ip)))
+
+      (def (log-request ts req)
+        (using (req :- http-request)
+          (let* ((wr 0)
+                 ;; timestamp
+                 (wr (fx+ wr (writer.write-string (number->string (exact (floor ts))))))
+                 (wr (fx+ wr (writer.write-char #\space)))
+                 ;; client IP
+                 (wr (fx+ wr (let (ip (car req.client))
+                               (case (u8vector-length ip)
+                                 ((4) (write-ip4-address ip))
+                                 ((6) (write-ip6-address ip))
+                                 (else
+                                  (writer.write-string "???"))))))
+                 (wr (fx+ wr (writer.write-char #\space)))
+                 ;; request protocol
+                 (wr (fx+ wr (writer.write-string req.proto)))
+                 (wr (fx+ wr (writer.write-char #\space)))
+                 ;; request method
+                 (wr (fx+ wr (writer.write-string
+                              (if (symbol? req.method)
+                                (symbol->string req.method)
+                                req.method))))
+                 (wr (fx+ wr (writer.write-char #\space)))
+                 ;; URL
+                 (wr (fx+ wr (writer.write-string req.url)))
+                 (wr (fx+ wr (writer.write-char #\newline))))
+            (set! current-size (fx+ current-size wr)))))
+
+      (while #t
+        (with ([ts . req] (thread-receive))
+          (log-request ts req))
+
+        ;; coalesce to avoid extraneous flushes
+        (let coalesce ()
+          (match (thread-receive .1 #f)
+            ([ts . req]
+             (log-request ts req)
+             (when (fx< current-size rotate-size)
+               (coalesce)))
+            (else
+             (writer.flush))))
+
+        ;; check if we need to rotate
+        (when (fx>= current-size rotate-size)
+          (writer.flush)
+          (output.close)
+          (log-rotate! path)
+          (set! output (open-file-writer path flags: O_CREAT))
+          (writer.reset! output #f)
+          (set! current-size 0))))))
+
+(def (log-rotate! path)
+  (let* ((log0 (string-append path ".1"))
+         (log1 (string-append path ".1.gz"))
+         (log2 (string-append path ".2.gz"))
+         (log3 (string-append path ".3.gz"))
+         (log4 (string-append path ".4.gz")))
+    (cond
+     ((file-exists? log4)
+      (delete-file log4)
+      (rename-file log3 log4)
+      (rename-file log2 log3)
+      (rename-file log1 log2)
+      (rename-file path log0)
+      (invoke "gzip" [log0]))
+     ((file-exists? log3)
+      (rename-file log3 log4)
+      (rename-file log2 log3)
+      (rename-file log1 log2)
+      (rename-file path log0)
+      (invoke "gzip" [log0]))
+     ((file-exists? log2)
+      (rename-file log2 log3)
+      (rename-file log1 log2)
+      (rename-file path log0)
+      (invoke "gzip" [log0]))
+     ((file-exists? log1)
+      (rename-file log1 log2)
+      (rename-file path log0)
+      (invoke "gzip" [log0]))
+     (else
+      (rename-file path log0)
+      (invoke "gzip" [log0])))))

src/std/net/httpd/server.ss

@@ -21,10 +21,11 @@
 (def (start-http-server! mux: (mux (make-default-http-mux))
                          backlog: (backlog 10)
                          sockopts: (sockopts [SO_REUSEADDR])
+                         request-logger: (request-logger #f)
                          . addresses)
   (start-logger!)
   (let (socks (map (cut http-listen <> backlog: backlog sockopts: sockopts) addresses))
-    (let (srv (spawn/group 'http-server http-server socks (Mux mux)))
+    (let (srv (spawn/group 'http-server http-server socks (Mux mux) request-logger))
       (current-http-server srv)
       srv)))
 
@@ -41,14 +42,16 @@
     (else
      (tcp-listen addr backlog: backlog sockopts: sockopts))))
 
-(def (http-server socks mux)
+(def (http-server socks mux request-logger)
   (using (mux :- Mux)
     (def acceptors
       (parameterize ((current-http-server (current-thread)))
         (map
           (lambda (sock)
             (spawn/name 'http-server-accept
-                        http-server-accept sock (cut mux.get-handler <> <>)))
+                        http-server-accept sock
+                        (cut mux.get-handler <> <>)
+                        request-logger))
           socks)))
 
     (def (shutdown!)
@@ -99,12 +102,13 @@
      (finally
       (shutdown!)))))
 
-(def (http-server-accept sock get-handler)
+(def (http-server-accept sock get-handler request-logger)
   (using (sock :- ServerSocket)
     (def (loop)
       (let (clisock (sock.accept))
         (spawn/name 'http-request-handler
-                    http-request-handler (StreamSocket clisock) get-handler)
+                    http-request-handler (StreamSocket clisock)
+                    get-handler request-logger)
         (loop)))
 
     (let again ()