diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-14 14:23:51 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-19 11:32:00 +0200 |
commit | a219bf64933d3313aebe0e5576b291e32e93d93f (patch) | |
tree | cac1226f500dfbd5a7daf991bfc2b157846ad83d /src/scm/webid-oidc/server/endpoint.scm | |
parent | 19915a8b5b2912d255a6850a5d8d796a4f9c7fc9 (diff) |
server: add an exception for showing a message to the user
Diffstat (limited to 'src/scm/webid-oidc/server/endpoint.scm')
-rw-r--r-- | src/scm/webid-oidc/server/endpoint.scm | 64 |
1 files changed, 58 insertions, 6 deletions
diff --git a/src/scm/webid-oidc/server/endpoint.scm b/src/scm/webid-oidc/server/endpoint.scm index d327139..9a19ceb 100644 --- a/src/scm/webid-oidc/server/endpoint.scm +++ b/src/scm/webid-oidc/server/endpoint.scm @@ -48,8 +48,62 @@ 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 <endpoint> () (host #:init-keyword #:host #:getter host #:init-value #f) (path #:init-keyword #:path #:getter path #:init-value "/")) @@ -122,12 +176,10 @@ (let find-router ((routed (routed endpoint))) (match routed (() - (values - (build-response - #:code 404 - #:reason-phrase (W_ "Not Found")) - #f - '())) + (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))) _ ...) |