;; 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 .
(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
(
host
path
relevant?
routed
handle
&web-exception
make-web-exception
web-exception?
web-exception-code
web-exception-reason-phrase
&caused-by-user
make-caused-by-user
caused-by-user?
caused-by-user-webid
&user-message
make-user-message
user-message?
user-message-sxml
))
(define-exception-type
&web-exception
&external-error
make-web-exception
web-exception?
(code web-exception-code)
(reason-phrase web-exception-reason-phrase))
(define-exception-type
&caused-by-user
&external-error
make-caused-by-user
caused-by-user?
(webid caused-by-user-webid))
(define-exception-type
&user-message
&external-error
make-user-message
user-message?
(sxml user-message-one-sxml))
(define (user-message-sxml exn)
(let loop ((components (simple-exceptions exn))
(gathered '()))
(match components
(()
(match gathered
(()
`(div ,(W_ "No information available.")))
((= reverse gathered)
`(div ,@gathered))))
(((? user-message? (= user-message-one-sxml next))
components ...)
(loop components `(,next ,@gathered)))
((_ components ...)
(loop components gathered)))))
(define-class ()
(host #:init-keyword #:host #:getter host #:init-value #f)
(path #:init-keyword #:path #:getter path #:init-value "/"))
(define-method (initialize (endpoint ) initargs)
(next-method)
(let-keywords
initargs #t
((host #f)
(path "/"))
(unless (or (not host) (string? host))
(scm-error 'wrong-type-arg "make "
(G_ "#:host should be a string or #f")
'()
(list host)))
(unless (and (string? path) (string-prefix? "/" path))
(scm-error 'wrong-type-arg "make "
(G_ "#:path should be an absolute path")
'()
(list path)))))
(define-class ()
(routed #:init-keyword #:routed #:getter routed #:init-value '()))
(define-method (initialize (endpoint ) initargs)
(next-method)
(let-keywords
initargs #t
((routed '()))
(let check-routed ((routed routed)
(i 0))
(match routed
(() #t)
(((? (cute is-a? <> )) routed ...)
(check-routed routed (+ i 1)))
((not-an-endpoint _ ...)
(scm-error 'wrong-type-arg "make "
(format #f (G_ "#:routed element ~a should be an endpoint") i)
'()
(list not-an-endpoint)))
(else
(scm-error 'wrong-type-arg "make "
(G_ "#:routed should be a list of endpoints")
'()
(list routed)))))))
(define-method (relevant? (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 ) request request-body)
(let find-router ((routed (routed endpoint)))
(match routed
(()
(raise-exception
(make-exception
(make-web-exception 404 (W_ "Not Found"))
(make-user-message (W_ "The resource could not be found.")))))
(((and router
(? (cute relevant? <> request)))
_ ...)
(handle router request request-body))
((_ routed ...)
(find-router routed)))))