73 lines
3.2 KiB
Scheme
73 lines
3.2 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 post)
|
|
(gembooru endpoint tags))
|
|
|
|
|
|
(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/gemini uri path)
|
|
;; Route for Gemini endpoints
|
|
(match path
|
|
(("post" "make") (endpoint/make-post/gemini i/o uri))
|
|
(("post" "look") (endpoint/look-post i/o options uri))
|
|
(("post" "view" id) (endpoint/view-post i/o options id))
|
|
(("post" "edit" id) (endpoint/edit-post i/o options id (uri-query uri)))
|
|
(("post" id) (endpoint/post i/o options uri id))
|
|
(("tags" "make") (endpoint/make-tag i/o options (uri-query uri)))
|
|
(("tags" id) (endpoint/tag i/o options uri id))
|
|
(() (endpoint/index i/o options uri))
|
|
(_ (endpoint/not-found i/o uri))))
|
|
|
|
(define (route-request/titan uri parameters path)
|
|
;; Route for Titan endpoints
|
|
(match path
|
|
(("post" "make") (apply endpoint/make-post/titan i/o options parameters))
|
|
(_ (endpoint/not-found i/o uri))))
|
|
|
|
|
|
(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 (split-and-decode-uri-path (uri-path uri))))
|
|
(cond ((gemini-uri? uri) (route-request/gemini uri path))
|
|
((titan-uri? uri) (route-request/titan uri parameters path)))))
|
|
|
|
(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))))
|