The `org' directory is no longer necessary

1 files changed, 115 insertions, 0 deletions

diff --git a/api.scm b/api.scm
new file mode 100644
index 0000000..1e71064
--- /dev/null
+++ b/api.scm
@@ -0,0 +1,115 @@
+;;; 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 config)
+             (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)
+             (jakob dynamic util)
+             (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 (clearnet-only handler)
+  (lambda (request body)
+    (if (and (from-darknet? request) (not (%debug-enabled)))
+        (panic "This API is only available on the clearnet." #:code 403)
+        (handler request body))))
+
+(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
+         (((if (%debug-enabled) identity rate-limit-wrap)
+           (match (cons (request-method request) endpoint)
+             (('GET  "apps" "comment-form" _)            get-comment-form)
+             ('(GET  "api"  "challenge" "proof-of-work") make-pow-challenge!)
+             ('(GET  "api"  "challenge" "captcha")       make-captcha-challenge!)
+             ('(GET  "api"  "comments")                  get-comments)
+             (('POST "api"  "comment")                   put-comment)
+             (('POST "api"  "comment" "react")           put-reaction)
+
+             (('GET  "apps" "gallery")                   (clearnet-only get-gallery))
+             (('GET  "apps" "rsvp" "event-info")         (clearnet-only get-event-info))
+             (('POST "apps" "rsvp")                      (clearnet-only 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)
+      (handle-api-request request body path))
+    (values (wrap-response response) resp-body)))
+
+(format #t "Server started.~%")
+(run-server main-request-handler 'http `(#:addr ,INADDR_ANY #:port ,(%api-server-port)))