229 lines
7.6 KiB
Racket
229 lines
7.6 KiB
Racket
#lang racket/base
|
|
|
|
(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
|
|
gemini-request-write
|
|
gemini-response-write
|
|
gemini-make-success-meta)
|
|
|
|
;; protocol
|
|
|
|
(define gmi-codes
|
|
(hash 'input 10
|
|
'sensitive-input 11
|
|
'success 20
|
|
'redirect-temp 30
|
|
'redirect-perm 31
|
|
'failure-temp 40
|
|
'server-unavailable 41
|
|
'cgi-error 42
|
|
'proxy-error 43
|
|
'slow-down 44
|
|
'failure-perm 50
|
|
'not-found 51
|
|
'gone 52
|
|
'proxy-fail 53
|
|
'bad-request 59
|
|
'cert-required 60
|
|
'cert-not-authorized 61
|
|
'cert-not-valid 62))
|
|
(define gmi-rev-codes
|
|
(for/hash ([(k v) (in-hash gmi-codes)])
|
|
(values v k)))
|
|
|
|
;; Int Str
|
|
(struct gmi-rsp [status meta-line] #:transparent)
|
|
;; Str Hash Port
|
|
(struct gmi-rsp:success gmi-rsp [mime extra-fields body] #:transparent)
|
|
|
|
;; port -> url
|
|
;; reads a gemini request (returns the URL)
|
|
(define (gemini-request-read [port (current-input-port)])
|
|
(let ([line (read-line port 'any)])
|
|
(string->url port)))
|
|
|
|
;; util: parse success meta text
|
|
;; str -> mimetype fields-hash
|
|
(define (gemini-parse-success-meta meta)
|
|
(match (regexp-split #px"; *" meta)
|
|
[(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)))]
|
|
[_ (values item #t)])))]
|
|
['() (raise (exn:fail:network "gmi protocol error" (current-continuation-marks)))]))
|
|
|
|
;; port -> gmi-rsp
|
|
(define (gemini-response-read [port (current-input-port)])
|
|
(let ([line (read-line port 'any)])
|
|
(match (regexp-match #px"^([0-9]{2}) (.*?)$" line)
|
|
[(list _ status-str meta)
|
|
(let ([status (string->number status-str)])
|
|
(match status
|
|
[(? (curry = (hash-ref gmi-codes 'success)))
|
|
(let-values ([(mime extra-fields) (gemini-parse-success-meta meta)])
|
|
(gmi-rsp:success status meta mime extra-fields port))]
|
|
[_
|
|
(close-input-port port)
|
|
(gmi-rsp status meta)]))]
|
|
[_ (raise (exn:fail:network "gmi protocol error" (current-continuation-marks)))])))
|
|
|
|
;; url port ->
|
|
(define (gemini-request-write req-url [port (current-output-port)])
|
|
(write-string (format "~a\r\n" (url->string req-url)) port))
|
|
|
|
;; gmi-rsp port ->
|
|
(define (gemini-response-write resp [port (current-output-port)])
|
|
(write-string (format "~a ~a\r\n" (gmi-rsp-status resp) (gmi-rsp-meta-line resp)) port))
|
|
|
|
;; string hash -> string
|
|
(define (gemini-make-success-meta mime extra-fields)
|
|
(string-join (cons mime (for/list ([(k v) (in-hash extra-fields)])
|
|
(match v
|
|
[#t k]
|
|
[_ (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))
|
|
|