Pushing Haunt to Its Limits

CREATE TABLE comments(
    id SERIAL PRIMARY KEY,
    approved TIMESTAMP,
    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,
    reactions VARCHAR(1024)
);

(define (format-comment comment)
  "Format `comment', an alist, as SXML for a comment-type interaction"
  (define (strip uri)
    "Attempt to remove any sort of protocol specification from `uri'"
    (let* ((needle "://")
           (index (string-contains uri needle)))
      (if index
          (strip (substring uri (+ index (string-length needle))))
          uri)))
  (let* ((author-name (assoc-ref comment 'name))
         (author-url (assoc-ref comment 'url))
         (author-photo (gravatar-url (assoc-ref comment 'email)))
         (publish-datetime (assoc-ref comment 'publish-time))
         (content-text (assoc-ref comment 'comment))
         (content-reactions (assoc-ref comment 'reactions)))
    `(li (@ (class "p-comment h-cite comment comment-source-internal"))
         (img (@ (class "comment-source-identifier")
                 (alt "Icon for comments posted on jakob.space")
                 (src "/static/image/lambda.svg")))
         (div (@ (class "p-author h-card author"))
              (img (@ (class "u-photo") (src ,author-photo)))
              (span (@ (class author-name)) ,author-name)
              ,@(if author-url
                    `((a (@ (class "author-url")
                            (href ,author-url))
                         "(" ,(strip author-url) ")"))
                    `()))
         (div (@ (class "e-content p-name comment-content"))
              ,@(chain content-text
                       (safe-markdown->sxml _)))
         (div (@ (class "metaline"))
              (time (@ (class "dt-published")
                       (datetime ,publish-datetime))
                    ,(date->string
                      (string->date publish-datetime "~Y~m~d ~H~M~S.~N")
                      "~B ~e, ~Y at ~H:~M")))
         (ul (@ (class "comment-reactions"))
             ,@(map (match-lambda
                      ((emote . count)
                       `(li ,(format #f "~a (~a)" emote count))))
                    content-reactions)))))

(define (render-comment-view response)
  "Render `response', the output of `fetch-webmentions', as SXML"
  (map format-comment response))

(define (gravatar-url email)
  (chain email
         (string-downcase _)
         (string-trim-both _)
         (string->bytevector _ "utf8")
         (bytevector-hash _ (lookup-hash-algorithm 'md5))
         (bytevector->base16-string _)
         (format #f "https://www.gravatar.com/avatar/~a" _)))

(define (safe-markdown->sxml text)
  "Convert TEXT to an sxml form filtering out any unsafe entities"
  (define (sanitize sexp)
    (cond ((and (list? sexp)
                (positive? (length sexp))
                (eqv? 'img (car sexp)))
           #f)
          ((list? sexp)
           (filter identity (map sanitize sexp)))
          (else sexp)))
  (sanitize (commonmark->sxml text)))

(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." n)))))

(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 (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))))
         (solution (- (local-eval expression (let ((x upper-bound)) (the-environment)))
                      (local-eval expression (let ((x lower-bound)) (the-environment)))))
         (id (dequeue-id! tex-challenge-id-queue)))
    (hash-set! tex-challenges id solution)
    (values id
            (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx"
                                  lower-bound
                                  upper-bound
                                  latex-src)))))

(define (validate-captcha! user-answer id)
  (define epsilon 0.01)
  (let ((solution (hash-ref tex-challenges id))
        (id-allocated (not (member id (id-queue-free tex-challenge-id-queue)))))
    ;; FIXME: The predictable IDs means that its' easy for someone to screw with
    ;; someone elses' captcha challenge (by invalidating it before they can
    ;; submit it). Given the combination of our reaping algorithm and
    ;; rate-limiting, does it make sense to only release the ID when the
    ;; response is correct?
    (format #t "Here: Solution was ~a and id-allocated is ~a~%" solution id-allocated)
    (when (and solution id-allocated)
      (release-id! id tex-challenge-id-queue))
    (and solution
         id-allocated
         (<= (/ (abs (- solution (string->number user-answer)))
                solution)
             epsilon))))

;; How many zeroes the SHA-256 hash has to be prefixed by to be a valid proof of work.
(define %hardness 8)

(define (new-proof-of-work-challenge!)
  (let ((id (dequeue-id! pow-challenge-id-queue))
        (challenge (base64-encode (gen-random-bv 32))))
    (hash-set! pow-challenges id challenge)
    (values id challenge)))

(define (validate-proof-of-work! prefix challenge-id)
  (define zero-prefix (string-join (map (lambda (_) "0") (iota %hardness)) ""))
  (when (member challenge-id (id-queue-free pow-challenge-id-queue))
    (panic "No such challenge ID"))
  (let* ((challenge (hash-ref pow-challenges challenge-id))
         (hash-value (chain (list prefix challenge)
                            (string-concatenate _)
                            (string->bytevector _ "utf8")
                            (bytevector-hash _ (lookup-hash-algorithm 'sha256))
                            (bytevector->base16-string _))))
    ;; Invariant from `unless' form:
    ;; (not (member challenge-id (id-queue-free pow-challenge-id-queue)))
    (when challenge
      (release-id! challenge-id pow-challenge-id-queue))
    (and (= 32 (string-length prefix))
         (string-prefix? zero-prefix hash-value))))

(define (make-pow-challenge! request body)
  "API endpoint handler for requesting a proof-of-work challenge"
  (let-values (((challenge-id nonce) (new-proof-of-work-challenge!)))
    (values '((content-type . (application/json)))
            (scm->json-string
             `((hardness . ,%hardness)
               (challenge-id . ,challenge-id)
               (nonce . ,nonce))))))

function makeid(length) {
  let result = '';
  let alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  for (let i = 0; i < length; i++) {
    result += alphabet.charAt(Math.floor(Math.random() * alphabet.length));
  }
  return result;
}

async function digestMessage(message) {
  const msgUtf8 = new TextEncoder().encode(message);
  const hashBuffer = await crypto.subtle.digest('SHA-256', msgUtf8);
  const hashArray = Array.from(new Uint8Array(hashBuffer));
  const hashHex = hashArray.map((b) => b.toString(16).padStart(2, '0')).join('');
  return hashHex;
}

async function findPrefix(hardness, nonce) {
  while (true) {
    let prefix = makeid(32);
    let digestHex = await digestMessage(prefix + nonce);
    if (digestHex.startsWith("0".repeat(hardness))) {
      return prefix;
    }
  }
}

function raceEndpoint() {
  return new Promise(function (resolve, reject) {
    makeRequest("GET", "/api/challenge/proof-of-work")
      .then(function (data) {
        let challengeData = JSON.parse(data);
        findPrefix(challengeData.hardness, challengeData.nonce)
          .then((prefix) => { resolve([prefix, challengeData["challenge-id"]]) } );
      })
      .catch(reject);
  });
}

;;; 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 (jakob dynamic aes)
  #:use-module (gcrypt random)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:export (new-captcha))

(define %libnettle (dynamic-link "libnettle"))
(define %aes256-rounds 14)

(define %aes-key-size (/ 256 8))
(define %aes-block-size (/ 128 8))
(define %tex-aes-key (gen-random-bv %aes-key-size))

;; Assume `data' is a bytevector of length `%aes-block-size'.
(define (aes-256-encrypt key data)
  (let ((dest (make-bytevector %aes-block-size))
        (%ctx (make-c-struct (map (lambda (_) uint32) (iota (* 4 (+ 1 %aes256-rounds))))
                             (map (lambda (_) 0) (iota (* 4 (+ 1 %aes256-rounds))))))
        (%aes-256-encrypt
         (pointer->procedure void
                             (dynamic-func "nettle_aes256_encrypt" %libnettle)
                             (list '* size_t '* '*)))
        (%aes-256-set-encrypt-key
         (pointer->procedure void
                             (dynamic-func "nettle_aes256_set_encrypt_key" %libnettle)
                             (list '* '*))))
    (%aes-256-set-encrypt-key %ctx (bytevector->pointer %tex-aes-key))
    (%aes-256-encrypt %ctx %aes-block-size (bytevector->pointer dest) (bytevector->pointer data))
    dest))

(define (aes-256-decrypt key data)
  (let ((dest (make-bytevector %aes-block-size))
        (%ctx (make-c-struct (map (lambda (_) uint32) (iota (* 4 (+ 1 %aes256-rounds))))
                             (map (lambda (_) 0) (iota (* 4 (+ 1 %aes256-rounds))))))
        (%aes-256-decrypt
         (pointer->procedure void
                             (dynamic-func "nettle_aes256_decrypt" %libnettle)
                             (list '* size_t '* '*)))
        (%aes-256-set-decrypt-key
         (pointer->procedure void
                             (dynamic-func "nettle_aes256_set_decrypt_key" %libnettle)
                             (list '* '*))))
    (%aes-256-set-decrypt-key %ctx (bytevector->pointer %tex-aes-key))
    (%aes-256-decrypt %ctx %aes-block-size (bytevector->pointer dest) (bytevector->pointer data))
    dest))

;; (utf8->string (aes-256-decrypt %tex-aes-key (aes-256-encrypt %tex-aes-key (string->utf8 "AAAABBBBC hello!"))))
;; => "AAAABBBBC hello!"

(define-record-type <id-queue>
  (make-id-queue mutex min-free-threshold free-ids allocated-ids)
  id-queue?
  (mutex              id-queue-mutex)
  (min-free-threshold id-queue-min-free-threshold)
  (free-ids           id-queue-free      set-id-queue-free!)
  (allocated-ids      id-queue-allocated set-id-queue-allocated!))

(define* (make-queue n #:key (min-free-threshold 32))
  "Construct a stateful queue for tracking captcha IDs

The parameter N specifies how many free IDs should initially be allocated. The
optional keyword argument MIN-FREE-THRESHOLD specifies when `dequeue-id!' should
iterate through the allocated list and free anything exceeding an
internally-defined `time-to-live-seconds'."
  (make-id-queue (make-mutex) min-free-threshold (iota n) (list)))

(define (append-to-free-queue! id queue)
  "Add ID to the end of the free list of QUEUE"
  (set-id-queue-free!
   queue
   (append! (id-queue-free queue) (list id))))

(define (remove-from-free-queue! id queue)
  "Remove ID from the free list of QUEUE"
  (set-id-queue-free! queue (delete! id (id-queue-free queue))))

(define (append-to-allocated-queue! id queue)
  "Add ID to the end of the allocated list of QUEUE"
  (set-id-queue-allocated!
   queue
   (append! (id-queue-allocated queue) (list (list id (current-time))))))

(define (remove-from-allocated-queue! id queue)
  "Remove ID from the allocated list of QUEUE"
  (set-id-queue-allocated!
   queue
   (filter! (lambda (x) (not (equal? id (car x))))
            (id-queue-allocated queue))))

(define (release-id! id queue)
  "Release ID to the free list of QUEUE"
  (with-mutex (id-queue-mutex queue)
    (assert (find (lambda (x) (equal? id (car x))) (id-queue-allocated queue)))
    (assert (not (member id (id-queue-free queue))))
    (append-to-free-queue! id queue)
    (remove-from-allocated-queue! id queue)))

(define (dequeue-id! queue)
  "Draw a random ID from QUEUE and mark it as allocated"
  (define time-to-live-seconds (* 20 60))
  (with-mutex (id-queue-mutex queue)
    ;; Initial pass to "unintrusively" free any stale IDs.
    (when (< (length (id-queue-free queue))
             (id-queue-min-free-threshold queue))
      (for-each
       (match-lambda
         ((id created-time)
          (when (>= (- (time-second (current-time))
                       (time-second created-time))
                    time-to-live-seconds)
            (remove-from-allocated-queue! id queue))))
       (list-copy (id-queue-allocated queue))))
    ;; If we're still over the threshold, we'll need to be more intrusive.
    ;; Ideally, this is avoided by rate-limiting.
    (when (< (length (id-queue-free queue))
             (id-queue-min-free-threshold queue))
      (let* ((to-take (- (id-queue-min-free-threshold queue)
                         (length (id-queue-free queue))))
             (to-free (map car (take (id-queue-allocated queue) to-take))))
        (set-id-queue-allocated! queue (drop (id-queue-allocated queue) to-take))
        (set-id-queue-free! queue (append! (id-queue-free queue) to-free))))
    (let* ((n (random (length (id-queue-free queue))))
           (id (list-ref (id-queue-free queue) n)))
      (remove-from-free-queue! id queue)
      (append-to-allocated-queue! id queue)
      id)))