98 lines
3.5 KiB
Scheme
98 lines
3.5 KiB
Scheme
;;; /etc/gembooru/template.scm
|
|
|
|
;; This file is loaded by GemBooru at runtime within a sandbox. It provides
|
|
;; useful bindings to access the current state of the program, as well as a
|
|
;; set of safe bindings for us to write arbitrary code (specifically, we're
|
|
;; provided with all-pure-bindings, which means no mutable state).
|
|
;;
|
|
;; GemBooru expects this file to return an association list where fields are
|
|
;; pairs of symbols and functions, each one corresponding to a page on the
|
|
;; capsule. Each function is expected to take in a specific set of arguments,
|
|
;; and return valid SGT (S-GemText; see mod/gemini.scm's write/sgt for details).
|
|
;;
|
|
;; Any unrecognised names in the alist will be ignored, and any that aren't
|
|
;; provided fall back to default located in /usr/share/gembooru/template.scm.
|
|
;; Failing that, GemBooru will simply exit with an error.
|
|
;;
|
|
;; Please be aware that these functions will be called every time the page is
|
|
;; loaded, so don't get too complicated with them, even though you have a real
|
|
;; programming language to work with. They WILL get killed if they use too
|
|
;; many resources, or take too long to execute.
|
|
;;
|
|
;; Final note: this interface is currently a work-in-progress. Everything about
|
|
;; it could change at any time, if something is found not to work or could be
|
|
;; made better than it is.
|
|
|
|
(define* (uri-from-reference reference-uri #:key
|
|
(scheme (uri-scheme reference-uri))
|
|
(host (uri-host reference-uri))
|
|
(port (uri-port reference-uri))
|
|
(path (uri-path reference-uri))
|
|
(query (uri-query reference-uri)))
|
|
;; Generate a URI with a reference URI as default values
|
|
(build-uri scheme #:host host #:port port #:path path #:query query))
|
|
|
|
|
|
|
|
;;; Consistent SGT URI generators for use between all templates ;;;
|
|
|
|
(define (home-link uri)
|
|
`(a ,(uri-from-reference uri #:path "/") "Go home"))
|
|
|
|
(define (search-link uri)
|
|
`(a ,(uri-from-reference uri #:query #f #:path "/search") "Search"))
|
|
|
|
(define (upload-link uri)
|
|
`(a ,(uri-from-reference uri #:scheme 'titan #:path "/upload") "Upload"))
|
|
|
|
(define (post-link uri id ext)
|
|
`(a ,(uri-from-reference uri #:path (format #f "/post/~a" id))
|
|
,(format #f "~a.~a" id ext)))
|
|
|
|
(define (post-view-link uri id ext)
|
|
`(a ,(uri-from-reference uri #:path (format #f "/post/view/~a.~a" id ext))
|
|
"View media file"))
|
|
|
|
|
|
|
|
;;; Generator templates ;;;
|
|
|
|
(define (generate/index ctx)
|
|
;; Generate the homepage shown on / or /index
|
|
(let* ((uri (base-context-uri ctx))
|
|
(host (uri-host uri)))
|
|
`((h1 "GemBooru")
|
|
(p ,(format #f "Welcome to ~a!" host) "")
|
|
,(search-link uri)
|
|
,(upload-link uri))))
|
|
|
|
|
|
(define (generate/post ctx)
|
|
;; Generate /post/${ID}
|
|
(let* ((uri (base-context-uri (post-context-base ctx)))
|
|
(id (post-context-hash ctx))
|
|
(ext (post-context-extension ctx)))
|
|
`((h1 ,(post-context-hash ctx))
|
|
,(home-link uri)
|
|
,(post-view-link uri id ext))))
|
|
|
|
|
|
(define (generate/search ctx)
|
|
;; Generate /search
|
|
|
|
(define (post-links uri ids)
|
|
;; Generate a list of SGT links for the given ids
|
|
(map (lambda (id) (post-link uri (car id) (cdr id))) ids))
|
|
|
|
(let* ((uri (base-context-uri (search-context-base ctx)))
|
|
(ids (search-context-result-ids ctx)))
|
|
`((h1 "Search")
|
|
,(home-link uri)
|
|
,(search-link uri)
|
|
,@(post-links uri ids))))
|
|
|
|
|
|
;; Pass the generator functions back up to GemBooru
|
|
(export '(generate/index
|
|
generate/post
|
|
generate/search))
|