diff options
Diffstat (limited to 'src/scm/webid-oidc/authorization-page-unsafe.scm')
| -rw-r--r-- | src/scm/webid-oidc/authorization-page-unsafe.scm | 185 |
1 files changed, 185 insertions, 0 deletions
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))))))) |