[dynamic] Add `demux.scm' for testing

This is to mimic my web server configuration. Simple Guile script to match on
the first component of the path (if any) and forward to the dynamic process
rather than `haunt serve' if it's prefixed with `api'.

1 files changed, 54 insertions, 0 deletions

diff --git a/haunt/demux.scm b/haunt/demux.scm
new file mode 100644
index 0000000..356b262
--- /dev/null
+++ b/haunt/demux.scm
@@ -0,0 +1,54 @@
+;;; 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/>.
+
+(use-modules (srfi srfi-1)
+             (web request)
+             (web response)
+             (web server)
+             (web uri)
+             (web client))
+
+(define static-url "http://localhost:8080")
+(define dynamic-url "http://localhost:8081")
+
+(define (main-request-handler request body)
+  "Demuxer entry-point; parse `request' and forward to the correct local service"
+  (define (wrap-response response)
+    (if (response? response)
+        (build-response
+         #:version           (response-version       response)
+         #:code              (response-code          response)
+         #:reason-phrase     (response-reason-phrase response)
+         #:headers           (remove (lambda (hdr) (eqv? 'content-length (car hdr)))
+                                     (response-headers response))
+         #:port              (response-port          response)
+         #:validate-headers? #f)
+        (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)
+      (let ((url (if (and (positive? (length path)) (string= "api" (first path)))
+                     (string-concatenate (list dynamic-url path-encoded))
+                     (string-concatenate (list static-url path-encoded)))))
+        (http-request url
+                      #:method (request-method request)
+                      #:body body
+                      #:version '(1 . 1)
+                      #:keep-alive? #f
+                      #:headers (request-headers request))))
+    (values (wrap-response response) resp-body)))
+
+(run-server main-request-handler 'http '(#:port 8082))