diff options
Diffstat (limited to 'src/scm')
-rw-r--r-- | src/scm/webid-oidc/Makefile.am | 11 | ||||
-rw-r--r-- | src/scm/webid-oidc/authorization-page-unsafe.scm | 185 | ||||
-rw-r--r-- | src/scm/webid-oidc/authorization-page.scm | 59 | ||||
-rw-r--r-- | src/scm/webid-oidc/errors.scm | 14 |
4 files changed, 267 insertions, 2 deletions
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 56b50ec..57bd1b1 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -13,7 +13,10 @@ dist_webidoidcmod_DATA += \ %reldir%/client-manifest.scm \ %reldir%/authorization-code.scm \ %reldir%/refresh-token.scm \ - %reldir%/oidc-id-token.scm + %reldir%/oidc-id-token.scm \ + %reldir%/authorization-page.scm \ + %reldir%/authorization-page-unsafe.scm + webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ @@ -29,4 +32,8 @@ webidoidcgo_DATA += \ %reldir%/client-manifest.go \ %reldir%/authorization-code.go \ %reldir%/refresh-token.go \ - %reldir%/oidc-id-token.go + %reldir%/oidc-id-token.go \ + %reldir%/authorization-page.go \ + %reldir%/authorization-page-unsafe.go + +EXTRA_DIST += %reldir%/ChangeLog diff --git a/src/scm/webid-oidc/authorization-page-unsafe.scm b/src/scm/webid-oidc/authorization-page-unsafe.scm new file mode 100644 index 0000000..f969caf --- /dev/null +++ b/src/scm/webid-oidc/authorization-page-unsafe.scm @@ -0,0 +1,185 @@ +(define-module (webid-oidc authorization-page-unsafe) + #:use-module (webid-oidc errors) + #:use-module (sxml simple) + #:use-module (web uri) + #:use-module (web response) + #:use-module (ice-9 i18n) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 string-fun)) + +(define (G_ text) + (let ((out (gettext text))) + (if (string=? out text) + ;; No translation, disambiguate + (car (reverse (string-split text #\|))) + out))) + +(define (str->sxml str) + (cdadr + (xml->sxml + (string-append "<protect>" str "</protect>")))) + +(define (make-page title . body) + (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 ,(G_ "xml-lang|en"))) + (head + (title ,title)) + (body + ,@body))))))) + +(define-public (authorization-page credential-invalid? + client-id post-uri) + (when (uri? client-id) + (set! client-id (uri->string client-id))) + (when (string? post-uri) + (set! post-uri (string->uri post-uri))) + (values (build-response + #:headers `((content-type application/xhtml+xml))) + + (make-page + (G_ "page-title|Authorization") + (if (equal? + (string->uri client-id) + (string->uri + "http://www.w3.org/ns/solid/terms#PublicOidcClient")) + `(h1 ,@(str->sxml (G_ "Authorize this anonymous application?"))) + `(h1 ,@(str->sxml (format #f (G_ "Authorize <a href=~s>~a</a>?") + client-id client-id)))) + `(p ,@(str->sxml (G_ "Do you want to authorize this application to represent you?"))) + `(form (@ (action ,(uri->string post-uri)) + (method "POST")) + (div + (label (@ (for "password") + ,@(if credential-invalid? + '((class "authz-page-credential-error")) + '())) + ,@(str->sxml + (if credential-invalid? + (G_ "Please retry your password:") + (G_ "Please enter your password:")))) + (input (@ (type "password") + (name "password") + (id "password")))) + (input (@ (type "submit") + (value ,(G_ "Allow")))))))) + +(define (bad-request . body) + (values (build-response #:code 400 + #:reason-phrase "Bad Request" + #:headers '((content-type application/xhtml+xml))) + (apply make-page (G_ "Bad request") body))) + +(define-public (error-no-client-id) + (bad-request + `(p ,@(str->sxml + (G_ "The application did not set the <emph>client_id</emph> parameter."))))) + +(define-public (error-no-redirect-uri) + (bad-request + `(p ,@(str->sxml + (G_ "The application did not set the <emph>redirect_uri</emph> parameter."))))) + +(define (wrap-error err) + (if (record? err) + (let* ((type (record-type-descriptor err)) + (get + (lambda (slot) + ((record-accessor type slot) err))) + (recurse + (lambda (err) + (wrap-error err)))) + (case (record-type-name type) + ((¬-base64) + `((li ,(format #f (G_ "the value ~s is not a base64 string.") + (get 'value))))) + ((¬-json) + `((li ,(format #f (G_ "the following value is not JSON:")) + (pre ,(get 'value))))) + ((¬-turtle) + `((li ,(format #f (G_ "the following value is not Turtle:")) + (pre ,(get 'value))))) + ((&response-failed-unexpectedly) + `((li ,(format #f (G_ "the server request unexpectedly failed with code ~a and reason phrase ~s.") + (get 'response-code) (get 'response-reason-phrase))))) + ((&unexpected-header-value) + `((li ,(let ((value (get 'value))) + (if value + (format #f (G_ "the header ~a should not have the value ~s.\n") + (get 'header) value) + (format #f (G_ "the header ~a should be present.") + (get 'header))))))) + ((&unexpected-response) + (cons + `(li ,(format #f (G_ "the server response wasn’t expected:")) + (pre ,(call-with-output-string + (lambda (port) + (write-response (get 'response) port))))) + (recurse (get 'cause)))) + ((&incorrect-client-id-field) + (let ((value (get 'value))) + `((li + ,(if value + (format #f (G_ "the client_id field is incorrect: ~s") value) + (G_ "the client_id field is missing")))))) + ((&incorrect-redirect-uris-field) + (let ((value (get 'value))) + `((li + ,(if value + (format #f (G_ "the redirect_uris field is incorrect: ~s") value) + (G_ "the redirect_uris field is missing")))))) + ((&cannot-fetch-linked-data) + (cons + `(li ,(format #f (G_ "I could not fetch a RDF graph at ~a;") (uri->string (get 'uri)))) + (recurse (get 'cause)))) + ((¬-a-client-manifest) + (cons + `(li ,(format #f (G_ "this is not a client manifest:")) + (pre ,(format #f "~s" (get 'value)))) + (recurse (get 'cause)))) + ((&unauthorized-redirection-uri) + (cons + `(li ,(format #f (G_ "the manifest does not authorize redirection URI ~a:") + (uri->string (get 'uri))) + (pre ,(format #f "~s" (get 'manifest)))) + (recurse (get 'cause)))) + ((&inconsistent-client-manifest-id) + `((li ,(format #f (G_ "the client manifest at ~a is advertised for ~a;") + (uri->string (get 'id)) + (uri->string (get 'advertised-id)))))) + ((&cannot-fetch-client-manifest) + (cons + `(li ,(format #f (G_ "I could not fetch the client manifest of ~a;") + (uri->string (get 'id)))) + (recurse (get 'cause)))) + ((¬-an-authorization-code-payload) + (cons + `(li ,(format #f (G_ "I could not issue an authorization code for you;"))) + (recurse (get 'cause)))) + (else + (raise-exception err)))) + (throw err))) + +(define-public (error-application error) + (bad-request + `(p ,(G_ "The application you are trying to authorize behaved unexpectedly. Here is the explanation of the error:") + (ol ,@(wrap-error error))))) + +(define-public (redirection client-id uri) + (values (build-response + #:code 302 + #:headers `((location . ,uri) + (content-type application/xhtml+xml))) + (make-page + (G_ "Redirecting...") + `(h1 "Authorization granted, you are being redirected") + `(p ,@(str->sxml + (format + #f + (G_ "<a href=~s>~a</a> can now log in on your behalf. You still need to adjust permissions.") + (uri->string client-id) + (uri->string client-id))))))) diff --git a/src/scm/webid-oidc/authorization-page.scm b/src/scm/webid-oidc/authorization-page.scm new file mode 100644 index 0000000..b2c2f1f --- /dev/null +++ b/src/scm/webid-oidc/authorization-page.scm @@ -0,0 +1,59 @@ +(define-module (webid-oidc authorization-page) + #:use-module (webid-oidc errors) + #:use-module ((webid-oidc authorization-page-unsafe) #:prefix unsafe:) + #:use-module (ice-9 i18n) + #:use-module (ice-9 string-fun) + #:use-module (ice-9 receive) + #:use-module (ice-9 threads)) + +(define locale-mutex + (make-mutex)) + +(define-syntax with-locale + (syntax-rules () + ((with-locale web-locale . job) + (let ((locale-with-underscore + (if (equal? web-locale "C") + ;; For the unit tests + "C" + (string-append + (string-replace-substring web-locale "-" "_") + ".UTF-8"))) + (previous-locale (setlocale LC_ALL))) + (dynamic-wind + (lambda () + (lock-mutex locale-mutex)) + (lambda () + (dynamic-wind + (lambda () + (with-exception-handler + (lambda (error) + (raise-unknown-client-locale web-locale locale-with-underscore) + (setlocale LC_ALL "C")) + (lambda () + (setlocale LC_ALL locale-with-underscore)) + #:unwind? #t)) + (lambda () . job) + (lambda () + (setlocale LC_ALL previous-locale)))) + (lambda () + (unlock-mutex locale-mutex))))))) + +(define-public (authorization-page + locale credential-invalid? client-id post-uri) + (with-locale + locale + (unsafe:authorization-page credential-invalid? + client-id post-uri))) + +(define-public (error-no-client-id locale) + (with-locale locale (unsafe:error-no-client-id))) + +(define-public (error-no-redirect-uri locale) + (with-locale locale (unsafe:error-no-redirect-uri))) + +(define-public (error-application locale error) + (with-locale locale (unsafe:error-application error))) + +(define-public (redirection locale client-id uri) + (with-locale locale (unsafe:redirection client-id uri))) diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index b0e9a19..714e0be 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -777,6 +777,17 @@ (raise-exception ((record-constructor &cannot-encode-id-token) id-token key cause))) +(define-public &unknown-client-locale + (make-exception-type + '&unknown-client-locale + &external-error + '(web-locale c-locale))) + +(define-public (raise-unknown-client-locale web-locale c-locale) + (raise-exception + ((record-constructor &unknown-client-locale) web-locale c-locale) + #:continuable? #t)) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -1087,6 +1098,9 @@ ((¬-an-id-token-payload) (format #f (G_ "~s is not an ID token payload (because ~a)") (get 'value) (recurse (get 'cause)))) + ((&unknown-client-locale) + (format #f (G_ "I couldn’t set the locale to ~s as an approximation of the client locale ~s") + (get 'c-locale) (get 'web-locale))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) |