Merge branch 'self-hosted-comments'

It's been working well enough. I think it's time to get the initial version of
this on `master'.

1 files changed, 108 insertions, 0 deletions

diff --git a/haunt/api.scm b/haunt/api.scm
new file mode 100644
index 0000000..810b905
--- /dev/null
+++ b/haunt/api.scm
@@ -0,0 +1,108 @@
+;;; Copyright © 2019 - 2023 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/>.
+
+(use-modules (ice-9 match)
+             (jakob dynamic blacklist)
+             (jakob dynamic captcha)
+             (jakob dynamic capabilities comment-form)
+             (jakob dynamic capabilities comments)
+             (jakob dynamic capabilities gallery)
+             (jakob dynamic capabilities rsvp)
+             (jakob dynamic errors)
+             (jakob dynamic logging)
+             (jakob dynamic rate-limiter)
+             (json)
+             (rnrs conditions)
+             (rnrs exceptions)
+             (srfi srfi-1)
+             (web request)
+             (web response)
+             (web server)
+             (web uri))
+
+(define (not-found request)
+  "Build a (somewhat) descriptive response for a non-existent resource."
+  (values (build-response #:code 404)
+          (string-append "Resource not found: "
+                         (uri->string (request-uri request)))))
+
+(define (format-error-response condition)
+  "Format CONDITION, a &reportable-condition, as an HTTP response"
+  (values (build-response #:code (reportable-condition-code condition))
+          (scm->json-string
+           `((success . #f)
+             (error . ,(reportable-condition-message condition))))))
+
+(define-syntax values->list
+  (syntax-rules ()
+    ((values-list exp)
+     (call-with-values (lambda () exp) list))))
+
+(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))
+        (args (uri-query (request-uri request))))
+    (log-append! 'info (if args
+                           (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip)
+                           (format #f "~a ~a (~a)" method endpoint originating-ip)))
+    ;; Somewhat painful wrap/unwrap of values because there isn't support for
+    ;; returning multiple values from a `guard' clause.
+    (apply values
+      (guard (ex ((reportable-condition? ex)
+                  (values->list (format-error-response ex))))
+        (fail-when-ip-blacklisted originating-ip)
+        (values->list
+         ((rate-limit-wrap
+           (match (cons (request-method request) endpoint)
+             (('GET "comment-form" _) get-comment-form)
+             ('(GET "challenge" "proof-of-work") make-pow-challenge!)
+             ('(GET "challenge" "captcha") make-captcha-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)))))
+          request body))))))
+
+(define (main-request-handler request body)
+  "Server entry-point; parse `request' and defer to routing system."
+  (define (wrap-response response)
+    ;; This is either a response, or an alist of headers. The latter case is
+    ;; simple to handle, but the former requires us to do a (rather unweildy)
+    ;; copy of the response to inject our headers.
+    (if (response? response)
+        (build-response
+         #:version           (response-version       response)
+         #:code              (response-code          response)
+         #:reason-phrase     (response-reason-phrase response)
+         #:headers           (cons '(Access-Control-Allow-Origin . "*")
+                                    (response-headers response))
+         #:port              (response-port          response)
+         #:validate-headers? #t)
+        (cons '(Access-Control-Allow-Origin . "*") response)))
+  (let* ((path-encoded (uri-path (request-uri request)))
+         (path (split-and-decode-uri-path path-encoded)))
+    (define-values (response resp-body)
+      (if (string= "api" (first path))
+          (handle-api-request request body (drop path 1))
+          (not-found request)))
+    (values (wrap-response response) resp-body)))
+
+(format #t "Server started.~%")
+(run-server main-request-handler 'http `(#:addr ,INADDR_ANY #:port 8080))