diff options
Diffstat (limited to 'src/scm/webid-oidc/hello-world.scm')
| -rw-r--r-- | src/scm/webid-oidc/hello-world.scm | 122 |
1 files changed, 51 insertions, 71 deletions
diff --git a/src/scm/webid-oidc/hello-world.scm b/src/scm/webid-oidc/hello-world.scm index 98b4703..4d97657 100644 --- a/src/scm/webid-oidc/hello-world.scm +++ b/src/scm/webid-oidc/hello-world.scm @@ -15,6 +15,8 @@ ;; along with this program. If not, see <https://www.gnu.org/licenses/>. (define-module (webid-oidc hello-world) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc server endpoint hello) #:use-module (webid-oidc resource-server) #:use-module (webid-oidc server log) #:use-module (webid-oidc web-i18n) @@ -28,32 +30,15 @@ #:use-module (ice-9 i18n) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 match) #:use-module (sxml simple) #:use-module (sxml match) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (oop goops) + #:duplicates (merge-generics) #:declarative? #t) -(define (hello-page id) - `(*TOP* - (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang ,(W_ "xml-lang|en"))) - (body - ,(sxml-match - (xml->sxml - (format #f (W_ "<h1>Hello, ~a!</h1>") - (uri->string id) - (with-output-to-string - (lambda () - (sxml->xml - `(a (@ (href ,(uri->string id))) - ,(uri->string id))))))) - ((*TOP* ,title) title)) - ,(sxml-match - (xml->sxml - (format #f (W_ "<p>The client is compatible with Solid.</p>"))) - ((*TOP* ,p) p)))))) - (define-public (main) (setvbuf (current-output-port) 'none) (setvbuf (current-error-port) 'none) @@ -137,6 +122,7 @@ Options: (format (current-error-port) (G_ "The port should be a number between 0 and 65535.\n")) (exit 1)) + (define greeter (make <greeter>)) (let ((handler (lambda (request request-body) (when log-file @@ -144,55 +130,49 @@ Options: (when error-file (prepare-error-file error-file)) (parameterize ((web-locale request)) - (if (eq? (request-method request) 'GET) - (let ((agent (assoc-ref (request-headers request) 'xxx-agent))) - (if (and agent (string->uri agent)) - (values - (build-response - #:headers `((content-type application/xhtml+xml) - (source . ,means-string))) - (with-output-to-string - (lambda () - (sxml->xml (hello-page (string->uri agent)))))) - (values - (build-response #:code 401 - #:reason-phrase (W_ "reason-phrase|Unauthorized") - #:headers `((content-type application/xhtml+xml) - (source . ,means-string))) - (with-output-to-string - (lambda () - (sxml->xml - `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang ,(W_ "xml-lang|en"))) - (body - ,(sxml-match - (xml->sxml - (format #f (W_ "<h1>Please authenticate</h1>"))) - ((*TOP* ,title) title)) - ,(sxml-match - (xml->sxml - (format #f (W_ "<p>This page requires authentication with Solid.</p>"))) - ((*TOP* ,p) p))))))))))) - (values - (build-response #:code 405 - #:reason-phrase (W_ "reason-phrase|Method Not Allowed") - #:headers `((content-type application/xhtml+xml) - (source . ,means-string))) - (with-output-to-string - (lambda () - (sxml->xml - `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang ,(W_ "xml-lang|en"))) - (body - ,(sxml-match - (xml->sxml - (format #f (W_ "<h1>Method not allowed</h1>"))) - ((*TOP* ,title) title)) - ,(sxml-match - (xml->sxml - (format #f (W_ "<p>You can only use the <emph>GET</emph> method on this resource.</p>"))) - ((*TOP* ,p) p)))))))))))))) + (with-exception-handler + (lambda (exn) + (unless (web-exception? exn) + (raise-exception exn)) + (values + (build-response + #:code (web-exception-code exn) + #:reason-phrase (web-exception-reason-phrase exn) + #:headers `((content-type application/xhtml+xml))) + (call-with-output-string + (cute sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(call-with-input-string + (format #f (W_ "<h1>Please authenticate</h1>")) + xml->sxml) + ,(if (user-message? exn) + (user-message-sxml exn) + (call-with-input-string + (format #f (W_ "<p>No more information.</p>")) + xml->sxml))))) + <>)))) + (lambda () + (set! request + (let ((user + (match (assq-ref (request-headers request) 'xxx-agent) + ((? string? (= string->uri (? uri? uri))) + uri) + (else #f)))) + (build-request (request-uri request) + #:meta (if user `((user . ,user)) '()) + #:headers (request-headers request) + #:version (request-version request) + #:method (request-method request)))) + (receive (response response-body response-meta) + (handle greeter request request-body) + (when (port? response-body) + (set! response-body + (read-response-body response))) + (values response response-body))) + #:unwind? #t))))) (install-suspendable-ports!) (run-server handler 'http (list #:port (string->number port-string)))))))))) |