;; webid-oidc, 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 reverse-proxy)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (webid-oidc resource-server)
  #:use-module (webid-oidc jti)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #: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 (srfi srfi-19)
  #:use-module (rnrs bytevectors)
  #:use-module (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web client)
  #:use-module (webid-oidc cache)
  #:use-module (web server))

(define*-public (make-reverse-proxy
                 #:key
                 (jti-list #f)
                 (server-uri #f)
                 (current-time current-time)
                 (http-get http-get)
                 (endpoint #f)
                 (auth-header 'XXX-Agent))
  (set! auth-header
        ;; We need to remove the lowercase version of auth-header from
        ;; all incoming requests!
        (string->symbol
         (string-downcase
          (symbol->string auth-header))))
  (define authenticate
    (make-authenticator
     (or jti-list (make-jti-list))
     #:server-uri server-uri
     #:current-time current-time
     #:http-get http-get))
  (unless (and endpoint (uri? endpoint))
    (error "#:endpoint argument is not present or not an URI."))
  (lambda (request request-body)
    (let ((agent
           (catch #t
             (lambda ()
               (authenticate request request-body))
             (lambda (key . args)
               (case key
                 ((invalid-access-token
                   invalid-proof
                   unconfirmed-issuer)
                  #f)
                 (else
                  (apply throw key args)))))))
      (let ((raw-headers (request-headers request)))
        (let ((modified-headers
               (append
                (if agent
                    (list (cons auth-header (uri->string agent)))
                    '())
                (filter
                 (lambda (h)
                   (not (eq? (car h) auth-header)))
                 raw-headers))))
          (let ((modified-request
                 (build-request
                  (request-uri request)
                  #:method (request-method request)
                  #:headers modified-headers)))
            (let ((port (open-socket-for-uri endpoint)))
              (let ((request-with-port
                     (write-request modified-request port)))
                (when request-body
                  (unless (bytevector? request-body)
                    (set! request-body (string->utf8 request-body)))
                  (write-request-body request-with-port request-body))
                (force-output (request-port request-with-port))
                (let ((response (read-response port)))
                  (let ((response-body
                         (or (response-must-not-include-body? response)
                             (read-response-body response))))
                    (let ((adapted-response
                           (build-response
                            #:code (response-code response)
                            #:reason-phrase (response-reason-phrase response)
                            #:headers
                            (append
                             (if (eqv? (response-code response) 401)
                                 (list (cons 'www-authenticate '((DPoP))))
                                 '())
                             (response-headers response)))))
                      (close-port port)
                      (values adapted-response response-body))))))))))))