;; webid-oidc, 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 (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 "" str ""))))
(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?")
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 client_id parameter.")))))
(define-public (error-no-redirect-uri)
(bad-request
`(p ,@(str->sxml
(G_ "The application did not set the redirect_uri 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 can now log in on your behalf. You still need to adjust permissions.")
(uri->string client-id)
(uri->string client-id)))))))