;; 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)))))))