implement server utils

gemini/main.rkt

@@ -1,10 +1,12 @@
 #lang racket/base
 
-(require racket/match racket/function racket/port racket/string
+(require racket/match racket/function racket/port racket/string racket/bool racket/path
          net/url net/url-structs net/url-string)
 
 (provide (struct-out gmi-rsp)
          (struct-out gmi-rsp:success)
+         gmi-codes
+         gmi-rev-codes
          gemini-request-read
          gemini-parse-success-meta
          gemini-response-read
@@ -55,7 +57,8 @@
     [(list meta rst ...)
      (values meta (for/hash ([item (in-list rst)])
                   (match (regexp-match-positions "=" item)
-                    [(list (cons pos _)) (values (substring item 0 pos) (substring item (add1 pos)))]
+                    [(list (cons pos _))
+                     (values (substring item 0 pos) (substring item (add1 pos)))]
                     [_ (values item #t)])))]
     ['() (raise (exn:fail:network "gmi protocol error" (current-continuation-marks)))]))
 
@@ -90,6 +93,136 @@
                               [_ (string-append k "=" v)])))
                "; "))
 
+;; server
+
+(define mimes
+  (hash #".gmi" "text/gemini"
+        #".gemini" "text/gemini"
+
+        #".json" "application/json"
+        #".jsonld" "application/ld+json"
+        #".jsonap" "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\""
+
+        #".htm" "text/html"
+        #".html" "text/html"
+
+        #".apng" "image/png"
+        #".gif" "image/gif"
+        #".jpg" "image/jpeg"
+        #".jpeg" "image/jpeg"
+        #".png" "image/png"
+        #".webp" "image/webp"
+
+        #".webm" "video/webm"
+
+        #".aac" "audio/aac"
+        #".mp3" "audio/mpeg"
+        #".opus" "audio/opus"
+        #".weba" "audio/webm"
+
+        #".xml" "application/xml"))
+(define mime-default "appliation/octet-stream")
+
+;; handlers
+;; intermediate handlers are url next-func -> gmi-rsp body-func
+;; terminating handlers are url -> gmi-rsp body-func
+
+(define default-chunk-sz 4096)
+(define default-index-files '("index.gmi" "index.gemini"))
+
+(define not-found-rsp
+  (gmi-rsp (hash-ref gmi-codes 'not-found)
+           "the requested resource was not found on this server"))
+
+(define (make-host-checker host)
+  (lambda (req next)
+    (if (or (false? (url-host req)) (string=? host (url-host req)))
+      (next req)
+      (values
+        not-found-rsp
+        #f))))
+
+;; string-or-path -> handler
+(define (make-static-handler static-path #:directory-indices? [dir-indices? #f])
+  ;; prevents path traversal
+  (define (ensure-root root path)
+    (let ([path-tmp (simplify-path (build-path root path))])
+      (if
+        (for/and ([a (in-list (explode-path root))] [b (in-list (explode-path path-tmp))])
+          (equal? a b))
+        path-tmp
+        root)))
+
+  ;; generates an index file if none is present
+  (define (generate-index fs-path orig-url)
+    (define parent-path (url-path orig-url))
+    (define links (for/list ([item (in-list (directory-list fs-path))])
+                    (struct-copy url orig-url
+                                 [path (append parent-path
+                                               ;; this couldn't possibly be more obtuse
+                                               (path/param (path-element->string item) '()))])))
+    (define links+
+      (match parent-path
+        ['() links]
+        [(list firsts ... lst) (cons (struct-copy url orig-url [path firsts]) links)]))
+
+    (define document
+      (string-join
+        (cons (format "# index of ~a\n" (url->string orig-url))
+              (map (lambda (item) (format "=> ~a" (url->string item))) links))
+        "\n"))
+    (define doc-bytes (string->bytes/utf-8 document))
+    (define doc-len (bytes-length doc-bytes))
+
+    (values (gmi-rsp (hash-ref gmi-codes 'success)
+                     (gemini-make-success-meta "text/gemini"
+                                               (hash "content-length" (number->string doc-len))))
+            (lambda (out) (write-bytes doc-bytes out))))
+
+  ;; guesses mime type by extension
+  (define (lookup-mime path)
+    (hash-ref mimes (path-get-extension path) mime-default))
+
+  ;; generates a file response
+  (define (generate-file-rsp fs-path)
+    (values
+      (gmi-rsp (hash-ref gmi-codes 'success)
+               (gemini-make-success-meta
+                 (lookup-mime fs-path)
+                 (hash "content-length" (number->string (file-size fs-path)))))
+      (lambda (out)
+        (call-with-input-file
+          fs-path
+          ;; racket people merge the hecking sendfile PR challenge 2020
+          (lambda (in)
+            (define chunk (make-bytes default-chunk-sz))
+            (let loop ()
+              (match (read-bytes-avail! chunk in)
+                [(? integer? n)
+                 (write-bytes chunk out 0 n)
+                 (loop)]
+                [(? eof-object?) (void)]
+                [_ (error "unexpected value from read-bytes-avail!")])))))))
+
+  (lambda (req)
+    (let* ([path (filter path/param-path (url-path req))]
+           [fs-path (ensure-root static-path path)])
+      (cond
+        [(directory-exists? fs-path)
+         ;; check for index files, if those are found then serve that
+         ;; otherwise if indices are enabled generate an index
+         ;; otherwise error
+         (or (for/or ([check-index (in-list default-index-files)])
+               (define new-path (build-path fs-path check-index))
+               (if (file-exists? new-path) (generate-file-rsp new-path) #f))
+             (if dir-indices?
+               (generate-index fs-path req)
+               (values not-found-rsp #f)))]
+        [(file-exists? fs-path)
+         (generate-file-rsp fs-path)]
+        [else not-found-rsp]))))
+
+
 (module+ test
   (require rackunit))