;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 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 authorization-page-unsafe) #:use-module (webid-oidc errors) #:use-module (sxml simple) #:use-module (web uri) #:use-module (web response) #:use-module (webid-oidc web-i18n) #:use-module (ice-9 exceptions) #:use-module (ice-9 string-fun) #:use-module (ice-9 match) #:use-module (sxml simple) #:use-module (sxml match) #:declarative? #t #:export ( authorization-page error-no-client-id error-no-redirect-uri error-application redirection )) (define (str->sxml str) (sxml-match (xml->sxml (string-append "" str "")) ((*TOP* (protect ,element ...)) (list element ...)))) (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 ,(W_ "xml-lang|en"))) (head (title ,title)) (body ,@body))))))) (define (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 (W_ "page-title|Authorization") (if (equal? (string->uri client-id) (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient")) `(h1 ,@(str->sxml (W_ "Authorize this anonymous application?"))) `(h1 ,@(str->sxml (format #f (W_ "Authorize ~a?") client-id client-id)))) `(p ,@(str->sxml (W_ "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? (W_ "Please retry your password:") (W_ "Please enter your password:")))) (input (@ (type "password") (name "password") (id "password")))) (input (@ (type "submit") (value ,(W_ "Allow")))))))) (define (bad-request . body) (values (build-response #:code 400 #:reason-phrase (W_ "reason-phrase|Bad Request") #:headers '((content-type application/xhtml+xml))) (apply make-page (W_ "Bad request") body))) (define (error-no-client-id) (bad-request `(p ,@(str->sxml (W_ "The application did not set the client_id parameter."))))) (define (error-no-redirect-uri) (bad-request `(p ,@(str->sxml (W_ "The application did not set the redirect_uri parameter."))))) (define (wrap-error err) (if (message-for-the-user? err) (user-message err) `(p (W_ "Sorry, no more information is available.")))) (define (error-application error) (bad-request `(div (p ,(W_ "The application you are trying to authorize behaved unexpectedly.")) ,@(sxml-match (wrap-error error) ((div ,element ...) `(,element ...)) (,else `(,else)))))) (define (redirection client-id uri) (values (build-response #:code 302 #:reason-phrase (W_ "reason-phrase|Found") #:headers `((location . ,uri) (content-type application/xhtml+xml))) (make-page (W_ "Redirecting...") `(h1 "Authorization granted, you are being redirected") `(p ,@(str->sxml (format #f (W_ "

~a can now log in on your behalf. You still need to adjust permissions.

") (uri->string client-id) (uri->string client-id)))))))