(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 "<protect>" str "</protect>"))))

(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 href=~s>~a</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 <emph>client_id</emph> parameter.")))))

(define-public (error-no-redirect-uri)
  (bad-request
   `(p ,@(str->sxml
          (G_ "The application did not set the <emph>redirect_uri</emph> 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)
          ((&not-base64)
           `((li ,(format #f (G_ "the value ~s is not a base64 string.")
                          (get 'value)))))
          ((&not-json)
           `((li ,(format #f (G_ "the following value is not JSON:"))
                 (pre ,(get 'value)))))
          ((&not-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.")))))))
          ((&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))))
          ((&not-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))))
          ((&not-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 href=~s>~a</a> can now log in on your behalf. You still need to adjust permissions.")
                   (uri->string client-id)
                   (uri->string client-id)))))))