[scheme] Initial gallery API

3 files changed, 136 insertions, 3 deletions

diff --git a/dynamic/api.scm b/dynamic/api.scm
index b899dc6..22a9856 100644
--- a/dynamic/api.scm
+++ b/dynamic/api.scm
@@ -14,7 +14,8 @@
 ;;; along with this program. If not, see
 ;;; <http://www.gnu.org/licenses/>.
 
-(use-modules (dynamic capabilities rsvp)
+(use-modules (dynamic capabilities gallery)
+             (dynamic capabilities rsvp)
              (dynamic logging)
              (srfi srfi-1)
              (ice-9 match)
@@ -32,12 +33,15 @@
 (define (handle-api-request request body endpoint)
   "Route handler for the API server."
   (let ((method (request-method request))
-        (originating-ip (assoc-ref (request-headers request) 'X-Forwarded-For)))
-    (log-append! 'info (format #f "~a ~a (~a)" method endpoint originating-ip)))
+        (originating-ip (assoc-ref (request-headers request) 'X-Forwarded-For))
+        (args (uri-query (request-uri request))))
+    (log-append! 'info (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip)))
   ((match (cons (request-method request) endpoint)
      ;; ('(GET "challenge") make-challenge)
      ;; ('(GET "comments") get-comments)
      ;; ('(POST "comment") put-comment)
+     ('(GET "gallery") get-gallery)
+     ('(GET "gallery" "image") get-image)
      ('(GET "rsvp" "event-info") get-event-info)
      ('(POST "rsvp") post-event-rsvp)
      (_ (lambda (. args) (not-found request))))
diff --git a/dynamic/capabilities/gallery.scm b/dynamic/capabilities/gallery.scm
new file mode 100644
index 0000000..1d63061
--- /dev/null
+++ b/dynamic/capabilities/gallery.scm
@@ -0,0 +1,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")))))))
diff --git a/dynamic/schema-gallery.sql b/dynamic/schema-gallery.sql
new file mode 100644
index 0000000..bad4100
--- /dev/null
+++ b/dynamic/schema-gallery.sql
@@ -0,0 +1,18 @@
+CREATE TABLE IF NOT EXISTS galleries (
+  id SERIAL,
+  vanity char(12) NOT NULL,
+  title varchar(128),
+  description varchar(4096) NOT NULL,
+  datetime timestamp with time zone NOT NULL,
+  PRIMARY KEY (id)
+);
+
+CREATE TABLE IF NOT EXISTS images (
+  id SERIAL,
+  vanity char(12) NOT NULL,
+  title varchar(128),
+  filename varchar(64) NOT NULL,
+  thumb_filename varchar(64) NOT NULL,
+  datetime timestamp with time zone NOT NULL,
+  PRIMARY KEY (id)
+);