[dynamic] Initial database stubs

3 files changed, 126 insertions, 22 deletions

diff --git a/dynamic/api.scm b/dynamic/api.scm
index 6cda81a..8bbff1e 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 gallery)
+(use-modules (dynamic capabilities comments)
+             (dynamic capabilities gallery)
              (dynamic capabilities rsvp)
              (dynamic logging)
              (srfi srfi-1)
@@ -38,8 +39,9 @@
     (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 "comments") get-comments)
+     ('(POST "comment") put-comment)
+     ('(POST "react") put-reaction)
      ('(GET "gallery") get-gallery)
      ('(GET "gallery" "image") get-image)
      ('(GET "rsvp" "event-info") get-event-info)
diff --git a/dynamic/capabilities/comments.scm b/dynamic/capabilities/comments.scm
index d7dc1fa..6786474 100644
--- a/dynamic/capabilities/comments.scm
+++ b/dynamic/capabilities/comments.scm
@@ -14,27 +14,125 @@
 ;;; along with this program. If not, see
 ;;; <http://www.gnu.org/licenses/>.
 
-(define challenges (make-hash-table))
+(define-module (dynamic capabilities comments)
+  #:use-module (dynamic util)
+  #:use-module (ice-9 match)
+  #:use-module (json)
+  #:use-module (squee)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (get-comments put-comment put-reaction))
+
 (define conn (connect-to-postgres-paramstring "dbname=jakob_comments"))
 
+(define (get-comments-slug slug)
+  (define (format-comment comment)
+    (match comment
+      ((id name subject email comment reactions)
+       `((id . ,id)
+         (name . ,name)
+         (subject . ,subject)
+         (email . ,email)
+         (comment . ,comment)
+         (reactions . ,reactions)))))
+  (let* ((query "SELECT id, name, subject, email, comment, reactions
+                 FROM comments WHERE slug = $1")
+         (result (exec-query conn query (list (car slug)))))
+    (values '((content-type . (application/json)))
+            (scm->json-string
+             (list->vector
+              (map format-comment result))))))
+
 (define (get-comments request body)
-  (values '((content-type . (application/json)))
-          (scm->json-string
-           '((title . "whoa buddy")
-             (author . "Jakob Kreuze")
-             (date . "2022-03-27")
-             (text . "bad take, bad take!")))))
+  (let* ((query-string (uri-query (request-uri request)))
+         (params (if query-string
+                     (decode-form query-string)
+                     '()))
+         (slug (assoc-ref params "p")))
+    (if slug
+        (get-comments-slug slug)
+        (values (build-response #:code 400)
+                (scm->json-string
+                 `((success . #f)
+                   (error . "missing `slug' query parameter")))))))
 
-(define (put-comment request body)
-  (display (decode-form body))
-  (newline)
+
+
+(define (assoc-value alist key)
+  (let ((result (assoc-ref alist key)))
+    (if result (car result) result)))
+
+(define (insert-comment form-data)
+  (exec-query conn
+     "INSERT INTO comments (submitted, slug, name, subject, email, url, comment)
+      VALUES (now(), $1, $2, $3, $4, $5, $6);"
+     (list (assoc-value form-data "slug")
+           (assoc-value form-data "name")
+           (assoc-value form-data "subject")
+           (assoc-value form-data "email")
+           (assoc-value form-data "url")
+           (assoc-value form-data "comment")))
   (values '((content-type . (text/plain))) "Hello hacker!"))
 
-(define (make-challenge request body)
-  (let-values (((uuid value image) (new-captcha)))
-    (hash-set! challenges uuid value)
-    (hash-for-each (lambda (x y) (display x) (newline)) challenges)
-    (values `((content-type . (application/base64))
-              (access-control-allow-origin . "*")
-              (x-captcha-id . ,uuid))
-            (base64-encode image))))
+(define (valid-comment? form-data)
+  (and (assoc "slug" form-data)
+       (assoc "name" form-data)
+       (assoc "comment" form-data)))
+
+(define (put-comment request body)
+  (let ((form-data (decode-form body)))
+    (if (valid-comment? form-data)
+        (insert-comment form-data)
+        (values (build-response #:code 400)
+                (scm->json-string
+                 `((success . #f)
+                   (error . "missing `slug', `name', or `comment'")))))))
+
+
+
+(define (comment-reactions id)
+  (let* ((query "SELECT reactions FROM comments WHERE id = $1")
+         (result (exec-query conn query (list id))))
+    ;; It could be NULL, in which case we want the empty list instead.
+    (if (positive? (length result)) (or (caar result) "()") #f)))
+
+(define (acons-normalize key value alist)
+  (cons (cons key value)
+        (filter (lambda (pair) (not (equal? (car pair) key))) alist)))
+
+(define (add-reaction reactions reaction)
+  (with-output-to-string
+    (lambda ()
+      (let ((parsed (call-with-input-string reactions read)))
+        (write (acons-normalize reaction
+                                (if (assoc reaction parsed) (+ 1 (assoc-value parsed reaction)) 1)
+                                parsed))))))
+
+(define (set-reactions id reactions)
+  (exec-query conn
+     "UPDATE comments SET reactions = $1 WHERE id = $2"
+     (list reactions id))
+  (values '((content-type . (text/plain))) "Reacted hacker!"))
+
+;; TODO: Need to validate `form-data' first.
+(define (put-reaction request body)
+  (let* ((form-data (decode-form body))
+         (id (assoc-value form-data "id"))
+         (reaction (assoc-value form-data "reaction"))
+         (reactions (comment-reactions id)))
+    (if reactions
+        (set-reactions id (add-reaction reactions reaction))
+        (values (build-response #:code 400)
+                (scm->json-string
+                 `((success . #f)
+                   (error . "no such comment")))))))
+
+;; (define (make-challenge request body)
+;;   (let-values (((uuid value image) (new-captcha)))
+;;     (hash-set! challenges uuid value)
+;;     (hash-for-each (lambda (x y) (display x) (newline)) challenges)
+;;     (values `((content-type . (application/base64))
+;;               (access-control-allow-origin . "*")
+;;               (x-captcha-id . ,uuid))
+;;             (base64-encode image))))
diff --git a/dynamic/schema-comments.sql b/dynamic/schema-comments.sql
index 1c690f3..b2cb652 100644
--- a/dynamic/schema-comments.sql
+++ b/dynamic/schema-comments.sql
@@ -4,9 +4,13 @@ CREATE TABLE comments(
     submitted TIMESTAMP NOT NULL,
     slug VARCHAR(100) NOT NULL,
     name VARCHAR(50) NOT NULL,
+    subject VARCHAR(100),
     email VARCHAR(100),
     url VARCHAR(100),
-    comment VARCHAR(1024) NOT NULL
+    comment VARCHAR(1024) NOT NULL,
+    reactions VARCHAR(1024)
 );
 
 -- Use `now' for `submitted'.
+
+-- INSERT INTO comments (submitted, slug, name, comment) VALUES (now(), 'test', 'Jakob', 'Hello, world!');