167 lines
6.3 KiB
Scheme
167 lines
6.3 KiB
Scheme
;;; template.scm
|
|
|
|
;; This file handles the code related to user-supplied template files that
|
|
;; provide GemBooru with procedures that can generate each page on-the-fly.
|
|
;;
|
|
;; TODO: Allow the admin to split their templates into multiple files/modules
|
|
;; TODO: Figure out how to return a module from the sandbox
|
|
|
|
(define-module (template)
|
|
#:export (try-respond-page
|
|
generator-by-name
|
|
build-templates-from-files
|
|
build-templates make-templates
|
|
templates?
|
|
templates-index
|
|
templates-post
|
|
templates-search))
|
|
|
|
(use-modules (srfi srfi-9)
|
|
(ice-9 sandbox)
|
|
(web uri)
|
|
(gemini)
|
|
(config))
|
|
|
|
|
|
(define-record-type <templates>
|
|
;; The set of template procedures to generate pages dynamically
|
|
;; TODO: Fill this out as we add new pages. There should be a template for
|
|
;; EVERY page in the capsule (excluding the titan-only paths like /upload)
|
|
(make-templates index post search)
|
|
templates?
|
|
(index templates-index)
|
|
(post templates-post)
|
|
(search templates-search))
|
|
|
|
|
|
(define* (build-templates #:key (index default-template)
|
|
(post default-template)
|
|
(search default-template))
|
|
;; Higher-level interface to initialise the templates record
|
|
(make-templates index post search))
|
|
|
|
|
|
(define (default-template first . rest)
|
|
;; If you see this page, I fucked up and I apologise in advance :(
|
|
`((h1 "Uh oh!")
|
|
(p "Looks like you forgot to set a template generator"
|
|
"This page shouldn't've been possible to encounter!"
|
|
"Please report this bug to the developers!")))
|
|
|
|
|
|
(define sandbox-bindings
|
|
;; We should give the user access to inspect but not mutate any types we
|
|
;; provide them, such as URIs. Be careful to only provide pure bindings where
|
|
;; at all possible
|
|
`(((ice-9 format) format)
|
|
((web uri) build-uri uri?
|
|
build-uri-reference uri-reference?
|
|
build-relative-ref relative-ref?
|
|
uri-scheme uri-host uri-port uri-path uri-query
|
|
string->uri uri->string uri-decode uri-encode
|
|
string->uri-reference string->relative-ref
|
|
split-and-decode-uri-path encode-and-join-uri-path)
|
|
((config) options? options-host-uri)
|
|
((sandbox) export
|
|
base-context? base-context-uri
|
|
post-context?
|
|
post-context-base post-context-hash post-context-extension
|
|
search-context?
|
|
search-context-base search-context-result-ids)
|
|
,@all-pure-bindings))
|
|
|
|
|
|
(define (eval-templates port)
|
|
;; Read and evaluate the templates file in a sandbox
|
|
|
|
(define (read-all port)
|
|
;; Get all expressions in the given port and wrap them in a begin block
|
|
`(begin
|
|
,@(let loop ((exprs (list)))
|
|
(let ((expr (read port)))
|
|
(if (eof-object? expr)
|
|
(reverse exprs)
|
|
(loop (cons expr exprs)))))))
|
|
|
|
(define (valid-templates? templates)
|
|
;; Check if x is an association list, with the proper structure. We want
|
|
;; every element to be of the form ('symbol . proc)
|
|
|
|
(define (valid-element? element)
|
|
;; TODO: Verify that the procedures have the right signature
|
|
;; Perhaps macros to prevent them from using the wrong signature
|
|
(and (pair? element)
|
|
(symbol? (car element))
|
|
(procedure? (cdr element))))
|
|
|
|
(or (null? templates)
|
|
(and (pair? templates)
|
|
(valid-element? (car templates))
|
|
(valid-templates? (cdr templates)))))
|
|
|
|
(let* ((expr (read-all port))
|
|
(templates (eval-in-sandbox expr #:bindings sandbox-bindings)))
|
|
(if (valid-templates? templates)
|
|
templates
|
|
(error "Invalid templates!")))) ; TODO: Better error messaging here
|
|
|
|
|
|
(define (build-templates-from-files options)
|
|
;; Create a templates record by evaluating the scheme code in port in a
|
|
;; sandbox, then converting the returned alist into the record type
|
|
;; ALL templates must be explicitly present or it'll throw an error
|
|
|
|
(define (try-call-with-input-file file proc)
|
|
;; Only apply proc to file if the file exists and is readable
|
|
(if (access? file R_OK)
|
|
(call-with-input-file file proc)
|
|
(list)))
|
|
|
|
(define (alist->arguments alist)
|
|
;; Create a list of arguments to apply to build-templates from the alist
|
|
;; It isn't strictly necessary to do it like this, but I like it :)
|
|
(let ((keys '((generate/index #:index . "/")
|
|
(generate/post #:post . "/post")
|
|
(generate/search #:search . "/search"))))
|
|
(define (key->argument key)
|
|
;; Convert the key to a keyword and procedure, or error
|
|
(let* ((proc-name (car key))
|
|
(kwarg (cadr key))
|
|
(path (cddr key))
|
|
(proc (assoc-ref alist proc-name)))
|
|
(if proc
|
|
(list kwarg
|
|
(lambda (x . xs)
|
|
;; TODO: Make time/alloc limits user-configurable?
|
|
(call-with-time-and-allocation-limits 1 (* 10 1024 1024)
|
|
(lambda () (apply proc x xs)))))
|
|
(error "Template generator not found for " path))))
|
|
|
|
(apply append (map key->argument keys))))
|
|
|
|
(let* ((user-path (options-templates options))
|
|
(default-path "/usr/share/gembooru/template.scm")
|
|
(user-alist (try-call-with-input-file user-path eval-templates))
|
|
(default-alist (try-call-with-input-file default-path eval-templates))
|
|
;; If a key is specified in both, we want to prefer the user's
|
|
(alist (append user-alist default-alist)))
|
|
(apply build-templates (alist->arguments alist))))
|
|
|
|
|
|
(define (try-respond-page i/o uri thunk)
|
|
;; Try to generate the page using thunk, or respond with a failure
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(format #t "[ERROR]: ~a\n" exn)
|
|
(respond/failure i/o status/failure/cgi
|
|
"Failed to generate page: ~s" (uri-path uri)))
|
|
(lambda ()
|
|
(respond/success i/o "text/gemini" (sgt->string (thunk))))
|
|
#:unwind? #t))
|
|
|
|
|
|
(define (generator-by-name options name)
|
|
;; Return the generator function corresponding to the given name
|
|
(let* ((templates (options-templates options))
|
|
(proc (string->symbol (format #f "templates-~a" name))))
|
|
(eval `(,proc ,templates) (interaction-environment))))
|