67 lines
3 KiB
Scheme
67 lines
3 KiB
Scheme
;;; gembooru.scm ;;;
|
|
|
|
(use-modules (srfi srfi-11)
|
|
(ice-9 match)
|
|
(web uri)
|
|
(gnutls)
|
|
(gembooru net connection)
|
|
(gembooru net gemini)
|
|
(gembooru config)
|
|
(gembooru config template)
|
|
(gembooru endpoint index)
|
|
(gembooru endpoint search)
|
|
(gembooru endpoint upload)
|
|
(gembooru endpoint post))
|
|
|
|
|
|
(define (handle-client session client options i/o)
|
|
;; Handle incoming client connections by confirming the provided certificate
|
|
;; hasn't expired yet, and then routing to the correct handler functions
|
|
|
|
(define* (parse-and-route-request client options i/o #:optional certificate)
|
|
;; Parse the request and route to the correct endpoint handler
|
|
|
|
(define (route-request uri parameters)
|
|
;; TODO: Should probably log this in a dedicated access file
|
|
(format #t "~a: Requested ~a~@[ with certificate ~s~]\n"
|
|
(client->string client) (uri->string uri)
|
|
(fingerprint-client-certificate session))
|
|
|
|
(let ((path (uri-path uri)) (query (uri-query uri)))
|
|
(cond ((gemini-uri? uri)
|
|
(match (split-and-decode-uri-path path)
|
|
(("upload") (endpoint/upload/gemini i/o uri))
|
|
(("search") (endpoint/search i/o options uri))
|
|
(("post" "view" id) (endpoint/view-post i/o options id))
|
|
(("post" "edit" id) (endpoint/edit-post i/o options id query))
|
|
(("post" id) (endpoint/post i/o options uri id))
|
|
(() (endpoint/index i/o options uri))
|
|
(_ (endpoint/not-found i/o uri))))
|
|
((titan-uri? uri)
|
|
(match (split-and-decode-uri-path path)
|
|
(("upload") (apply endpoint/upload/titan i/o options parameters))
|
|
(_ (endpoint/not-found i/o uri)))))))
|
|
|
|
(let-values (((uri parameters) (parse-request-headers i/o)))
|
|
(if uri
|
|
(route-request uri parameters)
|
|
(respond/failure i/o status/failure/bad
|
|
"Invalid request!"))))
|
|
|
|
;; Make sure any provided client certificate isn't expired before proceeding
|
|
;; Endpoints that use the certificate must do further verification themselves
|
|
(let ((certificate (client-certificate session)))
|
|
(cond ((not certificate) (parse-and-route-request client options i/o))
|
|
((member certificate-status/expired (peer-certificate-status session))
|
|
(respond/certificate i/o status/certificate/invalid "Expired"))
|
|
(else (parse-and-route-request client options i/o certificate)))))
|
|
|
|
|
|
(let* ((options (build-options/command-line))
|
|
(templates (build-templates-from-files options))
|
|
(credentials (credentials-from-file (options-certificate options)
|
|
(options-private-key options))))
|
|
(set-options-templates! options templates)
|
|
|
|
(start-ssl-server credentials options handle-client
|
|
#:port (uri-port (options-host-uri options))))
|