diff options
| -rw-r--r-- | haunt/ui.scm | 70 | ||||
| -rw-r--r-- | haunt/ui/serve.scm | 47 |
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)))) |