;; 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 .
(define-module (webid-oidc server endpoint reverse-proxy)
#:use-module (webid-oidc errors)
#: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 (webid-oidc offloading)
#: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 (rnrs bytevectors)
#:use-module (oop goops)
#:duplicates (merge-generics)
#:declarative? #t
#:export
(
backend-uri
authentication-header
open-socket-for-uri
))
(define open-socket-for-uri
(make-parameter
(@ (web client) open-socket-for-uri)))
(define-class ()
(backend-uri #:init-keyword #:backend-uri #:getter backend-uri)
(authentication-header
#:init-keyword #:authentication-header
#:getter authentication-header
#:init-value 'XXX-Agent))
(define-method (initialize (endpoint ) initargs)
(next-method)
(let-keywords
initargs #t
((backend-uri #f)
(authentication-header 'XXX-Agent))
(match backend-uri
((? string? (= string->uri (? uri? the-backend-uri)))
(set! backend-uri the-backend-uri)
(slot-set! endpoint 'backend-uri the-backend-uri))
(else #t))
(unless (and backend-uri (uri? backend-uri))
(scm-error 'wrong-type-arg "make "
(G_ "#:backend-uri should be an URI")
'()
(list backend-uri)))
(unless (symbol? authentication-header)
(scm-error 'wrong-type-arg "make "
(G_ "#:authentication-header should be a symbol")
'()
(list authentication-header)))))
(define-method (handle (endpoint ) request request-body)
(let ((modified-request
(build-request
(request-uri request)
#:method (request-method request)
#:headers
`(,@(let ((user (assq-ref (request-meta request) 'user)))
(if user
`((,(authentication-header endpoint) . ,(uri->string user)))
'()))
,@(filter
(match-lambda
((header . _)
(not (string-ci=?
(symbol->string header)
(symbol->string (authentication-header endpoint))))))
(request-headers request))))))
(in-another-thread
(let/ec return
(with-exception-handler
(lambda (exn)
(if (exception-with-message? exn)
(format (current-error-port)
(G_ "~a: reverse proxy failure: ~a\n")
(date->string ((p:current-date)))
(exception-message exn))
(format (current-error-port)
(G_ "~a: reverse proxy failure\n")
(date->string ((p:current-date)))))
(return
(build-response
#:code 502
#:reason-phrase (W_ "reason-phrase|Bad Gateway")
#:headers '((content-type application/xhtml+xml)))
(call-with-output-string
(cute 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|Bad Gateway")))
(body
(p ,(W_ "The backend server could not be contacted.")))))
<>))
'()))
(lambda ()
(let ((port ((open-socket-for-uri) (backend-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 ((body (and (not (response-must-not-include-body? response))
port)))
(values response body '())))))))))))