#lang racket/base

;; Resources are referrable & renderable objects, (most are html pages)

;; (resource path renderer referrer) creates and returns a new "resource"
;; value.  The arguments are:
;; - `path': the path of the output file, relative to the working directory,
;;   indicating where the resource file should be put at, also corresponding to
;;   the URL it will be found at.  It must be a `/'-separated relative string,
;;   no `..', `.', or `//', and it can end in `/' (which will turn to
;;   "index.html").
;; - `renderer': a unary function that renders the resource, receiving the path
;;   for the file to be created as an argument.  This path will be different
;;   than the `path' argument because this function is invoked in the target
;;   directory.
;; - `referrer': a function accepting one or more arguments (and possibly
;;   keywords) that produces a value to be used to refer to this resource
;;   (using `a', `img', etc).  The first value that will be passed to this
;;   function will be the actual URL path, which depends on the currently
;;   rendered page path -- the argument will be relative to it.
;; The resulting resource value is actually a rendering function that is
;; similar to the `referrer', except without the first URL argument -- when it
;; is called, it invokes the `referrer' function with the actual (relativized)
;; URL.  Creating a resource registers the `renderer' to be executed when
;; rendering is initiated.  Note that more resources can be created while
;; rendering; they will also be rendered in turn until no more resources are
;; created.

(require scribble/text)

;; default file, urls to it will point to its directory instead, and a
;; /-suffixed path will render to this file
(define default-file "index.html")

;; the currently rendered directory, as a list
(define rendered-dirpath (make-parameter '()))

;; A mapping from path prefixes to urls (actually, any string) -- when two
;; paths are in the same prefix, links from one to the other are relative, but
;; if they're in different prefixes, the url will be used instead; the roots
;; are expected to be disjoint (= no "/foo" and "/foo/bar" roots).
;; Additionally, optional symbol flags can appear in each entry, currently only
;; 'abs is used below for roots that should always use absolute links (needed
;; for some skeleton pages that are used in nested subdirectories).
(provide url-roots)
(define url-roots (make-parameter #f))

(define cached-roots '(#f . #f))
(define (current-url-roots)
  ;; takes `url-roots', a (listof (list prefix-string url-string . flags)), and
  ;; produces an alist with lists of strings for the keys; the prefix-strings
  ;; are split on "/"s, and the url-strings can be anything at all actually
  ;; (they are put as-is before the path with a "/" between them).
  (let ([roots (url-roots)])
    (unless (eq? roots (car cached-roots))
      (set! cached-roots
            (cons roots
                  (and (list? roots) (pair? roots)
                       (map (lambda (root)
                              (list* (regexp-match* #rx"[^/]+" (car root))
                                     (regexp-replace #rx"/$" (cadr root) "")
                                     (cddr root)))
                            roots)))))
    (cdr cached-roots)))

;; a utility for relative paths, taking the above `default-file' and
;; `url-roots' into consideration.
(define (relativize file tgtdir curdir)
  (define file* (if (equal? file default-file) "" file))
  (define roots (current-url-roots))
  (define (find-root path mode)
    (ormap (lambda (root+url+flags)
             (let loop ([r (car root+url+flags)] [p path])
               (if (pair? r)
                 (and (pair? p) (equal? (car p) (car r))
                      (loop (cdr r) (cdr p)))
                 (case mode
                   [(get-path) `(,(cadr root+url+flags) ,@p ,file*)]
                   [(get-abs-or-true)
                    (if (memq 'abs (cddr root+url+flags)) `("" ,@p) #t)]
                   [else (error 'relativize "internal error: ~e" mode)]))))
           roots))
  (define result
    (let loop ([t tgtdir] [c curdir] [pfx '()])
      (cond
        ;; find shared prefix
        [(and (pair? t) (pair? c) (equal? (car t) (car c)))
         (loop (cdr t) (cdr c) (cons (car t) pfx))]
        ;; done with the shared prefix, deal with the root now
        ;; no roots => always use a relative path (useful for debugging)
        [(not roots) `(,@(map (lambda (_) "..") c) ,@t ,file*)]
        ;; share a root => use a relative path unless its an absolute root
        [(find-root (reverse pfx) 'get-abs-or-true)
         => (lambda (abs/true)
              `(;; rel. => as above
                ,@(if (list? abs/true) abs/true (map (lambda (_) "..") c))
                ,@t ,file*))]
        ;; different roots => use the one for the target
        [(find-root tgtdir 'get-path)]
        ;; if there isn't any, throw an error
        [else (error 'relativize "target url is not in any known root: ~a"
                     (string-join `(,@tgtdir ,file*) "/"))])))
  (if (equal? '("") result) "." (string-join result "/")))
#| tests
(require tests/eli-tester)
(define R relativize)
(let ()
  (test do (test (R "bleh.txt"   '()        '()       ) => "bleh.txt"
                 (R "bleh.txt"   '("x")     '()       ) => "x/bleh.txt"
                 (R "bleh.txt"   '("x" "y") '()       ) => "x/y/bleh.txt"
                 (R "bleh.txt"   '()        '("x")    ) => "../bleh.txt"
                 (R "bleh.txt"   '("x")     '("x")    ) => "bleh.txt"
                 (R "bleh.txt"   '("x" "y") '("x")    ) => "y/bleh.txt"
                 (R "bleh.txt"   '()        '("x" "y")) => "../../bleh.txt"
                 (R "bleh.txt"   '("x")     '("x" "y")) => "../bleh.txt"
                 (R "bleh.txt"   '("x" "y") '("x" "y")) => "bleh.txt"
                 (R "bleh.txt"   '("x" "y") '("y" "x")) => "../../x/y/bleh.txt"
                 (R "index.html" '()        '()       ) => "."
                 (R "index.html" '("x")     '()       ) => "x/"
                 (R "index.html" '("x" "y") '()       ) => "x/y/"
                 (R "index.html" '()        '("x")    ) => "../"
                 (R "index.html" '("x")     '("x")    ) => "."
                 (R "index.html" '("x" "y") '("x")    ) => "y/"
                 (R "index.html" '()        '("x" "y")) => "../../"
                 (R "index.html" '("x")     '("x" "y")) => "../"
                 (R "index.html" '("x" "y") '("x" "y")) => "."
                 (R "index.html" '("x" "y") '("y" "x")) => "../../x/y/")
        do (parameterize ([url-roots '(["/x" "/X/"] ["/y" "/Y/"])])
             (test (R "bleh.txt"   '()        '()       ) =error> "not in any"
                   (R "bleh.txt"   '("x")     '()       ) => "/X/bleh.txt"
                   (R "bleh.txt"   '("x" "y") '()       ) => "/X/y/bleh.txt"
                   (R "bleh.txt"   '()        '("x")    ) =error> "not in any"
                   (R "bleh.txt"   '("x")     '("x")    ) => "bleh.txt"
                   (R "bleh.txt"   '("x" "y") '("x")    ) => "y/bleh.txt"
                   (R "bleh.txt"   '()        '("x" "y")) =error> "not in any"
                   (R "bleh.txt"   '("x")     '("x" "y")) => "../bleh.txt"
                   (R "bleh.txt"   '("x" "y") '("x" "y")) => "bleh.txt"
                   (R "bleh.txt"   '("x" "y") '("y" "x")) => "/X/y/bleh.txt"
                   (R "index.html" '()        '()       ) =error> "not in any"
                   (R "index.html" '("x")     '()       ) => "/X/"
                   (R "index.html" '("x" "y") '()       ) => "/X/y/"
                   (R "index.html" '()        '("x")    ) =error> "not in any"
                   (R "index.html" '("x")     '("x")    ) => "."
                   (R "index.html" '("x" "y") '("x")    ) => "y/"
                   (R "index.html" '()        '("x" "y")) =error> "not in any"
                   (R "index.html" '("x")     '("x" "y")) => "../"
                   (R "index.html" '("x" "y") '("x" "y")) => "."
                   (R "index.html" '("x" "y") '("y" "x")) => "/X/y/"))
        do (parameterize ([url-roots '(["/x" "/X/"] ["/y" "/Y/" abs])])
             (test (R "foo.txt" '("x" "1") '("x" "2")) => "../1/foo.txt"
                   (R "foo.txt" '("y" "1") '("y" "2")) => "/1/foo.txt"))))
|#

;; utility for keeping a list of renderer thunks
(define-values [add-renderer get/reset-renderers]
  (let ([l '()] [s (make-semaphore 1)])
    ;; map paths to #t -- used to avoid overwriting files
    (define t (make-hash))
    (define-syntax-rule (S body) (call-with-semaphore s (lambda () body)))
    (values (lambda (path renderer)
              (S (if (hash-ref t path #f)
                   (error 'resource "path used for two resources: ~e" path)
                   (begin (hash-set! t path #t) (set! l (cons renderer l))))))
            (lambda () (S (begin0 (reverse l) (set! l '())))))))

;; `#:exists' determines what happens when the render destination exists, it
;; can be one of: #f (do nothing), 'delete-file (delete if a file exists, error
;; if exists as a directory)
(provide resource)
(define (resource path renderer referrer #:exists [exists 'delete-file])
  (define (bad reason) (error 'resource "bad path, ~a: ~e" reason path))
  (unless (string? path) (bad "must be a string"))
  (for ([x (in-list '([#rx"^/" "must be relative"]
                      [#rx"//" "must not have empty elements"]
                      [#rx"(?:^|/)[.][.]?(?:/|$)"
                          "must not contain `.' or `..'"]))])
    (when (regexp-match? (car x) path) (bad (cadr x))))
  (let ([path (regexp-replace #rx"(?<=^|/)$" path default-file)])
    (define-values (dirpathlist filename)
      (let-values ([(l r) (split-at-right (regexp-split #rx"/" path) 1)])
        (values l (car r))))
    (define (render)
      (let loop ([ps dirpathlist])
        (if (pair? ps)
          (begin (unless (directory-exists? (car ps))
                   (if (or (file-exists? (car ps)) (link-exists? (car ps)))
                     (bad "exists as a file/link")
                     (make-directory (car ps))))
                 (parameterize ([current-directory (car ps)])
                   (loop (cdr ps))))
          (begin (cond [(not exists)] ; do nothing
                       [(or (file-exists? filename) (link-exists? filename))
                        (delete-file filename)]
                       [(directory-exists? filename)
                        (bad "exists as directory")])
                 (parameterize ([rendered-dirpath dirpathlist])
                   (printf "  ~a\n" path)
                   (renderer filename))))))
    (define (url) (relativize filename dirpathlist (rendered-dirpath)))
    (define absolute-url
      (delay (let ([url (relativize filename dirpathlist '())])
               (if (url-roots)
                 url
                 ;; we're in local build mode, and insist on an absolute url,
                 ;; so construct a `file://' result
                 (list* "file://" (current-directory) url)))))
    (add-renderer path render)
    (make-keyword-procedure
     (lambda (kws kvs . args) (keyword-apply referrer kws kvs (url) args))
     (case-lambda [(x) (if (and (pair? x) (eq? (car x) get-path))
                         (if (cdr x) absolute-url (url))
                         (referrer (url) x))]
                  [args (apply referrer (url) args)]))))

;; make it possible to always get the path to a resource
(provide get-resource-path)
(define get-path (gensym))
(define (get-resource-path resource [absolute? #f])
  (resource (cons get-path absolute?)))

;; a convenient utility to create renderers from some output function (like
;; `output-xml' or `display') and some content
(provide file-writer)
(define ((file-writer writer content) file)
  (call-with-output-file file (lambda (o) (writer content o))))

;; runs all renderers, and any renderers that might have been added on the way
(provide render-all)
(define (render-all)
  (printf "Rendering...\n")
  (define todo (get/reset-renderers))
  (if (null? todo)
    (printf "  Warning: no content to render\n")
    (let loop ([todo todo])
      (unless (null? todo)
        (for-each (lambda (r) (r)) todo)
        (loop (get/reset-renderers))))) ; if more were created
  (printf "Rendering done.\n"))
