Implement dumb asset handler for development

Evgeny PisemskyThu Aug 22 10:10:00+0300 2024

ce651e9

Implement dumb asset handler for development

gitile/handler.scm

11 
;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
2+
;;;; Copyright (C) 2024 Evgeny Pisemsky <mail@pisemsky.site>
23 
;;;;
34 
;;;; SPDX-License-Identifier: AGPL-3.0-or-later
45 
;;;;

…

2324 
  #:use-module (gitile pages)
2425 
  #:use-module (gitile repo)
2526 
  #:use-module (ice-9 match)
27+
  #:use-module (ice-9 ftw)
28+
  #:use-module (ice-9 binary-ports)
2629 
  #:use-module (rnrs bytevectors)
2730 
  #:use-module (srfi srfi-9)
2831 
  #:use-module (srfi srfi-11)

…

3235 
  #:use-module (web uri)
3336 
  #:export (gitile-handler))
3437 
35-
(define (request-path-components request)
36-
  (split-and-decode-uri-path (uri-path (request-uri request))))
38+
(define-record-type <asset>
39+
  (make-asset url dir mime)
40+
  asset?
41+
  (url asset-url)
42+
  (dir asset-dir)
43+
  (mime asset-mime))
44+
45+
(define (asset-directory)
46+
  (canonicalize-path
47+
   (string-append (dirname (current-filename)) "/../assets")))
48+
49+
(define (asset-list-specific dir subdir suffix mime)
50+
  (map (lambda (name)
51+
         (make-asset (string-append "/" subdir "/" name)
52+
                     dir
53+
                     mime))
54+
       (scandir (string-append dir "/" subdir)
55+
                (lambda (item)
56+
                  (string-suffix-ci? suffix item)))))
57+
58+
(define (asset-list dir)
59+
  (append
60+
   (asset-list-specific dir "js" ".js" "text/javascript")
61+
   (asset-list-specific dir "css" ".css" "text/css")
62+
   (asset-list-specific dir "images" ".png" "image/png")
63+
   (asset-list-specific dir "images" ".svg" "image/svg+xml")))
64+
65+
(define (asset-load-data asset)
66+
  (call-with-input-file
67+
      (string-append (asset-dir asset)
68+
                     (asset-url asset))
69+
    get-bytevector-all))
70+
71+
(define (asset-find-by-url url assets)
72+
  (let ((results (filter (lambda (a)
73+
                           (equal? (asset-url a) url))
74+
                         assets)))
75+
    (if (null? results) #f (car results))))
3776 
3877 
(define (not-found request footer)
3978 
  (format #t "Not found: ~a~%" (uri->string (request-uri request)))
…
4281 
               "" "" footer)
4382 
        #:code 404))
4483 
84+
(define (default-handler request footer assets)
85+
  (let ((a (asset-find-by-url (uri-path (request-uri request)) assets)))
86+
    (if (asset? a)
87+
        (values `((content-type . (,(string->symbol (asset-mime a)))))
88+
                (asset-load-data a))
89+
        (not-found request footer))))
90+
4591 
(define (style page project ref footer)
4692 
  `(html
4793 
     (head
…
208254 
                         (substring request (string-length slug))))
209255 
               (loop projects))))))))
210256 
257+
  (define assets (asset-list (asset-directory)))
258+
211259 
  (match config
212260 
    (($ <config> port host database repositories base-git-url index-title intro
213261 
        footer)
…
218266 
         (match (cons project-name path)
219267 
           (("" . ())
220268 
            (show (index-page (projects) base-git-url index-title intro footer)))
221-
           (("" . args)
222-
            (repo-404 "Project not found" ""
223-
                      "-"))
224269 
           ((project-name)
225270 
            (call-with-repo project-name
226271 
              (lambda (repo)
…
255300 
              (lambda (repo)
256301 
                (show (style (project-tags project-name repo)
257302 
                      project-name "-" footer)))))
258-
           (_ (not-found request footer))))))))
303+
           (_ (default-handler request footer assets))))))))