1 files changed, 136 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/server/endpoint.scm b/src/scm/webid-oidc/server/endpoint.scm
new file mode 100644
index 0000000..d327139
--- /dev/null
+++ b/src/scm/webid-oidc/server/endpoint.scm
@@ -0,0 +1,136 @@
+;; disfluid, implementation of the Solid specification
+;; Copyright (C) 2021  Vivien Kraus
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero 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 Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc provider-confirmation)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module ((webid-oidc config) #:prefix cfg:)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (web server)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module (ice-9 getopt-long)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:use-module (sxml simple)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
+  #:declarative? #t
+  #:export
+  (
+   <endpoint>
+   host
+   path
+   relevant?
+
+   <router>
+   routed
+
+   handle
+   ))
+
+(define-class <endpoint> ()
+  (host #:init-keyword #:host #:getter host #:init-value #f)
+  (path #:init-keyword #:path #:getter path  #:init-value "/"))
+
+(define-method (initialize (endpoint <endpoint>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((host #f)
+    (path "/"))
+   (unless (or (not host) (string? host))
+     (scm-error 'wrong-type-arg "make <endpoint>"
+                (G_ "#:host should be a string or #f")
+                '()
+                (list host)))
+   (unless (and (string? path) (string-prefix? "/" path))
+     (scm-error 'wrong-type-arg "make <endpoint>"
+                (G_ "#:path should be an absolute path")
+                '()
+                (list path)))))
+
+(define-class <router> (<endpoint>)
+  (routed #:init-keyword #:routed #:getter routed #:init-value '()))
+
+(define-method (initialize (endpoint <router>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((routed '()))
+   (let check-routed ((routed routed)
+                      (i 0))
+     (match routed
+       (() #t)
+       (((? (cute is-a? <> <endpoint>)) routed ...)
+        (check-routed routed (+ i 1)))
+       ((not-an-endpoint _ ...)
+        (scm-error 'wrong-type-arg "make <router>"
+                   (format #f (G_ "#:routed element ~a should be an endpoint") i)
+                   '()
+                   (list not-an-endpoint)))
+       (else
+        (scm-error 'wrong-type-arg "make <router>"
+                   (G_ "#:routed should be a list of endpoints")
+                   '()
+                   (list routed)))))))
+
+(define-method (relevant? (endpoint <endpoint>) request)
+  (let ((requested-host
+         (match (request-host request)
+           ((or ((? string? host) . _)
+                (? string? host))
+            host)
+           (else #f)))
+        (requested-path
+         (split-and-decode-uri-path
+          (uri-path (request-uri request)))))
+    (and (or (not (host endpoint))
+             (equal? (host endpoint) requested-host))
+         (let check-path ((path (split-and-decode-uri-path (path endpoint)))
+                          (requested-path requested-path))
+           (match `(,path ,requested-path)
+             ((() _) #t)
+             ((_ ()) #f)
+             (((element path ...)
+               (requested-element requested-path ...))
+              (and (equal? element requested-element)
+                   (check-path path requested-path))))))))
+
+(define-method (handle (endpoint <router>) request request-body)
+  (let find-router ((routed (routed endpoint)))
+    (match routed
+      (()
+       (values
+        (build-response
+         #:code 404
+         #:reason-phrase (W_ "Not Found"))
+        #f
+        '()))
+      (((and router
+             (? (cute relevant? <> request)))
+        _ ...)
+       (handle router request request-body))
+      ((_ routed ...)
+       (find-router routed)))))