(define-module (webid-oidc resource-server)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc oidc-configuration)
  #:use-module (webid-oidc provider-confirmation)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc dpop-proof)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module (webid-oidc jti)
  #:use-module (webid-oidc access-token)
  #: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 (ice-9 i18n)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (sxml simple)
  #:use-module (srfi srfi-19))

(define (G_ text)
  (let ((out (gettext text)))
    (if (string=? out text)
        ;; No translation, disambiguate
        (car (reverse (string-split text #\|)))
        out)))

(define*-public (make-authenticator jti-list
                                    #:key
                                    (server-uri #f)
                                    (current-time current-time)
                                    (http-get http-get))
  (unless (and server-uri (uri? server-uri))
    (error "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri)."))
  (lambda (request request-body)
    (let ((headers (request-headers request))
          (uri (request-uri request))
          (method (request-method request))
          (current-time
           (let ((t current-time))
             (when (thunk? t)
               (set! t (t)))
             (when (integer? t)
               (set! t (make-time time-utc 0 t)))
             (when (time? t)
               (set! t (time-utc->date t)))
             t)))
      (let ((authz (assoc-ref headers 'authorization))
            (dpop (assoc-ref headers 'dpop))
            (full-uri (build-uri (uri-scheme server-uri)
                                 #:userinfo (uri-userinfo server-uri)
                                 #:host (uri-host server-uri)
                                 #:port (uri-port server-uri)
                                 #:path (string-append
                                         "/"
                                         (encode-and-join-uri-path
                                          (append
                                           (split-and-decode-uri-path (uri-path server-uri))
                                           (split-and-decode-uri-path
                                            (uri-path uri))))))))
        (and authz dpop
             (eq? (car authz) 'dpop)
             (with-exception-handler
                 (lambda (error)
                   (format (current-error-port)
                           (G_ "~a: authentication failure: ~a\n")
                           (date->string current-time)
                           (error->str error))
                   #f)
               (lambda ()
                 (let* ((access-token
                         (access-token-decode
                          (symbol->string (cadr authz))
                          #:http-get http-get))
                        (cnf/jkt (access-token-cnf/jkt access-token))
                        (dpop-proof
                         (dpop-proof-decode
                          current-time jti-list method full-uri
                          dpop cnf/jkt)))
                   (let ((subject (access-token-webid access-token))
                         (issuer (access-token-iss access-token)))
                     (confirm-provider subject issuer #:http-get http-get)
                     subject)))
               #:unwind? #t))))))