;; disfluid, implementation of the Solid specification
;; Copyright (C) 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 server endpoint authentication)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc access-token)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc provider-confirmation)
  #:use-module (webid-oidc server endpoint)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (web server)
  #:use-module (web client)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (webid-oidc web-i18n)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (ice-9 control)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module (sxml simple)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (oop goops)
  #:duplicates (merge-generics)
  #:declarative? #t
  #:export
  (
   <authenticator>
   backend
   server-uri
   ))

(define-class <authenticator> (<endpoint>)
  (backend #:init-keyword #:backend #:getter backend)
  (server-uri #:init-keyword #:server-uri #:getter server-uri))

(define-method (initialize (endpoint <authenticator>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((backend #f)
    (server-uri #f))
   (unless (is-a? backend <endpoint>)
     (scm-error 'wrong-type-arg "make <authenticator>"
                (G_ "#:backend should be an endpoint")
                '()
                (list backend)))
   (match server-uri
     ((? string? (= string->uri (? uri? the-server-uri)))
      (set! server-uri the-server-uri)
      (slot-set! endpoint 'server-uri the-server-uri))
     (else #t))
   (unless (and server-uri (uri? server-uri))
     (scm-error 'wrong-type-arg "make <authenticator>"
                (G_ "#:server-uri should be an URI")
                '()
                (list server-uri)))))

(define-method (handle (endpoint <authenticator>) request request-body)
  (define accumulated-error '())
  (let ((headers (request-headers request))
        (uri (request-uri request))
        (method (request-method request)))
    (let ((authz (assq-ref headers 'authorization))
          (dpop (assq-ref headers 'dpop))
          (full-uri
           (let ((server-uri (server-uri endpoint)))
             (build-uri (uri-scheme server-uri)
                        #:userinfo (uri-userinfo server-uri)
                        #:host (uri-host server-uri)
                        #:port (uri-port server-uri)
                        #:path
                        (string-append
                         (if (and (equal? (uri-path server-uri) "")
                                  (equal? (uri-path uri) ""))
                             ""
                             ;; It must start with a / then
                             "/")
                         (encode-and-join-uri-path
                          (append
                           (split-and-decode-uri-path (uri-path server-uri))
                           (split-and-decode-uri-path (uri-path uri))))
                         (if (string-suffix? (uri-path uri) "/")
                             "/"
                             ""))))))
      (let ((user
             (and authz dpop
                  (eq? (car authz) 'dpop)
                  (with-exception-handler
                      (lambda (error)
                        (if (exception-with-message? error)
                            (format (current-error-port)
                                    (G_ "~a: authentication failure: ~a\n")
                                    (date->string ((p:current-date)))
                                    (exception-message error))
                            (format (current-error-port)
                                    (G_ "~a: authentication failure\n")
                                    (date->string ((p:current-date)))))
                        (set! accumulated-error
                              (make-exception
                               (make-user-message
                                (call-with-input-string
                                    (format #f (W_ "<p>There is an access token and a DPoP proof, but one or both is invalid.</p>"))
                                  xml->sxml))
                               error))
                        #f)
                    (lambda ()
                      ;; Sometimes the access is the cadr as a symbol,
                      ;; sometimes it is the cdr as a string. It depends
                      ;; whether the response has been written and read,
                      ;; or preserved as a guile object.
                      (let* ((lit-access-token
                              (match authz
                                ;; That’s when the request is parsed:
                                (('dpop (? symbol? symbol-value))
                                 (symbol->string symbol-value))
                                ;; That’s when it’s not:
                                (('dpop . (? string? string-value))
                                 string-value)))
                             (access-token
                              (decode <access-token> lit-access-token))
                             (cnf/jkt (cnf/jkt access-token))
                             (dpop-proof
                              (decode <dpop-proof> dpop
                                      #:method method
                                      #:uri full-uri
                                      #:cnf/check cnf/jkt
                                      #:access-token lit-access-token)))
                        (let ((subject (webid access-token))
                              (issuer (iss access-token)))
                          (confirm-provider subject issuer)
                          subject)))
                    #:unwind? #t))))
        (with-exception-handler
            (lambda (exn)
              ;; Since a 401 might be returned normally or raised as
              ;; an exception, we won’t add the header to authenticate
              ;; with DPoP in this layer.
              (raise-exception
               (apply make-exception
                      exn
                      (make-caused-by-user user)
                      accumulated-error)))
          (lambda ()
            (receive (response response-body meta)
                (handle (backend endpoint)
                        (build-request (request-uri request)
                                       #:method (request-method request)
                                       #:headers (request-headers request)
                                       #:port (request-port request)
                                       #:meta `((user . ,user)
                                                ,@(request-meta request)))
                        request-body)
              (values response response-body `((user . ,user) ,@meta)))))))))