;; 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-configuration)
  #:use-module (webid-oidc oidc-id-token)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc jwk)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module (web uri)
  #:use-module (web client)
  #: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-19)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (sxml simple))

(define*-public (authorize host-or-webid
                           #:key
                           (client-id #f)
                           (redirect-uri #f)
                           (state #f)
                           (http-get http-get))
  (define cannot-be-webid #f)
  (define candidate-errors '())
  ;; host-or-webid can be: the host (as a string), an URI (as a string
  ;; or an URI). 3 differents things.
  (when (string? host-or-webid)
    ;; If it’s a string, it can be either a host name or a URI.
    (set! host-or-webid
          (catch #t
            (lambda ()
              (let ((urified (string->uri host-or-webid)))
                (if urified
                    urified
                    (error "It’s not a string representing an URI."))))
            (lambda error
              (build-uri 'https #:host host-or-webid)))))
  ;; client-id and redirect-uri are required, state must be a string.
  (when (string? client-id)
    (set! client-id (string->uri client-id)))
  (when (string? redirect-uri)
    (set! redirect-uri (string->uri redirect-uri)))
  (let ((host-candidates
         (with-exception-handler
             (lambda (why-not-webid)
               ;; try as an identity provider
               (set! cannot-be-webid why-not-webid)
               (build-uri 'https
                          #:userinfo (uri-userinfo host-or-webid)
                          #:host (uri-host host-or-webid)
                          #:port (uri-port host-or-webid)))
           (lambda ()
             (get-provider-confirmations host-or-webid #:http-get http-get))
           #:unwind? #t)))
    (let ((configurations
           (if cannot-be-webid
               (with-exception-handler
                   (lambda (why-not-identity-provider)
                     (raise-neither-identity-provider-nor-webid
                      host-or-webid
                      why-not-identity-provider
                      cannot-be-webid))
                 (lambda ()
                   (cons (uri->string host-candidates)
                         (get-oidc-configuration (uri-host host-candidates)
                                                 #:userinfo (uri-userinfo host-candidates)
                                                 #:port (uri-port host-candidates)
                                                 #:http-get http-get))))
               (filter
                (lambda (cfg) cfg)
                (map
                 (lambda (host)
                   (with-exception-handler
                       (lambda (cause)
                         (set! candidate-errors (acons host cause candidate-errors))
                         #f)
                     (lambda ()
                       (cons (uri->string host)
                             (get-oidc-configuration (uri-host host)
                                                     #:userinfo (uri-userinfo host)
                                                     #:port (uri-port host)
                                                     #:http-get http-get)))
                     #:unwind? #t))
                 host-candidates)))))
      (let ((authorization-endpoints
             (if cannot-be-webid
                 (with-exception-handler
                     (lambda (why-not-identity-provider)
                       (raise-neither-identity-provider-nor-webid
                        host-or-webid
                        why-not-identity-provider
                        cannot-be-webid))
                   (lambda ()
                     (let ((host (car configurations))
                           (cfg (cdr configurations)))
                       (cons host (oidc-configuration-authorization-endpoint cfg)))))
                 (map
                  (lambda (host/cfg)
                    (let ((host (car host/cfg))
                          (cfg (cdr host/cfg)))
                      (with-exception-handler
                          (lambda (cause)
                            (set! candidate-errors (acons (string->uri host) cause
                                                          candidate-errors)))
                        (lambda ()
                          (cons host
                                (oidc-configuration-authorization-endpoint cfg)))
                        #:unwind? #t)))
                  configurations))))
        (if cannot-be-webid
            (let ((host (car authorization-endpoints))
                  (authz (cdr authorization-endpoints)))
              (list
               (cons
                host
                (build-uri (uri-scheme authz)
                           #:userinfo (uri-userinfo authz)
                           #:host (uri-host authz)
                           #:port (uri-port authz)
                           #:path (uri-path authz)
                           #:query (format #f "client_id=~a&redirect_uri=~a~a"
                                           (uri-encode (uri->string client-id))
                                           (uri-encode (uri->string redirect-uri))
                                           (if state
                                               (format #f "&state=~a"
                                                       (uri-encode state))
                                               ""))))))
            (let ((final-candidates
                   (map
                    (lambda (host/authorization-endpoint)
                      (let ((host (car host/authorization-endpoint))
                            (authorization-endpoint (cdr host/authorization-endpoint)))
                        (cons
                         host
                         (build-uri (uri-scheme authorization-endpoint)
                                    #:userinfo (uri-userinfo authorization-endpoint)
                                    #:host (uri-host authorization-endpoint)
                                    #:port (uri-port authorization-endpoint)
                                    #:path (uri-path authorization-endpoint)
                                    #:query (format #f "client_id=~a&redirect_uri=~a~a"
                                                    (uri-encode (uri->string client-id))
                                                    (uri-encode (uri->string redirect-uri))
                                                    (if state
                                                        (format #f "&state=~a"
                                                                (uri-encode state))
                                                        ""))))))
                    authorization-endpoints)))
              (when (null? final-candidates)
                (raise-no-provider-candidates host-or-webid candidate-errors))
              final-candidates))))))

(define*-public (token host client-key
                       #:key
                       (authorization-code #f)
                       (refresh-token #f)
                       (http-get http-get)
                       (http-post http-post))
  (unless (or authorization-code refresh-token)
    (scm-error 'wrong-type-arg "token"
               "You need to either set #:authorization-code or #:refresh-token."
               '()
               (list authorization-code)))
  (let ((token-endpoint
         (oidc-configuration-token-endpoint
          (get-oidc-configuration host #:http-get http-get)))
        (grant-type
         (if authorization-code
             "authorization_code"
             "refresh_token")))
    (let ((dpop-proof
           (issue-dpop-proof
            client-key
            #:alg (case (kty client-key)
                    ((EC) 'ES256)
                    ((RSA) 'RS256)
                    (else
                     (error "Unknown key type of ~S." client-key)))
            #:htm 'POST
            #:htu token-endpoint)))
      (receive (response response-body)
          (http-post token-endpoint
                     #:body
                     (string-join
                      (map
                       (lambda (arg)
                         (string-append (uri-encode (car arg))
                                        "="
                                        (uri-encode (cdr arg))))
                       `(("grant_type" . ,grant-type)
                         ,@(if authorization-code
                               `(("code" . ,authorization-code))
                               '())
                         ,@(if refresh-token
                               `(("refresh_token" . ,refresh-token))
                               '())))
                      "&")
                     #:headers
                     `((content-type application/x-www-form-urlencoded)
                       (dpop . ,dpop-proof)))
        (with-exception-handler
            (lambda (error)
              (raise-token-request-failed error))
          (lambda ()
            (when (bytevector? response-body)
              (set! response-body (utf8->string response-body)))
            (with-exception-handler
                (lambda (error)
                  (raise-unexpected-response response error))
              (lambda ()
                (unless (eqv? (response-code response) 200)
                  (raise-request-failed-unexpectedly
                   (response-code response)
                   (response-reason-phrase response)))
                (unless (and (response-content-type response)
                             (eq? (car (response-content-type response 'application/json))))
                  (raise-unexpected-header-value 'content-type (response-content-type response)))
                (stubs:json-string->scm response-body)))))))))

(define-public (list-profiles)
  (map (lambda (profile)
         (list
          (string->uri (car profile)) ;; webid
          (string->uri (cadr profile)) ;; issuer
          (caddr profile) ;; refresh token
          (cadddr profile))) ;; key
       (catch #t
         (lambda ()
           (call-with-input-file (string-append (p:data-home) "/profiles")
             read))
         (lambda error
           (format (current-error-port) "Could not read profiles: ~s\n" error)
           '()))))

(define (add-profile webid issuer refresh-token key)
  (let ((other-profiles (list-profiles)))
    (stubs:atomically-update-file
     (string-append (p:data-home) "/profiles")
     (string-append (p:data-home) "/profiles.lock")
     (lambda (port)
       (write
        (map (lambda (profile)
               (list
                (uri->string (car profile)) ;; webid
                (uri->string (cadr profile)) ;; issuer
                (caddr profile) ;; refresh token
                key)) ;; key
             (cons `(,webid
                     ,issuer
                     ,refresh-token)
                   other-profiles))
        port)))))

(define*-public (setup get-host/webid choose-provider browse-authorization-uri
                       #:key
                       (client-id #f)
                       (redirect-uri #f)
                       (http-get http-get)
                       (http-post http-post))
  (let ((host/webid (get-host/webid)))
    (let ((authorization-uris
           (authorize host/webid
                      #:client-id client-id
                      #:redirect-uri redirect-uri
                      #:http-get http-get))
          (key (generate-key #:n-size 2048)))
      (let ((provider (choose-provider (map car authorization-uris))))
        (let ((authz-uri (assq-ref authorization-uris provider)))
          (let ((authz-code (browse-authorization-uri authz-uri)))
            (let ((params
                   (token host/webid key
                          #:authorization-code authz-code
                          #:http-get http-get
                          #:http-post http-post)))
              (let ((id-token (id-token-decode (assq-ref params 'id_token)
                                               #:http-get http-get))
                    (access-token (assq-ref params 'access_token))
                    (refresh-token (assq-ref params 'refresh_token)))
                (when refresh-token
                  ;; Save it to disk
                  (add-profile (id-token-webid id-token)
                               (id-token-iss id-token)
                               refresh-token
                               key))
                (values (cdr id-token) access-token key)))))))))

(define*-public (login webid issuer refresh-token key
                       #:key
                       (http-get http-get)
                       (http-post http-post))
  (when (string? webid)
    (set! webid (string->uri webid)))
  (when (string? issuer)
    (set! issuer (string->uri issuer)))
  (let ((iss-host (uri-host issuer)))
    (let ((params
           (token iss-host key
                  #:refresh-token refresh-token
                  #:http-get http-get
                  #:http-post http-post)))
      (let ((id-token (id-token-decode (assq-ref params 'id_token)
                                       #:http-get http-get))
            (access-token (assq-ref params 'access_token))
            (new-refresh-token (assq-ref params 'refresh-token)))
        (when (and new-refresh-token
                   (not (equal? refresh-token new-refresh-token)))
          ;; The refresh token has been updated
          (add-profile (id-token-webid id-token)
                       (id-token-iss id-token)
                       refresh-token
                       key))
        (values (cdr id-token) access-token key)))))

(define*-public (refresh id-token
                         key
                         #:key
                         (http-get http-get)
                         (http-post http-post))
  (when (id-token-payload? id-token)
    ;; For convenience, we’d like a full ID token to use the ID token
    ;; API.
    (set! id-token (cons `((alg . "HS256")) id-token)))
  (let ((profiles (list-profiles)))
    (letrec ((find-refresh-token
              (lambda (profiles)
                (when (null? profiles)
                  (raise-profile-not-found (id-token-webid id-token)
                                           (id-token-iss id-token)
                                           (p:data-home)))
                (let ((prof (car profiles))
                      (others (cdr profiles)))
                  (let ((webid (car prof))
                        (issuer (cadr prof))
                        (refresh (caddr prof)))
                    (if (and (equal? webid (id-token-webid id-token))
                             (equal? issuer (id-token-iss id-token)))
                        refresh
                        (find-refresh-token others)))))))
      (login (id-token-webid id-token)
             (id-token-iss id-token)
             (find-refresh-token (profiles))
             key
             #:http-get http-get
             #:http-post http-post))))

(define* (renew-if-expired id-token access-token key
                           date
                           #:key
                           (http-get http-get)
                           (http-post http-post))
  ;; Since we’re not supposed to decode the access token, we’re
  ;; judging from the ID token to know if it has expired.
  (when (date? date)
    (set! date (date->time-utc date)))
  (when (time? date)
    (set! date (time-second date)))
  (when (id-token-payload? id-token)
    ;; See the refresh function
    (set! id-token (cons `((alg . "HS256")) id-token)))
  (let ((exp (id-token-exp id-token)))
    (set! exp (date->time-utc exp))
    (set! exp (time-second exp))
    (if (>= date exp)
        (parameterize ((p:current-date (lambda () date)))
          (refresh id-token key
                   #:http-get http-get
                   #:http-post http-post))
        (values id-token access-token key))))

(define*-public (make-client id-token access-token key
                             #:key
                             (http-get http-get)
                             (http-post http-post)
                             (http-request http-request))
  ;; 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" string->symbol symbol? write)
  (define (handler uri method headers other-args retry?)
    (let ((proof (issue-dpop-proof
                  key
                  #:alg (case (kty key)
                          ((EC) 'ES256)
                          ((RSA) 'RS256)
                          (else
                           (error "Unknown key type of ~S." key)))
                  #:htm method
                  #:htu uri
                  #:access-token access-token)))
      (receive (response response-body)
          (apply http-request uri
                 #:method method
                 #:headers (append `((dpop . ,proof)
                                     (Authorization . ,(string-append "DPoP " access-token)))
                                   headers)
                 other-args)
        (let ((server-date (response-date response))
              (code (response-code response)))
          (if (and retry? (eqv? code 401))
              ;; Maybe the access token has expired?
              (receive (new-id-token new-access-token new-key)
                  (renew-if-expired id-token access-token key server-date
                                    #:http-get http-get
                                    #:http-post http-post)
                (if (equal? access-token new-access-token)
                    ;; No, it’s just that way.
                    (values response response-body)
                    ;; Ah, we have a new access token
                    (begin
                      (set! id-token new-id-token)
                      (set! access-token new-access-token)
                      (set! key new-key)
                      (handler uri method headers other-args #f))))
              (values response response-body))))))
  (define (parse-args uri method headers other-args-rev rest)
    (if (null? rest)
        (handler uri method headers (reverse other-args-rev) #t)
        (let ((kw (car rest)))
          (case kw
            ((#:method)
             (if (null? (cdr rest))
                 (parse-args uri method headers (cons kw other-args-rev) '())
                 (parse-args uri (cadr rest) headers other-args-rev (cddr rest))))
            ((#:headers)
             (if (null? (cdr rest))
                 (parse-args uri method headers (cons kw other-args-rev) '())
                 (parse-args uri method (append headers (cadr rest)) other-args-rev (cddr rest))))
            (else
             (parse-args uri method headers (cons kw other-args-rev) '()))))))
  (define (parse-http-request-args uri args)
    (parse-args uri 'GET '() '() args))
  (lambda (uri . args)
    (parse-http-request-args uri args)))

(define*-public (serve-application id redirect-uri
                                   #:key
                                   (client-name "Example application")
                                   (client-uri "https://webid-oidc-demo.planete-kraus.eu"))
  (when (string? id)
    (set! id (string->uri id)))
  (when (string? redirect-uri)
    (set! redirect-uri (string->uri redirect-uri)))
  (when (string? client-uri)
    (set! client-uri (string->uri client-uri)))
  (let* ((manifest
          (format #f
                  "{
  \"@context\": \"https://www.w3.org/ns/solid/oidc-context.jsonld\",
  \"client_id\" : \"~a\",
  \"redirect_uris\" : [\"~a\"],
  \"client_name\" : \"~a\",
  \"client_uri\" : \"~a\",
  \"grant_types\" : [\"refresh_token\", \"authorization_code\"],
  \"response_types\" : [\"code\"]
}
"
                  (uri->string id)
                  (uri->string redirect-uri)
                  client-name
                  (uri->string id)))
         (manifest-etag (stubs:hash 'SHA-256 manifest)))
    (lambda (request request-body)
      (let ((uri (request-uri request)))
        (cond
         ((equal? (uri-path uri) (uri-path id))
          (let ((if-none-match (request-if-none-match request)))
            (if (and (list? if-none-match)
                     (member manifest-etag
                             (map car (request-if-none-match request))))
                (values
                 (build-response
                  #:code 304
                  #:reason-phrase "Not Modified"
                  #:headers `((content-type application/ld+json)
                              (etag . (,manifest-etag . #t))))
                 #f)
                (values
                 (build-response
                  #:headers `((content-type application/ld+json)
                              (etag . (,manifest-etag . #t))
                              (cache-control public must-revalidate)))
                 manifest))))
         ((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 "en"))
                                (head
                                 (title "Authorization"))
                                (body
                                 (p "You have been authorized. Please paste the following code in the application:")
                                 (p (strong ,code)))))))))
                  (values
                   (build-response
                    #:code 400
                    #: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 "en"))
                                (head
                                 (title "Error"))
                                (body
                                 (p "Your identity provider did not authorize you. :("))))))))))))
         (else
          (values
           (build-response
            #:code 404
            #: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 "en"))
                        (head
                         (title "Not Found"))
                        (body
                         (p "This page does not exist on the server."))))))))))))))