path: root/app.scm

(import (chicken base)
	utf8
	spiffy
	nrepl
	srfi-18
	(chicken file)
	(chicken io)
	(chicken port)
	(chicken format)
	(chicken pretty-print)
	(chicken string)
	lowdown
	sxml-transforms
	matchable
	(chicken irregex)
	srfi-13
	intarweb
	uri-common
	(chicken process)
	(chicken process-context)
	(chicken condition)
	trace)

(define *PORT* (get-environment-variable "PORT"))
(define *WEBROOT* (or (get-environment-variable "WEBROOT")
		      "dist"))
(define *SRCROOT* (or (get-environment-variable "SRCROOT")
		      "pages"))
(define *TEMPLATE* (or (get-environment-variable "TEMPLATE")
		       "template.html"))
(define *NREPL-PORT* (string->number (or (get-environment-variable "NREPL_PORT")
					 "1234")))

(define (pipe x . fns)
  (match fns
    [() x]
    [(fn . rest) (apply pipe (fn x) rest)]))

;; Convenience macro (@ expr ...) that expands to (lambda (x) (expr ... x))
(define-syntax @
  (syntax-rules ()
    ((_ expr ...)
     (lambda (x) (expr ... x)))))

(define-syntax thunk
  (syntax-rules ()
    ((_ expr ...)
     (lambda () (expr ...)))))

(define (replace from to str)
  (irregex-replace/all from str to))

(define (html-unescape html)
  (pipe html
	(@ replace """ "\"")
	(@ replace "'" "'")
	(@ replace "&" "&")
	(@ replace "&lt;" "<")
	(@ replace "&gt;" ">")))

(define (highlight ext code)
  (define tmp-file-path (create-temporary-file ext))
  (with-output-to-file tmp-file-path
    (lambda () (display code)))
  (define result
    (receive (input _ _) (process (format "highlight ~A -O html -f" tmp-file-path))
      (read-string #f input)))
  (define result (capture ,(format "highlight ~A -O html -f" tmp-file-path)))
  (delete-file tmp-file-path)
  result)

(define (replace-code-block content return)
  (define irx (irregex "^%lang (\\S+)%\\n?" 's))
  (define lang-match
    (irregex-search irx content))
  (if (not lang-match)
      (return content))

  (define lang
    (irregex-match-substring lang-match 1))

  (pipe content
	(@ replace irx "")
	(@ html-unescape)
	(@ highlight lang)
	(@ string-trim-both)))

(define (try-with-backoff thunk
			  #!optional (backoffs (list 10 50 150 500)))
  (define (inner boffs return)
    (call/cc
     (lambda (k)
       (with-exception-handler (lambda (exn) (k exn))
	 (lambda () (return (thunk))))))

    (if (null? boffs) (return #f))
    (thread-sleep! (/ (car boffs) 1000.0))
    (inner (cdr boffs) return))

  (call/cc (lambda (k) (inner backoffs k))))

(define (convert-md-to-html filepath)
  (define (read-md)
    (define result (read-string #f (open-input-file filepath)))
    (if (eq? #!eof result)
	(error 'eof "md file is empty"))
    result)

  (define md (try-with-backoff read-md))

  (if (string? md)
      (with-output-to-string
	(lambda () (markdown->html (open-input-string md))))

      ;; else
      (begin (print "warning: md file " filepath " seems to be empty!")
	     "")))

(define (highlight-code-blocks html)
  (define (highlight-match m)
    (format "<code>~A</code>"
	    (call/cc (@ replace-code-block (irregex-match-substring m 1)))))

  (irregex-replace/all (irregex "<code>(.*?)</code>" 's) html
		       highlight-match))

(define (insert-to-page-tmpl tmpl-path html)
  (define tmpl-port (open-input-file tmpl-path))
  (define tmpl-string (read-string #f tmpl-port))
  (format tmpl-string html))

(define (system-has-fswatch?)
  (call/cc (lambda (k)
	     (with-exception-handler
		 (lambda (exn) (k #f))
	       (lambda () (system* "which fswatch") (k #t))))))

(define (system-has-inotifywait?)
  (call/cc (lambda (k)
	     (with-exception-handler
		 (lambda (exn) (k #f))
	       (lambda () (system* "which inotifywait") (k #t))))))

(define (compile-file-into outdir)
  (lambda (filepath prev-result)
    (define (inner return)
      (define initial-srcroot (string-append "^" *SRCROOT*))
      (define replaced-filepath (replace initial-srcroot outdir filepath))

      (if (directory-exists? filepath)
	  (begin
	    (print (format "Creating corresponding directory: ~A" filepath))
	    (create-directory replaced-filepath #t)
	    (return (void))))

      (if (not (irregex-search "\\.md$" filepath))
	  (begin
	    (print (format "Copying non-md file: ~A" filepath))
	    (copy-file filepath replaced-filepath)
	    (return (void))))

      (print (format "Compiling markdown: ~A" filepath))
      (define out-path (pipe filepath
			     (@ replace "\\.md" ".html")
			     (@ replace initial-srcroot outdir)))

      (define out-content (pipe filepath
				(@ convert-md-to-html)
				(@ highlight-code-blocks)
				(@ insert-to-page-tmpl *TEMPLATE*)))

      (with-output-to-file out-path
	(thunk display out-content)))

    (call/cc inner)))

(define (recompile)
  (define tmpdir (create-temporary-directory))

  (find-files *SRCROOT*
	      action: (compile-file-into tmpdir))

  (system* (format "rm -r \"~A\" || true" *WEBROOT*))
  (system* (format "mv \"~A\" \"~A\"" tmpdir *WEBROOT*)))

(define (wait-for-filesystem-change stop-watching)
  (cond ((system-has-fswatch?)      (process (format "fswatch -r -L -1 ~A" *SRCROOT*)))
	((system-has-inotifywait?)  (process (format "inotifywait -r -q -e create -e modify -e delete -e move ~A" *SRCROOT*)))
	(else                       (begin (print "No file watching system installed")
					   (stop-watching (void))))))

(define (watch-print . rest) (apply print "[watch] " rest))
(thread-start!
 (lambda ()
   (watch-print "Starting watching source directory...")

   (call/cc
    (lambda (stop-watching)
      (let loop ()
	(watch-print "Calling file watching system...")
	(receive (input _ _) (wait-for-filesystem-change stop-watching)
	  (watch-print "Waiting for filesystem changes...")
	  (watch-print (format "Monitored directory has changed (output: ~A)" (read-line input)))
	  (recompile)
	  (loop)))))

   (watch-print "Stopped watching source directory.")))

(define (nrepl-print . rest) (apply print "[nrepl] " rest))
(thread-start!
 (lambda ()
   (nrepl-print (format "Starting nrepl on port ~A" *NREPL-PORT*))
   (nrepl-prompt (lambda () (display "#;0> ")))
   (nrepl *NREPL-PORT*)))

(recompile)

(define (map-last proc lst)
  (if (null? (cdr lst))
      (list (proc (car lst)))
      (cons (car lst) (map-last proc (cdr lst)))))

(define (app cont)
  (define uri (request-uri (current-request)))
  (define path (uri-path uri))

  (define (append-html-if-needed fragment)
    (define has-ext? (@ irregex-search "\\.\\S+$"))
    (match fragment
      ["" "index.html"]
      ;; if path ends in an extension, do nothing
      [(? has-ext?) fragment]
      ;; otherwise, add .html
      [_ (string-append fragment ".html")]))

  (define (string-intercalate delim lst)
    (string-intersperse lst delim))

  (define static-file-path (pipe path
				 (@ map-last append-html-if-needed)
				 (@ cdr)
				 (@ string-intercalate "/")))

  (print (format "Serving file ~A" static-file-path))
  (send-static-file static-file-path))

(if *PORT*
    (begin (print (format "Serving ~A on port ~A, using ~A as html template" *WEBROOT* *PORT* *TEMPLATE*))
	   (server-port (string->number *PORT*))
	   (root-path *WEBROOT*)
	   (vhost-map `((".*" . ,(@ app))))
	   (start-server))
    (begin (print "PORT not defined, not starting HTTP server. Putting main thread to sleep.")
	   (let loop ()
	     (thread-sleep! 1)
	     (loop))))