diff options
Diffstat (limited to 'src/scm')
| -rw-r--r-- | src/scm/webid-oidc/server/Makefile.am | 7 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/endpoint.scm | 136 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/endpoint/Makefile.am | 19 |
3 files changed, 160 insertions, 2 deletions
diff --git a/src/scm/webid-oidc/server/Makefile.am b/src/scm/webid-oidc/server/Makefile.am index 365b878..fd33462 100644 --- a/src/scm/webid-oidc/server/Makefile.am +++ b/src/scm/webid-oidc/server/Makefile.am @@ -20,7 +20,8 @@ dist_serverwebidoidcmod_DATA += \ %reldir%/precondition.scm \ %reldir%/update.scm \ %reldir%/delete.scm \ - %reldir%/log.scm + %reldir%/log.scm \ + %reldir%/endpoint.scm serverwebidoidcgo_DATA += \ %reldir%/create.go \ @@ -28,6 +29,8 @@ serverwebidoidcgo_DATA += \ %reldir%/precondition.go \ %reldir%/update.go \ %reldir%/delete.go \ - %reldir%/log.go + %reldir%/log.go \ + %reldir%/endpoint.go include %reldir%/resource/Makefile.am +include %reldir%/endpoint/Makefile.am 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))))) diff --git a/src/scm/webid-oidc/server/endpoint/Makefile.am b/src/scm/webid-oidc/server/endpoint/Makefile.am new file mode 100644 index 0000000..e32794d --- /dev/null +++ b/src/scm/webid-oidc/server/endpoint/Makefile.am @@ -0,0 +1,19 @@ +# 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/>. + +dist_endpointserverwebidoidcmod_DATA += + +endpointserverwebidoidcgo_DATA += |