path: root/src/guile/cantius.scm

;; SPDX-License-Identifier: CC0-1.0
;;
;; Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>

(define-module (cantius)
  #:use-module ((srfi srfi-26) #:select (cut))
  #:use-module ((srfi srfi-34) #:select (guard raise))
  #:use-module ((srfi srfi-35) #:select (condition &error &message))
  #:use-module ((srfi srfi-128) #:select (make-default-comparator))
  #:use-module ((srfi srfi-146) #:prefix s146:)
  #:use-module ((ice-9 format) #:select (format))
  #:use-module ((ice-9 control) #:select (let/ec))
  #:use-module ((ice-9 exceptions) #:select
                (exception-with-message? exception-message))
  #:use-module ((system repl debug) #:select (terminal-width))
  #:use-module ((web request) #:select (request-uri))
  #:use-module ((web uri) #:prefix uri:)
  #:use-module ((web response) #:select (build-response))
  #:use-module ((fibers web server) #:select (run-server))
  #:use-module ((de-paul-records) #:select
                (define-immutable-record-type* match match-let match-let*)))



(define-public current-path
  (make-parameter #f))

(define-public current-path-string
  (make-parameter #f))

(define-public %resource-root-path
  (make-parameter '()))

(export find-resource-file)
(define* (find-resource-file file #:optional (root-path (%resource-root-path)))
  (let loop ((paths root-path))
    (match paths
      (()
       #f)
      (((= (cut format #f "~a/~a" <> file) file-path)
        . paths-rest)
       (or (and (stat file-path #f) file-path)
           (loop paths-rest))))))



(define-immutable-record-type* endpoint
  (handler #:default (lambda _ (raise (condition (&error)))))
  (redirect/normalize-path? #:default 'true-by-default)
  (redirect/remove-query? #:default 'true-by-default)
  #:export? yes,of-course)

(define-immutable-record-type* endpoint-tree-node
  (direct-match #:default #f)
  (any-match #:default #f)
  (children #:default (s146:mapping (make-default-comparator))))

(define-immutable-record-type* endset
  (endpoints #:default (endpoint-tree-node))
  ;;(resource-root-path #:default '())
  ;;(fallback-handler #:default #f)
  ;;(static-resource-headers #:default #f)
  (redirect/normalize-path? #:default 'true-by-default)
  (redirect/remove-query? #:default 'true-by-default)
  #:export? sure,why-not)

(define (endpoint-tree-+ tree path what)
  (let recurse ((segments path)
                (tree-node tree))
    (define (processed-segments)
      (list-head path (- (length path) (length segments))))

    (match-let ((($* endpoint-tree-node direct-match any-match children)
                 tree-node))
      (when (endset? direct-match)
        (raise (condition
                (&error)
                (&message (message (format #f "Endset already registered for ~s"
                                           (processed-segments)))))))

      (match segments
        (()
         (cond (direct-match
                (raise (condition
                        (&error)
                        (&message (message (format #f "Endpoint already registered for ~s"
                                                   path))))))
               ((and (endset? what) (not (s146:mapping-empty? children)))
                (raise (condition
                        (&error)
                        (&message (message (format #f "Endpoints already registered under ~s"
                                                   path))))))
               (#t
                (endpoint-tree-node
                 #:<- tree-node
                 (direct-match what)))))

        ('any
         (cond (any-match
                (raise (condition
                        (&error)
                        (&message (message (format #f "\"any\" endpoint already registered for ~s"
                                                   path))))))
               ((endset? what)
                (raise (condition
                        (&error)
                        (&message (message (format #f "endset should be registered at normal path, not ~s"
                                                   path))))))
               (#t
                (endpoint-tree-node
                 #:<- tree-node
                 (any-match what)))))

        (((? string? current-segment) . segments-rest)
         (endpoint-tree-node
          #:<- tree-node
          (children (s146:mapping-update/default
                     children current-segment (cut recurse segments-rest <>)
                     %null-endpoint-tree-node))))))))

(define-public (endset-+ endset-obj path what)
  (endset
   #:<- endset-obj
   (endpoints (endpoint-tree-+ (endset-endpoints endset-obj) path what))))

(eval-when (compile load eval)
  (define-immutable-record-type* path-spec
    (path-syntax)
    (extra-handler-args-syntax))

  (define (syntax->path-spec x)
    (let loop ((path-segments '())
               (path-syntax x))
      (syntax-case path-syntax (unquote unquote-splicing)
        (()
         (path-spec (path-syntax #``(#,@(reverse path-segments)))
                    (extra-handler-args-syntax #'())))
        (rest-arg
         (identifier? #'rest-arg)
         (path-spec (path-syntax #``(#,@(reverse path-segments) . any))
                    (extra-handler-args-syntax #'(rest-arg))))
        ((unquote list-expression)
         (path-spec (path-syntax #``(#,@(reverse path-segments)
                                     . ,list-expression))
                    (extra-handler-args-syntax #'())))
        ((segment-arg . rest)
         (identifier? #'segment-arg)
         (raise (condition
                 (&error)
                 (&message (message "Binding identifiers to path segments not yet supported")))))
        (((unquote segment-expression) . rest)
         (loop (cons #',segment-expression path-segments) #'rest))
        (((unquote-splicing segments-expression) . rest)
         (loop (cons #',@segments-expression path-segments) #'rest))
        ((segment . rest)
         (string? (syntax->datum #'segment))
         (loop (cons #'segment path-segments) #'rest))))))

(export define-endpoint)
(define-syntax define-endpoint
  (lambda (x)
    (syntax-case x ()
      ((_ endset-identifier handler-identifier path
          ((init-form ...) ...)
          handler-body handler-body-rest ...)
       (and (identifier? #'webservice-identifier)
            (identifier? #'handler-identifier))
       (match (syntax->path-spec #'path)
         (($* path-spec path-syntax extra-handler-args-syntax)
          #`(begin
              (define (handler-identifier
                       #,(datum->syntax #'handler-identifier 'request)
                       #,(datum->syntax #'handler-identifier 'body)
                       . #,extra-handler-args-syntax)
                handler-body handler-body-rest ...)

              (define endset-identifier
                (endset-+ endset-identifier #,path-syntax
                          (endpoint (init-form ...) ...
                                    (handler handler-identifier)))))))))))

(define-immutable-record-type* endpoint-ref-result
  (path-tail)
  (endpoint))

(define (endpoint-tree-ref tree path)
  (let loop ((segments path)
             (tree-node tree)
             (best-any-match-endpoint #f)
             (best-any-match-path #f))
    (match segments
      (()
       (match tree-node
         (($* endpoint-tree-node (direct-match (? identity endpoint)))
          (endpoint-ref-result (path-tail #f)
                               (endpoint endpoint)))
         ((? (const best-any-match-endpoint))
          (endpoint-ref-result (path-tail best-any-match-path)
                               (endpoint best-any-match-endpoint)))
         (_
          #f)))

      ((current-segment . segments-rest)
       (match-let* (((best-any-match-endpoint best-any-match-path)
                     (or (and=> (endpoint-tree-node-any-match tree-node)
                                (cut list <> segments))
                         (list best-any-match-endpoint best-any-match-path)))
                    (children (endpoint-tree-node-children tree-node))
                    (subnode (s146:mapping-ref/default children current-segment
                                                       #f)))
         (cond (subnode
                (loop segments-rest subnode
                      best-any-match-endpoint best-any-match-path))
               (best-any-match-endpoint
                (endpoint-ref-result (path-tail best-any-match-path)
                                     (endpoint best-any-match-endpoint)))
               (#t
                #f)))))))

(define* (query-endset endset path #:optional (default #f))
  (define (do-it? . args)
    (match args
      ((less-specific 'true-by-default)
       less-specific)
      ((less-specific more-specific)
       more-specific)))

  (let loop ((endset endset)
             (path path)
             (*redirect/normalize-path? 'true-by-default)
             (*redirect/remove-query? 'true-by-default))
    (match-let ((($* endset
                     endpoints
                     (redirect/normalize-path?
                      (= (cut do-it? *redirect/normalize-path? <>)
                         redirect/normalize-path?))
                     (redirect/remove-query?
                      (= (cut do-it? *redirect/remove-query? <>)
                         redirect/remove-query?)))
                 endset))
      (define (update-endpoint base-endpoint)
        (endpoint
         #:<- base-endpoint
         (redirect/normalize-path? #:=> (cut do-it? redirect/normalize-path?
                                             <>))
         (redirect/remove-query? #:=> (cut do-it? redirect/remove-query? <>))))

      (match (endpoint-tree-ref endpoints path)
        (#f
         default)
        (($* endpoint-ref-result path-tail (endpoint (? endset? endset)))
         (loop endset path-tail redirect/normalize-path?
               redirect/remove-query?))
        (ref-result
         (endpoint-ref-result #:<- ref-result
                              (endpoint #:=> update-endpoint)))))))



(define %default-headers
  '((content-type . (text/plain (charset . "utf-8")))))

(export build-response*)
(define* (build-response* #:key (redirect-to #f) (headers %default-headers)
                          (code #f) #:rest args)
  (define code*
    (or code (if redirect-to 301 200)))

  (define redirect-to*
    (if (string? redirect-to)
        (uri:string->uri redirect-to)
        redirect-to))

  (define headers*
    (if redirect-to*
        `((location . ,redirect-to*) . ,headers)
        headers))

  (let loop ((to-filter args)
             (filtered '()))
    (match to-filter
      (()
       (apply build-response #:code code* #:headers headers*
              (reverse filtered)))
      (((? (cut memq <> '(#:code #:headers #:redirect-to))) _ . rest)
       (loop rest filtered))
      ((keyword keyword-arg . rest)
       (loop rest (cons* keyword-arg keyword filtered))))))

(define %catchall-endpoint
  (endpoint (handler (lambda (request body . _)
                       (values (build-response* #:code 404)
                               "There's no page with this address :(")))
            (redirect/normalize-path? #f)
            (redirect/remove-query? #f)))

(define %catchall-ref-result
  (endpoint-ref-result (path-tail #f)
                       (endpoint %catchall-endpoint)))

(define %ugly-uri-path-regex
  (make-regexp ".+/(/|$)"))

(define (exception->msg ex)
  (format #f "~a~%~a~%"
          (if (exception-with-message? ex)
              (format #f "Error: ~a." (exception-message ex))
              "Error occured.")
          ex))

(define (handler request body root-endset)
  (match-let* ((uri (request-uri request))
               (path-string (uri:uri-path uri))
               (path (uri:split-and-decode-uri-path path-string))
               (($* endpoint-ref-result path-tail endpoint)
                (query-endset root-endset path %catchall-ref-result))
               (($* endpoint redirect/normalize-path? redirect/remove-query?)
                endpoint))
    (define (normalized-path-string)
      (format #f "/~a" (uri:encode-and-join-uri-path path)))

    (define (redirect-path)
      (if redirect/normalize-path?
          (normalized-path-string)
          (uri:uri-path (request-uri request))))

    (define (redirect-query)
      (if redirect/remove-query?
          #f
          (uri:uri-query uri)))

    (if (or (and redirect/normalize-path?
                 (regexp-exec %ugly-uri-path-regex path-string))
            (and redirect/remove-query?
                 (uri:uri-query uri)))
        (values (build-response* #:redirect-to (uri:build-relative-ref
                                                #:path (redirect-path)
                                                #:query (redirect-query)))
                "Redirect...")
        (let/ec escape
          (with-exception-handler
              (lambda (ex)
                (define msg
                  (exception->msg ex))

                (display msg (current-error-port))

                (escape (build-response* #:code 500)
                        (string-append
                         msg
                         "\nBacktrace:\n\n"
                         (call-with-output-string
                           (lambda (port)
                             (terminal-width 80)
                             (display-backtrace (make-stack #t 5 0) port))))))
            (lambda ()
              (parameterize ((current-path path)
                             (current-path-string path-string))
                (start-stack 'cantius-request
                  (apply (endpoint-handler endpoint) request body
                         (or (and=> path-tail list) '()))))))))))

(define-public (run-cantius endset . server-args)
  (apply run-server (cut handler <> <> endset) server-args))