;; 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 client)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc provider-confirmation)
  #:use-module (webid-oidc oidc-id-token)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc client-manifest)
  #:use-module (webid-oidc web-i18n)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module ((webid-oidc cache) #:prefix cache:)
  #:use-module ((webid-oidc client accounts) #:prefix account:)
  #:use-module ((webid-oidc client client) #:prefix client:)
  #:use-module (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web server)
  #:use-module (web http)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (ice-9 match)
  #:use-module (sxml simple)
  #:use-module (oop goops)
  #:duplicates (merge-generics)
  #:re-export
  (
   (client:<client> . <client>)
   (client:client-id . client-id)
   (client:key-pair . key-pair)
   (client:redirect-uri . redirect-uri)

   (client:client . client)
   (account:authorization-process . authorization-process)
   (account:authorization-state . authorization-state)
   )
  #:export
  (
   request

   serve-application

   <extended-client-manifest>
   )
  #:declarative? #t)

;; For syntax highlighting
(define <account:account> account:<account>)
(define <client:client> client:<client>)

(define (setup-headers!)
  ;; HACK: guile does not support other authentication schemes in
  ;; WWW-Authenticate than Basic, so it will crash when a response
  ;; containing that header will be issued.
  (declare-header!
   "WWW-Authenticate"
   (cute parse-header 'pragma <>)
   (lambda (value)
     (and (list? value)
          (let check-value ((schemes value))
            (match schemes
              (() #t)
              (((? symbol?) tl ...)
               (check-value tl))
              (((hd . args) tl ...)
               (and (symbol? hd)
                    (let check-args ((args args))
                      (match args
                        (() #t)
                        (((key . value) tl ...)
                         (and (symbol? key)
                              (string? value)
                              (check-args tl)))))
                    (check-value tl)))))))
   (cute write-header 'pragma <> <>))
  ;; The same applies for the authorization header.
  (let ((original-parser (header-parser 'authorization))
        (original-writer (header-writer 'authorization)))
    (declare-header!
     "Authorization"
     original-parser
     (lambda (value) #t)
     (match-lambda*
       ((('dpop . dpop) port)
        (format port "DPoP ~a" dpop))
       ((value port)
        (original-writer value port))))))

(define* (initial-login client issuer)
  (setup-headers!)
  (parameterize ((client:client client))
    (make <account:account>
      #:issuer issuer)))

(define (request account uri . other-args)
  (setup-headers!)
  (unless (account:access-token account)
    (set! account (account:refresh account)))
  (define (do-with-headers method headers non-header-args can-fail?)
    (let* ((access-token (account:access-token account))
           (dpop-proof
            (let ((key-pair (account:key-pair account)))
              (issue <dpop-proof>
                     key-pair
                     #:jwk (public-key key-pair)
                     #:htm method
                     #:htu uri
                     #:access-token access-token))))
      (let ((all-headers
             `((dpop . ,dpop-proof)
               (authorization . (dpop . ,access-token))
               (accept-language . ((2 . ,(G_ "accept-language-header|en-us"))
                                   (1 . "en-us")))
               ,@headers)))
        (receive (response body)
            (apply (p:anonymous-http-request) uri
                   #:headers all-headers
                   non-header-args)
          (let ((code (response-code response)))
            (if (and (eqv? code 401) can-fail?)
                ;; Code expired
                (begin
                  (set! account (account:refresh (account:invalidate-access-token account)))
                  ;; retry
                  (do-with-headers method headers non-header-args #f))
                (values account response body)))))))
  (let scan-arguments ((args other-args)
                       (headers #f)
                       (non-header-args '())
                       (method #f))
    (match args
      (()
       (cond
        ((not headers)
         (scan-arguments args '() non-header-args method))
        ((not method)
         (scan-arguments args headers non-header-args 'GET))
        (else
         (do-with-headers method headers (reverse non-header-args) #t))))
      ((#:method new-method args ...)
       (scan-arguments args headers non-header-args (or method new-method)))
      ((#:headers (new-headers ...) args ...)
       (scan-arguments args (or headers new-headers) non-header-args method))
      ((kw value args ...)
       (scan-arguments args headers `(,value ,kw ,@non-header-args) method)))))

(define-class <extended-client-manifest> (<client-manifest>)
  (client-name #:init-keyword #:client-name #:accessor client-name)
  (client-uri #:init-keyword #:client-uri #:accessor client-uri)
  (grant-types #:init-keyword #:grant-types #:accessor grant-types)
  (response-types #:init-keyword #:response-types #:accessor response-types)
  #:module-name '(webid-oidc client))

(define-method (initialize (client <extended-client-manifest>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((client-name (G_ "Example application"))
    (client-uri "https://webid-oidc-demo.planete-kraus.eu")
    (grant-types '(refresh_token authorization_code))
    (response-types '(code)))
   (let fix-grant-types ((grant-types grant-types)
                         (ok '()))
     (match grant-types
       (()
        (let ((grant-types (reverse ok)))
          (let fix-response-types ((response-types response-types)
                                   (ok '()))
            (match response-types
              (()
               (let ((response-types (reverse ok)))
                 (let fix-client-uri ((client-uri client-uri))
                   (match client-uri
                     ((? uri? client-uri)
                      (let fix-client-name ((client-name client-name))
                        (match client-name
                          ((? string? client-name)
                           (begin
                             (slot-set! client 'client-name client-name)
                             (slot-set! client 'client-uri client-uri)
                             (slot-set! client 'grant-types grant-types)
                             (slot-set! client 'response-types response-types)))
                          (else
                           (scm-error 'wrong-type-arg "make"
                                      (G_ "#:client-name should be a string")
                                      '()
                                      (list client-name))))))
                     ((? string? (= string->uri (? uri? client-uri)))
                      (fix-client-uri client-uri))
                     (else
                      (scm-error 'wrong-type-arg "make"
                                 (G_ "#:client-uri should be an URI")
                                 '()
                                 (list client-uri)))))))
              (((or (? string? (= string->symbol hd))
                    (? symbol? hd))
                response-types ...)
               (fix-response-types response-types `(,hd ,@ok)))
              (else
               (scm-error 'wrong-type-arg "make"
                          (G_ "#:response-types should be a list of symbols")
                          '()
                          (list response-types)))))))
       (((or (? string? (= string->symbol hd))
             (? symbol? hd))
         grant-types ...)
        (fix-grant-types grant-types `(,hd ,@ok)))
       (else
        (scm-error 'wrong-type-arg "make"
                   (G_ "#:grant-types should be a list of symbols")
                   '()
                   (list grant-types)))))))

(define-method (->json-data (client <extended-client-manifest>))
  (let ((other
         (catch 'goops-error
           (lambda ()
             (next-method))
           (lambda _
             '()))))
    (let ((all
           `((client_name . ,(client-name client))
             (client_uri . ,(uri->string (client-uri client)))
             (grant_types . ,(list->vector (map symbol->string (grant-types client))))
             (response_types . ,(list->vector (map symbol->string (response-types client))))
             ,@other)))
      ;; Put @context first
      (receive (context non-context)
          (let search-context ((fields all)
                               (context-ones '())
                               (non-context-ones '()))
            (match fields
              ((('@context . ,context) fields ...)
               (search-context fields `(,context ,@context-ones) non-context-ones))
              ((non-context fields ...)
               (search-context fields context-ones `(,non-context ,@non-context-ones)))
              (()
               (values (reverse context-ones) (reverse non-context-ones)))))
        (append
         (map (lambda (ctx) `(@context . ,ctx)) context)
         non-context)))))

(define* (serve-application id redirect-uri . args)
  (let ((manifest (apply make <extended-client-manifest>
                         #:client-id id
                         #:redirect-uris (list redirect-uri)
                         args)))
    (lambda (request request-body)
      (parameterize ((web-locale request))
        (let ((uri (request-uri request)))
          (cond
           ((equal? (uri-path uri) (uri-path id))
            (receive (response response-body) (serve manifest #f)
              (let ((if-none-match (request-if-none-match request))
                    (etag (response-etag response)))
                (if (and (list? if-none-match)
                         etag
                         (member (car etag) (map car if-none-match)))
                    (values
                     (build-response
                      #:code 304
                      #:reason-phrase (W_ "reason-phrase|Not Modified")
                      #:headers `((content-type application/ld+json)
                                  (etag . ,etag)))
                     #f)
                    (values response response-body)))))
           ((equal? (uri-path uri) (uri-path redirect-uri))
            (let ((query-args
                   (map
                    (lambda (key=value)
                      (let ((splits
                             (map uri-decode (string-split key=value #\=))))
                        (if (or (null? splits) (null? (cdr splits)))
                            splits
                            (cons (string->symbol (car splits)) (cdr splits)))))
                    (string-split (uri-query uri) #\&))))
              (let ((code (assq-ref query-args 'code)))
                (if code
                    (values
                     (build-response
                      #:headers `((content-type application/xhtml+xml)))
                     (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 ,(W_ "page-title|Authorization")))
                                  (body
                                   (p ,(W_ "You have been authorized. Please paste the following code in the application:"))
                                   (p (strong ,code)))))))))
                    (values
                     (build-response
                      #:code 400
                      #:reason-phrase (W_ "reason-phrase|Invalid Request")
                      #:headers `((content-type application/xhtml+xml)))
                     (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 ,(W_ "page-title|Error")))
                                  (body
                                   (p ,(W_ "Your identity provider did not authorize you. :(")))))))))))))
           (else
            (values
             (build-response
              #:code 404
              #:reason-phrase (W_ "reason-phrase|Not Found")
              #:headers `((content-type application/xhtml+xml)))
             (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 ,(W_ "page-title|Not Found")))
                          (body
                           (p ,(W_ "This page does not exist on the server."))))))))))))))))