#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))