summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haunt/ui.scm70
-rw-r--r--haunt/ui/serve.scm47
2 files changed, 89 insertions, 28 deletions
diff --git a/haunt/ui.scm b/haunt/ui.scm
index 910adf9..e53adb8 100644
--- a/haunt/ui.scm
+++ b/haunt/ui.scm
@@ -26,24 +26,28 @@
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
#:use-module (haunt config)
+ #:use-module (haunt site)
#:export (program-name
- haunt-error
show-version-and-exit
+ simple-args-fold
+ %common-options
+ %default-common-options
+ show-common-options-help
+ leave
+ string->number*
+ load-config
option?
haunt-main))
(define commands
- '(serve))
+ '("serve"))
(define program-name (make-parameter 'haunt))
-(define (haunt-error str . args)
- (format (current-error-port) "~a: " (program-name))
- (apply format (current-error-port) str args)
- (newline))
-
(define (show-haunt-help)
(format #t "Usage: haunt COMMAND ARGS...
Run COMMAND with ARGS.~%~%")
@@ -54,20 +58,58 @@ Run COMMAND with ARGS.~%~%")
(format #t "Try `haunt --help' for more information.~%")
(exit 1))
-(define (show-version-and-exit)
- (let ((name (if (eq? (program-name) 'haunt)
- "haunt"
- (format #f "haunt ~a" (program-name)))))
- (format #t "~a ~a
+(define (show-version-and-exit name)
+ (format #t "~a ~a
Copyright (C) 2015 the Haunt authors
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.~%"
- name %haunt-version)))
+ name %haunt-version)
+ (exit 0))
+
+(define (leave format-string . args)
+ "Display error message and exist."
+ (apply format (current-error-port) format-string args)
+ (newline)
+ (exit 1))
+
+(define (string->number* str)
+ "Like `string->number', but error out with an error message on failure."
+ (or (string->number str)
+ (leave "~a: invalid number" str)))
+
+(define (simple-args-fold args options default-options)
+ (args-fold args options
+ (lambda (opt name arg result)
+ (leave "~A: unrecognized option" name))
+ (lambda (arg result)
+ (leave "~A: extraneuous argument" arg))
+ default-options))
+
+(define %common-options
+ (list (option '(#\c "config") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'config arg result)))))
+
+(define %default-common-options
+ '((config . "haunt.scm")))
+
+(define (show-common-options-help)
+ (display "
+ -c, --config configuration file to load"))
(define (option? str)
(string-prefix? "-" str))
+(define* (load-config file-name)
+ "Load configuration from FILE-NAME."
+ (if (file-exists? file-name)
+ (let ((obj (load file-name)))
+ (if (site? obj)
+ obj
+ (leave "configuration object must be a site, got: ~a" obj)))
+ (leave "configuration file found: ~a" file-name)))
+
(define (run-haunt-command command . args)
(let* ((module
(catch 'misc-error
@@ -87,7 +129,7 @@ There is NO WARRANTY, to the extent permitted by law.~%"
((or ("-h") ("--help"))
(show-haunt-help))
(("--version")
- (show-version-and-exit))
+ (show-version-and-exit "haunt"))
(((? option? opt) _ ...)
(format (current-error-port)
"haunt: unrecognized option '~a'~%"
diff --git a/haunt/ui/serve.scm b/haunt/ui/serve.scm
index 078b013..6e58a31 100644
--- a/haunt/ui/serve.scm
+++ b/haunt/ui/serve.scm
@@ -23,29 +23,48 @@
;;; Code:
(define-module (haunt ui serve)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-37)
#:use-module (ice-9 match)
+ #:use-module (ice-9 format)
#:use-module (haunt config)
#:use-module (haunt ui)
#:use-module (haunt serve web-server)
#:export (haunt-serve))
-(define (show-serve-help)
+(define (show-help)
(format #t "Usage: haunt serve [OPTION]
Start an HTTP server for the current site.~%")
(display "
+ -p, --port port to listen on")
+ (newline)
+ (show-common-options-help)
+ (newline)
+ (display "
-h, --help display this help and exit")
+ (display "
+ -V, --version display version and exit")
(newline))
-(define haunt-serve
- (match-lambda*
- (() (serve (haunt-output-directory)))
- ((or ("-h") ("--help"))
- (show-serve-help))
- (("--version")
- (show-version-and-exit))
- (((? option? opt) _ ...)
- (haunt-error "invalid option: ~a" opt)
- (exit 1))
- ((arg _ ...)
- (haunt-error "invalid argument: ~a" arg)
- (exit 1))))
+(define %options
+ (cons* (option '(#\h "help") #f #f
+ (lambda _
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda _
+ (show-version-and-exit "haunt serve")))
+ (option '(#\p "port") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'port (string->number* arg) result)))
+ %common-options))
+
+(define %default-options
+ (cons '((port . 8080))
+ %default-common-options))
+
+(define (haunt-serve . args)
+ (let* ((opts (simple-args-fold args %options %default-options))
+ (port (assoc-ref opts 'port)))
+ (format #t "serving ~a on port ~d~%" (haunt-output-directory) port)
+ (serve (haunt-output-directory))))