diff options
Diffstat (limited to 'src/scm/webid-oidc/authorization-page-unsafe.scm')
-rw-r--r-- | src/scm/webid-oidc/authorization-page-unsafe.scm | 137 |
1 files changed, 0 insertions, 137 deletions
diff --git a/src/scm/webid-oidc/authorization-page-unsafe.scm b/src/scm/webid-oidc/authorization-page-unsafe.scm deleted file mode 100644 index 640ad53..0000000 --- a/src/scm/webid-oidc/authorization-page-unsafe.scm +++ /dev/null @@ -1,137 +0,0 @@ -;; 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 <https://www.gnu.org/licenses/>. - -(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 "<protect>" str "</protect>")) - ((*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 href=~s>~a</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 <emph>client_id</emph> parameter."))))) - -(define (error-no-redirect-uri) - (bad-request - `(p ,@(str->sxml - (W_ "The application did not set the <emph>redirect_uri</emph> 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_ "<p><a href=~s>~a</a> can now log in on your behalf. You still need to adjust permissions.</p>") - (uri->string client-id) - (uri->string client-id))))))) |