summaryrefslogtreecommitdiff
path: root/haunt/demux.scm
blob: 2de029d0a12df0f17df4c24aefb85f43b833a5d9 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
;;; 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 (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))