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