;; 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)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc provider-confirmation)
  #: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 (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
  (
   <endpoint>
   host
   path
   relevant?

   <router>
   routed

   handle
   ))

(define-class <endpoint> ()
  (host #:init-keyword #:host #:getter host #:init-value #f)
  (path #:init-keyword #:path #:getter path  #:init-value "/"))

(define-method (initialize (endpoint <endpoint>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((host #f)
    (path "/"))
   (unless (or (not host) (string? host))
     (scm-error 'wrong-type-arg "make <endpoint>"
                (G_ "#:host should be a string or #f")
                '()
                (list host)))
   (unless (and (string? path) (string-prefix? "/" path))
     (scm-error 'wrong-type-arg "make <endpoint>"
                (G_ "#:path should be an absolute path")
                '()
                (list path)))))

(define-class <router> (<endpoint>)
  (routed #:init-keyword #:routed #:getter routed #:init-value '()))

(define-method (initialize (endpoint <router>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((routed '()))
   (let check-routed ((routed routed)
                      (i 0))
     (match routed
       (() #t)
       (((? (cute is-a? <> <endpoint>)) routed ...)
        (check-routed routed (+ i 1)))
       ((not-an-endpoint _ ...)
        (scm-error 'wrong-type-arg "make <router>"
                   (format #f (G_ "#:routed element ~a should be an endpoint") i)
                   '()
                   (list not-an-endpoint)))
       (else
        (scm-error 'wrong-type-arg "make <router>"
                   (G_ "#:routed should be a list of endpoints")
                   '()
                   (list routed)))))))

(define-method (relevant? (endpoint <endpoint>) request)
  (let ((requested-host
         (match (request-host request)
           ((or ((? string? host) . _)
                (? string? host))
            host)
           (else #f)))
        (requested-path
         (split-and-decode-uri-path
          (uri-path (request-uri request)))))
    (and (or (not (host endpoint))
             (equal? (host endpoint) requested-host))
         (let check-path ((path (split-and-decode-uri-path (path endpoint)))
                          (requested-path requested-path))
           (match `(,path ,requested-path)
             ((() _) #t)
             ((_ ()) #f)
             (((element path ...)
               (requested-element requested-path ...))
              (and (equal? element requested-element)
                   (check-path path requested-path))))))))

(define-method (handle (endpoint <router>) request request-body)
  (let find-router ((routed (routed endpoint)))
    (match routed
      (()
       (values
        (build-response
         #:code 404
         #:reason-phrase (W_ "Not Found"))
        #f
        '()))
      (((and router
             (? (cute relevant? <> request)))
        _ ...)
       (handle router request request-body))
      ((_ routed ...)
       (find-router routed)))))