ui: serve: Fix deprecation warning.
[haunt.git] / haunt / ui / serve.scm
CommitLineData
f299cca7
DT
1;;; Haunt --- Static site generator for GNU Guile
2;;; Copyright © 2015 David Thompson <davet@gnu.org>
3;;;
4;;; This file is part of Haunt.
5;;;
6;;; Haunt is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or
9;;; (at your option) any later version.
10;;;
11;;; Haunt is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14;;; General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with Haunt. If not, see <http://www.gnu.org/licenses/>.
18
19;;; Commentary:
20;;
21;; Haunt serve sub-command.
22;;
23;;; Code:
24
25(define-module (haunt ui serve)
3320a67e
DT
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-37)
f299cca7 28 #:use-module (ice-9 match)
3320a67e 29 #:use-module (ice-9 format)
5ed2006c 30 #:use-module (ice-9 ftw)
be68ae74 31 #:use-module (ice-9 threads)
46d38aab 32 #:use-module (haunt site)
f299cca7
DT
33 #:use-module (haunt config)
34 #:use-module (haunt ui)
35 #:use-module (haunt serve web-server)
36 #:export (haunt-serve))
37
3320a67e 38(define (show-help)
f299cca7
DT
39 (format #t "Usage: haunt serve [OPTION]
40Start an HTTP server for the current site.~%")
41 (display "
3320a67e 42 -p, --port port to listen on")
5ed2006c
DT
43 (display "
44 -w, --watch rebuild site when files change")
3320a67e
DT
45 (newline)
46 (show-common-options-help)
47 (newline)
48 (display "
f299cca7 49 -h, --help display this help and exit")
3320a67e
DT
50 (display "
51 -V, --version display version and exit")
f299cca7
DT
52 (newline))
53
3320a67e
DT
54(define %options
55 (cons* (option '(#\h "help") #f #f
56 (lambda _
57 (show-help)
58 (exit 0)))
59 (option '(#\V "version") #f #f
60 (lambda _
61 (show-version-and-exit "haunt serve")))
62 (option '(#\p "port") #t #f
63 (lambda (opt name arg result)
64 (alist-cons 'port (string->number* arg) result)))
5ed2006c
DT
65 (option '(#\w "watch") #f #f
66 (lambda (opt name arg result)
67 (alist-cons 'watch? #t result)))
3320a67e
DT
68 %common-options))
69
70(define %default-options
46d38aab 71 (cons '(port . 8080)
3320a67e
DT
72 %default-common-options))
73
0d67128c
DT
74(define (call-with-error-handling thunk)
75 (catch #t
76 thunk
77 (lambda (key . args)
78 (let ((cep (current-error-port))
79 (stack (make-stack #t 1)))
80 (display "ERROR: site rebuild failed\n\n" cep)
81 (display "Backtrace:\n" cep)
82 (display-backtrace stack cep)
83 (newline cep)
84 (apply display-error (stack-ref stack 0) cep args)
85 (newline cep)))))
86
5ed2006c 87;; XXX: Make this less naive.
884ab202 88(define (watch config-file check-dir? check-file?)
5ed2006c 89 "Watch the current working directory for changes to any of its files
884ab202
DT
90that match CHECK-FILE? and any subdirectories that match CHECK-DIR?.
91When a file has been changed, reload CONFIG-FILE and rebuild the
92site."
93
94 (define cwd (getcwd))
95
5ed2006c
DT
96 (define (any-files-changed? time)
97 (define (enter? name stat result)
884ab202
DT
98 ;; Don't bother descending if we already know that a file has
99 ;; changed.
100 (and (not result) (check-dir? name)))
5ed2006c
DT
101
102 (define (leaf name stat result)
103 ;; Test if file has been modified since the last time we
104 ;; checked.
884ab202
DT
105 (or result
106 (and (check-file? name)
107 (or (>= (stat:mtime stat) time)
108 (>= (stat:ctime stat) time)))))
5ed2006c
DT
109
110 (define (no-op name stat result) result)
111
884ab202 112 (file-system-fold enter? leaf no-op no-op no-op no-op #f cwd))
5ed2006c
DT
113
114 (let loop ((time (current-time)))
5ed2006c
DT
115 (when (any-files-changed? time)
116 (display "rebuilding...\n")
0d67128c
DT
117 (call-with-error-handling
118 (lambda ()
119 (build-site (load-config config-file)))))
884ab202
DT
120 (let ((next-time (current-time)))
121 (sleep 1)
122 (loop next-time))))
5ed2006c 123
3320a67e 124(define (haunt-serve . args)
5ed2006c
DT
125 (let* ((opts (simple-args-fold args %options %default-options))
126 (port (assq-ref opts 'port))
127 (watch? (assq-ref opts 'watch?))
128 (config (assq-ref opts 'config))
129 (site (load-config config))
46d38aab
DT
130 (doc-root (site-build-directory site)))
131 (format #t "serving ~a on port ~d~%" doc-root port)
5ed2006c
DT
132
133 (when watch?
134 (call-with-new-thread
135 (lambda ()
884ab202
DT
136 (watch config
137 (let ((cwd (getcwd))
138 (build-dir (site-build-directory site)))
139 (lambda (dir)
140 (not
141 (string-prefix? (string-append cwd "/" build-dir) dir))))
142 (site-file-filter site)))))
5ed2006c 143
829ee49c 144 (serve doc-root #:open-params `(#:port ,port))))