1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (dynamic capabilities gallery)
#:use-module (dynamic util)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (squee)
#:use-module (srfi srfi-1)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:export (get-gallery get-image))
(define conn (connect-to-postgres-paramstring "dbname=jakob_gallery"))
;; How many bytes of entropy to use when generating vanity ID's.
(define %vanity-length (make-parameter 9))
;; Path where gallery images are stored.
(define %gallery-image-directory (make-parameter "/home/jakob/gallery-images/"))
(define (valid-gallery-code code)
"Check database to see if `code' names a nonempty gallery."
(and (= (string-length code) (base64-length (%vanity-length)))
(positive?
(length
(exec-query conn "SELECT * FROM images WHERE vanity = $1"
(list code))))))
(define (get-gallery-images code)
"Handler for enumerating the image in a gallery."
(define (format-image image)
(match image
((title filename thumbnail datetime)
`((title . ,title)
(filename . ,filename)
(thumbnail . ,thumbnail)
(datetime . ,datetime)))))
(let* ((images (exec-query conn "SELECT title, filename, thumb_filename, datetime FROM images WHERE vanity = $1" (list code))))
(list->vector (map format-image images))))
(define (get-gallery-info code)
"Handler for enumerating the image in a gallery."
(define (format-gallery info)
(match info
((title description datetime)
`((title . ,title)
(description . ,description)
(datetime . ,datetime)))))
(let* ((info (exec-query conn "SELECT title, description, datetime FROM galleries WHERE vanity = $1" (list code))))
(format-gallery (car info))))
(define (get-gallery request body)
(let* ((query-string (uri-query (request-uri request)))
(params (if query-string
(decode-form query-string)
'()))
(code (car (assoc-ref params "g"))))
(if (valid-gallery-code code)
(values '((content-type . (application/json)))
(scm->json-string `((info . ,(get-gallery-info code))
(images . ,(get-gallery-images code)))))
(values (build-response #:code 400)
(scm->json-string
`((success . #f)
(error . "Invalid gallery code")))))))
(define (image-exists? file-name)
(define (string/= a b) (not (string= a b)))
(and (string/= file-name ".")
(string/= file-name "..")
(member file-name (scandir (%gallery-image-directory)))))
(define (read-image file-name)
(let* ((ext (string-downcase (last (string-split file-name #\.))))
(mime (cond ((string= ext "jpg") 'image/jpeg)
((string= ext "png") 'image/png)
(else (error "Unknown MIME type.")))))
(values `((content-type . (,mime)))
(call-with-input-file (format #f "~a/~a" (%gallery-image-directory) file-name)
(lambda (port)
(get-bytevector-all port))))))
(define (get-image request body)
(let* ((query-string (uri-query (request-uri request)))
(params (if query-string
(decode-form query-string)
'()))
(file-name (car (assoc-ref params "name"))))
(if (image-exists? file-name)
(read-image file-name)
(values (build-response #:code 400)
(scm->json-string
`((success . #f)
(error . "Invalid filename")))))))
|
