[scheme] Initial comments API

4 files changed, 361 insertions, 0 deletions

diff --git a/dynamic/api.scm b/dynamic/api.scm
new file mode 100644
index 0000000..463ceab
--- /dev/null
+++ b/dynamic/api.scm
@@ -0,0 +1,113 @@
+(use-modules (base64)
+             (captcha)
+             (json)
+             (srfi srfi-1)
+             (srfi srfi-11)
+             (srfi srfi-13)
+             (srfi srfi-26)
+             (rnrs bytevectors)
+             (ice-9 match)
+             (web server)
+             (web request)
+             (web response)
+             (web uri))
+
+;; Data model for comments:
+;; CREATE TABLE comments(
+;;     id SERIAL PRIMARY KEY,
+;;     approved TIMESTAMP,
+;;     submitted TIMESTAMP NOT NULL,
+;;     slug VARCHAR(100) NOT NULL,
+;;     name VARCHAR(50) NOT NULL,
+;;     email VARCHAR(100),
+;;     url VARCHAR(100),
+;;     comment VARCHAR(1024) NOT NULL
+;; );
+
+;; Use `now' for `submitted'.
+
+;; Globals.
+
+(define challenges (make-hash-table))
+;; (define conn (connect-to-postgres-paramstring "dbname=jakob-comments"))
+
+;; Util.
+
+(define (acons-list k v alist)
+  "Add V to K to alist as list"
+  (let ((value (assoc-ref alist k)))
+    (if value
+        (let ((alist (alist-delete k alist)))
+          (acons k (cons v value) alist))
+        (acons k (list v) alist))))
+
+(define (list->alist lst)
+  "Build a alist of list based on a list of key and values.
+
+   Multiple values can be associated with the same key"
+  (let next ((lst lst)
+             (out '()))
+    (if (null? lst)
+        out
+        (next (cdr lst) (acons-list (caar lst) (cdar lst) out)))))
+
+(define (decode-form bv)
+  "Convert BV querystring or form data to an alist"
+  (define string (utf8->string bv))
+  (define pairs (map (cut string-split <> #\=)
+                     ;; semi-colon and amp can be used as pair separator
+                     (append-map (cut string-split <> #\;)
+                                 (string-split string #\&))))
+  (list->alist (map (match-lambda
+                      ((key value)
+                       (cons (uri-decode key) (uri-decode value)))) pairs)))
+
+(define (request-path-components request)
+  (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (not-found request)
+  (values (build-response #:code 404)
+          (string-append "Resource not found: "
+                         (uri->string (request-uri request)))))
+
+;; 
+
+(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!")))))
+
+(define (put-comment request body)
+  (display (decode-form body))
+  (newline)
+  (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 (handle-api-request request body endpoint)
+  (display (cons (request-method request) endpoint))
+  (newline)
+  ((match (cons (request-method request) endpoint)
+     ('(GET "challenge") make-challenge)
+     ('(GET "comments") get-comments)
+     ('(POST "comment") put-comment)
+     (_ (lambda (. args) (not-found request))))
+   request body))
+
+(define (main-request-handler request body)
+  (let ((path (request-path-components request)))
+    (if (string= "api" (first path))
+        (handle-api-request request body (drop path 1))
+        (not-found request))))
+
+(run-server main-request-handler 'http '(#:port 8081))
diff --git a/dynamic/captcha.scm b/dynamic/captcha.scm
new file mode 100644
index 0000000..c4380fb
--- /dev/null
+++ b/dynamic/captcha.scm
@@ -0,0 +1,107 @@
+(define-module (captcha)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 local-eval)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-1)
+  #:export (new-captcha))
+
+(define proc-mutex (make-mutex))
+
+(define (random-term)
+  (match (random 5)
+    (0 `(* ,(+ 1 (random 10)) x))
+    (1 `(* ,(+ 1 (random 10)) (expt x ,(random 10))))
+    (2 `(* ,(+ 1 (random 10)) (exp x)))
+    (3 `(* ,(+ 1 (random 10)) (cos x)))
+    (4 `(* ,(+ 1 (random 10)) (sin x)))))
+
+(define (sexp->latex sexp)
+  (match sexp
+    (('+ rest ...) (string-join (map sexp->latex rest) " + "))
+    (('* rest ...) (string-join (map sexp->latex rest) " \\cdot "))
+    (('sin term) (format #f "\\sin(~a)" (sexp->latex term)))
+    (('cos term) (format #f "\\cos(~a)" (sexp->latex term)))
+    (('expt term n) (format #f "~a^{~a}" (sexp->latex term) (sexp->latex n)))
+    (('exp term) (format #f "e^{~a}" (sexp->latex term)))
+    ('x "x")
+    (n (cond ((and (number? n) (positive? n)) (format #f "~a" n))
+             ((and (number? n) (negative? n)) (format #f "(~a)" n))
+             ((number? n) "0")
+             (else (error "Do not know how to convert to latex." n))))))
+
+(define (differentiate-sexp sexp)
+  (match sexp
+    (('+ rest ...) `(+ ,@(map differentiate-sexp rest)))
+    (('* coeff term) (if (number? coeff)
+                         `(* ,coeff ,(differentiate-sexp term))
+                         (error "Do not know how to differentiate.")))
+    (('sin term) `(* ,(differentiate-sexp term) (cos ,term)))
+    (('cos term) `(* -1 ,(differentiate-sexp term) (sin ,term)))
+    (('exp term) `(* ,(differentiate-sexp term) (exp ,term)))
+    (('expt term n) `(* ,n (expt ,term ,(- n 1))))
+    ('x 1)
+    (n (if (number? n)
+           0
+           (error "Do not know how to differentiate.")))))
+
+(define (simplify-sexp sexp)
+  (match sexp
+    (('+ rest ...) `(+ ,@(map simplify-sexp rest)))
+    (('* 1 term) (simplify-sexp term))
+    (('* 1 rest ...) (simplify-sexp `(* ,@rest)))
+    (('sin term) `(sin ,(simplify-sexp term)))
+    (('sin term) `(cos ,(simplify-sexp term)))
+    (('exp term) `(exp ,(simplify-sexp term)))
+    (('expt term 1) (simplify-sexp term))
+    (('expt term n) `(expt ,(simplify-sexp term) ,(simplify-sexp n)))
+    (term term)))
+
+(define (random-expression)
+  (let ((n-terms (+ 2 (random 3))))
+    `(+ ,@(map (lambda (x) (random-term)) (iota n-terms)))))
+
+(define (latex->image src)
+  (chdir "/tmp")
+  (with-mutex proc-mutex
+    (call-with-output-file "formula.tex"
+      (lambda (port)
+        (format port "\\def\\formula{~a}
+\\documentclass[border=2pt]{standalone}
+\\usepackage{amsmath}
+\\usepackage{varwidth}
+\\begin{document}
+\\begin{varwidth}{\\linewidth}
+\\[ \\formula \\]
+\\end{varwidth}
+\\end{document}
+" src)))
+    (unless (eqv? 0 (status:exit-val (system "pdflatex formula.tex")))
+      (error "Cannot generate PDF"))
+    (let* ((port (open-input-pipe "convert -density 300 formula.pdf -quality 90 png:-"))
+           (data (get-bytevector-all port)))
+      (unless (eqv? 0 (status:exit-val (close-pipe port)))
+          (error "Cannot generate PNG"))
+      data)))
+
+(define (new-uuid)
+  (with-mutex proc-mutex
+    (let* ((port (open-input-pipe "uuidgen"))
+           (str  (read-line port)))
+      (close-pipe port)
+      str)))
+
+(define (new-captcha)
+  (let* ((lower-bound (random 10))
+         (upper-bound (+ lower-bound 1 (random 9)))
+         (expression (random-expression))
+         (latex-src (sexp->latex (simplify-sexp (differentiate-sexp expression)))))
+    (values (new-uuid)
+            (- (local-eval expression (let ((x upper-bound)) (the-environment)))
+               (local-eval expression (let ((x lower-bound)) (the-environment))))
+            (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx"
+                                  lower-bound
+                                  upper-bound
+                                  latex-src)))))
diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm
index 8f02a80..2e54998 100644
--- a/haunt/jakob/builder/blog.scm
+++ b/haunt/jakob/builder/blog.scm
@@ -80,6 +80,37 @@
             "."))
      (article ,(post-sxml post))
      (section
+      (@ (id "comments"))
+      (h2 "Comments for this Page")
+      (ul (@ (id "comment-container")))
+      (form
+       (@ (action "https://jakob.space/api/comment")
+          (method "post"))
+       (label (@ (for "name")) "Name:")
+       (br)
+       (input (@ (name "name") (id "name") (type "text")))
+       (br)
+       (label (@ (for "email")) "Email (optional; only used for Gravatar):")
+       (br)
+       (input (@ (name "email") (id "email") (type "text")))
+       (br)
+       (label (@ (for "url")) "Homepage (optional):")
+       (br)
+       (input (@ (name "url") (id "url") (type "text")))
+       (br)
+       (label (@ (for "comment")) "Comment (Markdown supported):")
+       (br)
+       (textarea (@ (name "comment") (id "comment") (rows "4") (cols "50") (maxlength "1024")))
+       (br)
+       (label (@ (for "captcha")) "Captcha: Please integrate the following definite integral.")
+       (br)
+       (img (@ (id "captcha") (alt "captcha-image")))
+       (br)
+       (input (@ (name "captcha") (id "captcha") (type "text")))
+       (br)
+       (input (@ (value "Submit") (type "submit"))))
+      ,(script "local.js"))
+     (section
       (@ (id "webmention"))
       (h2 ,(hyperlink "https://indieweb.org/Webmention" "Webmentions")
           " for this Page")
diff --git a/haunt/static/js/local.js b/haunt/static/js/local.js
new file mode 100644
index 0000000..51e0ea1
--- /dev/null
+++ b/haunt/static/js/local.js
@@ -0,0 +1,110 @@
+/*
+ * local.js -- Fetch and display local comments.
+ * Copyright © 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/>.
+ */
+
+function getData(url, callback) {
+  let xhr = new XMLHttpRequest();
+  xhr.onload = function(data) {
+    callback(data);
+  }
+  xhr.onerror = function(error) {
+    throw new Error(`Request failed: ${error}`);
+  }
+}
+
+function makeComment(comment) {
+  const strip = (uri) => {
+    const sep = "://";
+    return uri.substring(uri.indexOf(sep) + sep.length);
+  };
+
+  const element = (type, attributes) => {
+    let res = document.createElement(type);
+    for (const attribute in attributes) {
+      res.setAttribute(attribute, attributes[attribute]);
+    }
+    return res;
+  };
+
+  // Create the h-card section.
+  let avatar = element("img", {
+    "class": "u-photo",
+    "src": `https://www.gravatar.com/avatar/${comment.iconHash}?s=200`
+  });
+
+  let authorName = element("a", {
+    "class": "p-name u-url",
+    "href": comment.authorUrl
+  });
+  authorName.textContent = comment.authorName;
+
+  let authorURI = element("a", {
+    "class": "author_url",
+    "href": comment.author.url
+  });
+  authorURI.textContent = strip(comment.author.url);
+
+  let hCardContainer = element("div", {
+    "class": "p-author h-card author"
+  });
+  hCardContainer.appendChild(avatar);
+  hCardContainer.appendChild(authorName);
+  hCardContainer.appendChild(authorURI);
+
+  // Create the content section.
+  let contentContainer = element("div", {
+    "class": "e-content p-name comment-content",
+  });
+
+  contentContainer.textContent = comment.content;
+
+  // Create the metaline section.
+  let pubTime = comment.published;
+  let time = element("time", {
+    "class": "dt-published",
+    "datetime": pubTime,
+  });
+  time.textContent = (new Date(pubTime)).toString();
+
+  let linkBack = element("a", {
+    "class": "u-url",
+    "href": comment.url
+  });
+  linkBack.appendChild(time);
+
+  let metalineContainer = element("div", {
+    "class": "metaline"
+  });
+  metalineContainer.appendChild(linkBack);
+
+  // Put it all together.
+  let wrapper = element("li", {
+    "class": "p-comment h-cite comment",
+  });
+  wrapper.appendChild(hCardContainer);
+  wrapper.appendChild(contentContainer);
+  wrapper.appendChild(metalineContainer);
+
+  return wrapper;
+}
+
+getData("http://localhost:8081/api/challenge", (b64data) => {
+    console.log("Here2");
+  document.getElementById("captcha").src = 'data:image/png;base64,' + b64data;
+});
+console.log("Here1");