Add serve command.

* haunt/config.scm: New file.
* haunt/serve/mime-types.scm: New file.
* haunt/serve/web-server.scm: New file.
* haunt/ui/serve.scm: New file.
* haunt/ui.scm (commands, program-name): New variables.
  (show-haunt-help): Display possible commands.
  (run-haunt-command): New procedure.
  (haunt-main): Run subcommands.
* Makefile.am (SOURCES): Add files.

Makefile.am

@@ -40,6 +40,10 @@ moddir=$(prefix)/share/guile/site/2.0
 godir=$(libdir)/guile/2.0/ccache
 
 SOURCES =					\
-  haunt/ui.scm
+  haunt/config.scm				\
+  haunt/ui.scm					\
+  haunt/ui/serve.scm				\
+  haunt/serve/mime-types.scm			\
+  haunt/serve/web-server.scm
 
 EXTRA_DIST += pre-inst-env.in

haunt/config.scm

@@ -0,0 +1,39 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of Haunt.
+;;;
+;;; Haunt is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Haunt is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Haunt.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Haunt configuration.
+;;
+;;; Code:
+
+(define-module (haunt config)
+  #:export (%haunt-cwd
+            haunt-file-name
+            haunt-output-directory))
+
+(define %haunt-cwd (getcwd))
+
+(define (haunt-file-name rel)
+  "Return an absolute file name to the file REL in the haunt current
+working directory."
+  (string-append %haunt-cwd "/" rel))
+
+(define (haunt-output-directory)
+  "Return the current haunt compiled page output directory."
+  (haunt-file-name "output"))

haunt/serve/mime-types.scm

@@ -0,0 +1,556 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of Haunt.
+;;;
+;;; Haunt is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Haunt is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Haunt.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Simple MIME type guesser.
+;;
+;;; Code:
+
+(define-module (haunt serve mime-types)
+  #:use-module (ice-9 hash-table)
+  #:use-module (ice-9 regex)
+  #:export (mime-type))
+
+(define %mime-types
+  (alist->hash-table
+   '(("ez" . application/andrew-inset)
+     ("anx" . application/annodex)
+     ("atom" . application/atom+xml)
+     ("atomcat" . application/atomcat+xml)
+     ("atomsrv" . application/atomserv+xml)
+     ("lin" . application/bbolin)
+     ("cap" . application/cap)
+     ("pcap" . application/cap)
+     ("cu" . application/cu-seeme)
+     ("davmount" . application/davmount+xml)
+     ("tsp" . application/dsptype)
+     ("es" . application/ecmascript)
+     ("spl" . application/futuresplash)
+     ("hta" . application/hta)
+     ("jar" . application/java-archive)
+     ("ser" . application/java-serialized-object)
+     ("class" . application/java-vm)
+     ("js" . application/javascript)
+     ("m3g" . application/m3g)
+     ("hqx" . application/mac-binhex40)
+     ("cpt" . application/mac-compactpro)
+     ("nb" . application/mathematica)
+     ("nbp" . application/mathematica)
+     ("mdb" . application/msaccess)
+     ("doc" . application/msword)
+     ("dot" . application/msword)
+     ("mxf" . application/mxf)
+     ("bin" . application/octet-stream)
+     ("oda" . application/oda)
+     ("ogx" . application/ogg)
+     ("pdf" . application/pdf)
+     ("key" . application/pgp-keys)
+     ("pgp" . application/pgp-signature)
+     ("prf" . application/pics-rules)
+     ("ps" . application/postscript)
+     ("ai" . application/postscript)
+     ("eps" . application/postscript)
+     ("epsi" . application/postscript)
+     ("epsf" . application/postscript)
+     ("eps2" . application/postscript)
+     ("eps3" . application/postscript)
+     ("rar" . application/rar)
+     ("rdf" . application/rdf+xml)
+     ("rss" . application/rss+xml)
+     ("rtf" . application/rtf)
+     ("smi" . application/smil)
+     ("smil" . application/smil)
+     ("xhtml" . application/xhtml+xml)
+     ("xht" . application/xhtml+xml)
+     ("xml" . application/xml)
+     ("xsl" . application/xml)
+     ("xsd" . application/xml)
+     ("xspf" . application/xspf+xml)
+     ("zip" . application/zip)
+     ("apk" . application/vnd.android.package-archive)
+     ("cdy" . application/vnd.cinderella)
+     ("kml" . application/vnd.google-earth.kml+xml)
+     ("kmz" . application/vnd.google-earth.kmz)
+     ("xul" . application/vnd.mozilla.xul+xml)
+     ("xls" . application/vnd.ms-excel)
+     ("xlb" . application/vnd.ms-excel)
+     ("xlt" . application/vnd.ms-excel)
+     ("cat" . application/vnd.ms-pki.seccat)
+     ("stl" . application/vnd.ms-pki.stl)
+     ("ppt" . application/vnd.ms-powerpoint)
+     ("pps" . application/vnd.ms-powerpoint)
+     ("odc" . application/vnd.oasis.opendocument.chart)
+     ("odb" . application/vnd.oasis.opendocument.database)
+     ("odf" . application/vnd.oasis.opendocument.formula)
+     ("odg" . application/vnd.oasis.opendocument.graphics)
+     ("otg" . application/vnd.oasis.opendocument.graphics-template)
+     ("odi" . application/vnd.oasis.opendocument.image)
+     ("odp" . application/vnd.oasis.opendocument.presentation)
+     ("otp" . application/vnd.oasis.opendocument.presentation-template)
+     ("ods" . application/vnd.oasis.opendocument.spreadsheet)
+     ("ots" . application/vnd.oasis.opendocument.spreadsheet-template)
+     ("odt" . application/vnd.oasis.opendocument.text)
+     ("odm" . application/vnd.oasis.opendocument.text-master)
+     ("ott" . application/vnd.oasis.opendocument.text-template)
+     ("oth" . application/vnd.oasis.opendocument.text-web)
+     ("xlsx" . application/vnd.openxmlformats-officedocument.spreadsheetml.sheet)
+     ("xltx" . application/vnd.openxmlformats-officedocument.spreadsheetml.template)
+     ("pptx" . application/vnd.openxmlformats-officedocument.presentationml.presentation)
+     ("ppsx" . application/vnd.openxmlformats-officedocument.presentationml.slideshow)
+     ("potx" . application/vnd.openxmlformats-officedocument.presentationml.template)
+     ("docx" . application/vnd.openxmlformats-officedocument.wordprocessingml.document)
+     ("dotx" . application/vnd.openxmlformats-officedocument.wordprocessingml.template)
+     ("cod" . application/vnd.rim.cod)
+     ("mmf" . application/vnd.smaf)
+     ("sdc" . application/vnd.stardivision.calc)
+     ("sds" . application/vnd.stardivision.chart)
+     ("sda" . application/vnd.stardivision.draw)
+     ("sdd" . application/vnd.stardivision.impress)
+     ("sdf" . application/vnd.stardivision.math)
+     ("sdw" . application/vnd.stardivision.writer)
+     ("sgl" . application/vnd.stardivision.writer-global)
+     ("sxc" . application/vnd.sun.xml.calc)
+     ("stc" . application/vnd.sun.xml.calc.template)
+     ("sxd" . application/vnd.sun.xml.draw)
+     ("std" . application/vnd.sun.xml.draw.template)
+     ("sxi" . application/vnd.sun.xml.impress)
+     ("sti" . application/vnd.sun.xml.impress.template)
+     ("sxm" . application/vnd.sun.xml.math)
+     ("sxw" . application/vnd.sun.xml.writer)
+     ("sxg" . application/vnd.sun.xml.writer.global)
+     ("stw" . application/vnd.sun.xml.writer.template)
+     ("sis" . application/vnd.symbian.install)
+     ("vsd" . application/vnd.visio)
+     ("wbxml" . application/vnd.wap.wbxml)
+     ("wmlc" . application/vnd.wap.wmlc)
+     ("wmlsc" . application/vnd.wap.wmlscriptc)
+     ("wpd" . application/vnd.wordperfect)
+     ("wp5" . application/vnd.wordperfect5.1)
+     ("wk" . application/x-123)
+     ("7z" . application/x-7z-compressed)
+     ("bz2" . application/x-bzip2)
+     ("gz" . application/x-gzip)
+     ("abw" . application/x-abiword)
+     ("dmg" . application/x-apple-diskimage)
+     ("bcpio" . application/x-bcpio)
+     ("torrent" . application/x-bittorrent)
+     ("cab" . application/x-cab)
+     ("cbr" . application/x-cbr)
+     ("cbz" . application/x-cbz)
+     ("cdf" . application/x-cdf)
+     ("cda" . application/x-cdf)
+     ("vcd" . application/x-cdlink)
+     ("pgn" . application/x-chess-pgn)
+     ("cpio" . application/x-cpio)
+     ("csh" . application/x-csh)
+     ("deb" . application/x-debian-package)
+     ("udeb" . application/x-debian-package)
+     ("dcr" . application/x-director)
+     ("dir" . application/x-director)
+     ("dxr" . application/x-director)
+     ("dms" . application/x-dms)
+     ("wad" . application/x-doom)
+     ("dvi" . application/x-dvi)
+     ("rhtml" . application/x-httpd-eruby)
+     ("pfa" . application/x-font)
+     ("pfb" . application/x-font)
+     ("gsf" . application/x-font)
+     ("pcf" . application/x-font)
+     ("pcf.Z" . application/x-font)
+     ("mm" . application/x-freemind)
+     ("spl" . application/x-futuresplash)
+     ("gnumeric" . application/x-gnumeric)
+     ("sgf" . application/x-go-sgf)
+     ("gcf" . application/x-graphing-calculator)
+     ("gtar" . application/x-gtar)
+     ("tgz" . application/x-gtar)
+     ("taz" . application/x-gtar)
+     ("tar.gz" . application/x-gtar)
+     ("tar.bz2" . application/x-gtar)
+     ("tbz2" . application/x-gtar)
+     ("hdf" . application/x-hdf)
+     ("phtml" . application/x-httpd-php)
+     ("pht" . application/x-httpd-php)
+     ("php" . application/x-httpd-php)
+     ("phps" . application/x-httpd-php-source)
+     ("php3" . application/x-httpd-php3)
+     ("php3p" . application/x-httpd-php3-preprocessed)
+     ("php4" . application/x-httpd-php4)
+     ("php5" . application/x-httpd-php5)
+     ("ica" . application/x-ica)
+     ("info" . application/x-info)
+     ("ins" . application/x-internet-signup)
+     ("isp" . application/x-internet-signup)
+     ("iii" . application/x-iphone)
+     ("iso" . application/x-iso9660-image)
+     ("jam" . application/x-jam)
+     ("jnlp" . application/x-java-jnlp-file)
+     ("jmz" . application/x-jmol)
+     ("chrt" . application/x-kchart)
+     ("kil" . application/x-killustrator)
+     ("skp" . application/x-koan)
+     ("skd" . application/x-koan)
+     ("skt" . application/x-koan)
+     ("skm" . application/x-koan)
+     ("kpr" . application/x-kpresenter)
+     ("kpt" . application/x-kpresenter)
+     ("ksp" . application/x-kspread)
+     ("kwd" . application/x-kword)
+     ("kwt" . application/x-kword)
+     ("latex" . application/x-latex)
+     ("lha" . application/x-lha)
+     ("lyx" . application/x-lyx)
+     ("lzh" . application/x-lzh)
+     ("lzx" . application/x-lzx)
+     ("frm" . application/x-maker)
+     ("maker" . application/x-maker)
+     ("frame" . application/x-maker)
+     ("fm" . application/x-maker)
+     ("fb" . application/x-maker)
+     ("book" . application/x-maker)
+     ("fbdoc" . application/x-maker)
+     ("mif" . application/x-mif)
+     ("wmd" . application/x-ms-wmd)
+     ("wmz" . application/x-ms-wmz)
+     ("com" . application/x-msdos-program)
+     ("exe" . application/x-msdos-program)
+     ("bat" . application/x-msdos-program)
+     ("dll" . application/x-msdos-program)
+     ("msi" . application/x-msi)
+     ("nc" . application/x-netcdf)
+     ("pac" . application/x-ns-proxy-autoconfig)
+     ("dat" . application/x-ns-proxy-autoconfig)
+     ("nwc" . application/x-nwc)
+     ("o" . application/x-object)
+     ("oza" . application/x-oz-application)
+     ("p7r" . application/x-pkcs7-certreqresp)
+     ("crl" . application/x-pkcs7-crl)
+     ("pyc" . application/x-python-code)
+     ("pyo" . application/x-python-code)
+     ("qgs" . application/x-qgis)
+     ("shp" . application/x-qgis)
+     ("shx" . application/x-qgis)
+     ("qtl" . application/x-quicktimeplayer)
+     ("rpm" . application/x-redhat-package-manager)
+     ("rb" . application/x-ruby)
+     ("sh" . application/x-sh)
+     ("shar" . application/x-shar)
+     ("swf" . application/x-shockwave-flash)
+     ("swfl" . application/x-shockwave-flash)
+     ("scr" . application/x-silverlight)
+     ("sit" . application/x-stuffit)
+     ("sitx" . application/x-stuffit)
+     ("sv4cpio" . application/x-sv4cpio)
+     ("sv4crc" . application/x-sv4crc)
+     ("tar" . application/x-tar)
+     ("tcl" . application/x-tcl)
+     ("gf" . application/x-tex-gf)
+     ("pk" . application/x-tex-pk)
+     ("texinfo" . application/x-texinfo)
+     ("texi" . application/x-texinfo)
+     ("~" . application/x-trash)
+     ("%" . application/x-trash)
+     ("bak" . application/x-trash)
+     ("old" . application/x-trash)
+     ("sik" . application/x-trash)
+     ("t" . application/x-troff)
+     ("tr" . application/x-troff)
+     ("roff" . application/x-troff)
+     ("man" . application/x-troff-man)
+     ("me" . application/x-troff-me)
+     ("ms" . application/x-troff-ms)
+     ("ustar" . application/x-ustar)
+     ("src" . application/x-wais-source)
+     ("wz" . application/x-wingz)
+     ("crt" . application/x-x509-ca-cert)
+     ("xcf" . application/x-xcf)
+     ("fig" . application/x-xfig)
+     ("xpi" . application/x-xpinstall)
+     ("amr" . audio/amr)
+     ("awb" . audio/amr-wb)
+     ("amr" . audio/amr)
+     ("awb" . audio/amr-wb)
+     ("axa" . audio/annodex)
+     ("au" . audio/basic)
+     ("snd" . audio/basic)
+     ("flac" . audio/flac)
+     ("mid" . audio/midi)
+     ("midi" . audio/midi)
+     ("kar" . audio/midi)
+     ("mpga" . audio/mpeg)
+     ("mpega" . audio/mpeg)
+     ("mp2" . audio/mpeg)
+     ("mp3" . audio/mpeg)
+     ("m4a" . audio/mpeg)
+     ("m3u" . audio/mpegurl)
+     ("oga" . audio/ogg)
+     ("ogg" . audio/ogg)
+     ("spx" . audio/ogg)
+     ("sid" . audio/prs.sid)
+     ("aif" . audio/x-aiff)
+     ("aiff" . audio/x-aiff)
+     ("aifc" . audio/x-aiff)
+     ("gsm" . audio/x-gsm)
+     ("m3u" . audio/x-mpegurl)
+     ("wma" . audio/x-ms-wma)
+     ("wax" . audio/x-ms-wax)
+     ("ra" . audio/x-pn-realaudio)
+     ("rm" . audio/x-pn-realaudio)
+     ("ram" . audio/x-pn-realaudio)
+     ("ra" . audio/x-realaudio)
+     ("pls" . audio/x-scpls)
+     ("sd2" . audio/x-sd2)
+     ("wav" . audio/x-wav)
+     ("alc" . chemical/x-alchemy)
+     ("cac" . chemical/x-cache)
+     ("cache" . chemical/x-cache)
+     ("csf" . chemical/x-cache-csf)
+     ("cbin" . chemical/x-cactvs-binary)
+     ("cascii" . chemical/x-cactvs-binary)
+     ("ctab" . chemical/x-cactvs-binary)
+     ("cdx" . chemical/x-cdx)
+     ("cer" . chemical/x-cerius)
+     ("c3d" . chemical/x-chem3d)
+     ("chm" . chemical/x-chemdraw)
+     ("cif" . chemical/x-cif)
+     ("cmdf" . chemical/x-cmdf)
+     ("cml" . chemical/x-cml)
+     ("cpa" . chemical/x-compass)
+     ("bsd" . chemical/x-crossfire)
+     ("csml" . chemical/x-csml)
+     ("csm" . chemical/x-csml)
+     ("ctx" . chemical/x-ctx)
+     ("cxf" . chemical/x-cxf)
+     ("cef" . chemical/x-cxf)
+     ("emb" . chemical/x-embl-dl-nucleotide)
+     ("embl" . chemical/x-embl-dl-nucleotide)
+     ("spc" . chemical/x-galactic-spc)
+     ("inp" . chemical/x-gamess-input)
+     ("gam" . chemical/x-gamess-input)
+     ("gamin" . chemical/x-gamess-input)
+     ("fch" . chemical/x-gaussian-checkpoint)
+     ("fchk" . chemical/x-gaussian-checkpoint)
+     ("cub" . chemical/x-gaussian-cube)
+     ("gau" . chemical/x-gaussian-input)
+     ("gjc" . chemical/x-gaussian-input)
+     ("gjf" . chemical/x-gaussian-input)
+     ("gal" . chemical/x-gaussian-log)
+     ("gcg" . chemical/x-gcg8-sequence)
+     ("gen" . chemical/x-genbank)
+     ("hin" . chemical/x-hin)
+     ("istr" . chemical/x-isostar)
+     ("ist" . chemical/x-isostar)
+     ("jdx" . chemical/x-jcamp-dx)
+     ("dx" . chemical/x-jcamp-dx)
+     ("kin" . chemical/x-kinemage)
+     ("mcm" . chemical/x-macmolecule)
+     ("mmd" . chemical/x-macromodel-input)
+     ("mmod" . chemical/x-macromodel-input)
+     ("mol" . chemical/x-mdl-molfile)
+     ("rd" . chemical/x-mdl-rdfile)
+     ("rxn" . chemical/x-mdl-rxnfile)
+     ("sd" . chemical/x-mdl-sdfile)
+     ("sdf" . chemical/x-mdl-sdfile)
+     ("tgf" . chemical/x-mdl-tgf)
+     ("mcif" . chemical/x-mmcif)
+     ("mol2" . chemical/x-mol2)
+     ("b" . chemical/x-molconn-Z)
+     ("gpt" . chemical/x-mopac-graph)
+     ("mop" . chemical/x-mopac-input)
+     ("mopcrt" . chemical/x-mopac-input)
+     ("mpc" . chemical/x-mopac-input)
+     ("zmt" . chemical/x-mopac-input)
+     ("moo" . chemical/x-mopac-out)
+     ("mvb" . chemical/x-mopac-vib)
+     ("asn" . chemical/x-ncbi-asn1)
+     ("prt" . chemical/x-ncbi-asn1-ascii)
+     ("ent" . chemical/x-ncbi-asn1-ascii)
+     ("val" . chemical/x-ncbi-asn1-binary)
+     ("aso" . chemical/x-ncbi-asn1-binary)
+     ("asn" . chemical/x-ncbi-asn1-spec)
+     ("pdb" . chemical/x-pdb)
+     ("ent" . chemical/x-pdb)
+     ("ros" . chemical/x-rosdal)
+     ("sw" . chemical/x-swissprot)
+     ("vms" . chemical/x-vamas-iso14976)
+     ("vmd" . chemical/x-vmd)
+     ("xtel" . chemical/x-xtel)
+     ("xyz" . chemical/x-xyz)
+     ("gif" . image/gif)
+     ("ief" . image/ief)
+     ("jpeg" . image/jpeg)
+     ("jpg" . image/jpeg)
+     ("jpe" . image/jpeg)
+     ("pcx" . image/pcx)
+     ("png" . image/png)
+     ("svg" . image/svg+xml)
+     ("svgz" . image/svg+xml)
+     ("tiff" . image/tiff)
+     ("tif" . image/tiff)
+     ("djvu" . image/vnd.djvu)
+     ("djv" . image/vnd.djvu)
+     ("wbmp" . image/vnd.wap.wbmp)
+     ("cr2" . image/x-canon-cr2)
+     ("crw" . image/x-canon-crw)
+     ("ras" . image/x-cmu-raster)
+     ("cdr" . image/x-coreldraw)
+     ("pat" . image/x-coreldrawpattern)
+     ("cdt" . image/x-coreldrawtemplate)
+     ("cpt" . image/x-corelphotopaint)
+     ("erf" . image/x-epson-erf)
+     ("ico" . image/x-icon)
+     ("art" . image/x-jg)
+     ("jng" . image/x-jng)
+     ("bmp" . image/x-ms-bmp)
+     ("nef" . image/x-nikon-nef)
+     ("orf" . image/x-olympus-orf)
+     ("psd" . image/x-photoshop)
+     ("pnm" . image/x-portable-anymap)
+     ("pbm" . image/x-portable-bitmap)
+     ("pgm" . image/x-portable-graymap)
+     ("ppm" . image/x-portable-pixmap)
+     ("rgb" . image/x-rgb)
+     ("xbm" . image/x-xbitmap)
+     ("xpm" . image/x-xpixmap)
+     ("xwd" . image/x-xwindowdump)
+     ("eml" . message/rfc822)
+     ("igs" . model/iges)
+     ("iges" . model/iges)
+     ("msh" . model/mesh)
+     ("mesh" . model/mesh)
+     ("silo" . model/mesh)
+     ("wrl" . model/vrml)
+     ("vrml" . model/vrml)
+     ("x3dv" . model/x3d+vrml)
+     ("x3d" . model/x3d+xml)
+     ("x3db" . model/x3d+binary)
+     ("manifest" . text/cache-manifest)
+     ("ics" . text/calendar)
+     ("icz" . text/calendar)
+     ("css" . text/css)
+     ("csv" . text/csv)
+     ("323" . text/h323)
+     ("html" . text/html)
+     ("htm" . text/html)
+     ("shtml" . text/html)
+     ("uls" . text/iuls)
+     ("mml" . text/mathml)
+     ("asc" . text/plain)
+     ("txt" . text/plain)
+     ("text" . text/plain)
+     ("pot" . text/plain)
+     ("brf" . text/plain)
+     ("rtx" . text/richtext)
+     ("sct" . text/scriptlet)
+     ("wsc" . text/scriptlet)
+     ("tm" . text/texmacs)
+     ("ts" . text/texmacs)
+     ("tsv" . text/tab-separated-values)
+     ("jad" . text/vnd.sun.j2me.app-descriptor)
+     ("wml" . text/vnd.wap.wml)
+     ("wmls" . text/vnd.wap.wmlscript)
+     ("bib" . text/x-bibtex)
+     ("boo" . text/x-boo)
+     ("h++" . text/x-c++hdr)
+     ("hpp" . text/x-c++hdr)
+     ("hxx" . text/x-c++hdr)
+     ("hh" . text/x-c++hdr)
+     ("c++" . text/x-c++src)
+     ("cpp" . text/x-c++src)
+     ("cxx" . text/x-c++src)
+     ("cc" . text/x-c++src)
+     ("h" . text/x-chdr)
+     ("htc" . text/x-component)
+     ("csh" . text/x-csh)
+     ("c" . text/x-csrc)
+     ("d" . text/x-dsrc)
+     ("diff" . text/x-diff)
+     ("patch" . text/x-diff)
+     ("hs" . text/x-haskell)
+     ("java" . text/x-java)
+     ("lhs" . text/x-literate-haskell)
+     ("moc" . text/x-moc)
+     ("p" . text/x-pascal)
+     ("pas" . text/x-pascal)
+     ("gcd" . text/x-pcs-gcd)
+     ("pl" . text/x-perl)
+     ("pm" . text/x-perl)
+     ("py" . text/x-python)
+     ("scala" . text/x-scala)
+     ("etx" . text/x-setext)
+     ("sh" . text/x-sh)
+     ("tcl" . text/x-tcl)
+     ("tk" . text/x-tcl)
+     ("tex" . text/x-tex)
+     ("ltx" . text/x-tex)
+     ("sty" . text/x-tex)
+     ("cls" . text/x-tex)
+     ("vcs" . text/x-vcalendar)
+     ("vcf" . text/x-vcard)
+     ("json" . text/javascript)
+     ("3gp" . video/3gpp)
+     ("axv" . video/annodex)
+     ("dl" . video/dl)
+     ("dif" . video/dv)
+     ("dv" . video/dv)
+     ("fli" . video/fli)
+     ("gl" . video/gl)
+     ("mpeg" . video/mpeg)
+     ("mpg" . video/mpeg)
+     ("mpe" . video/mpeg)
+     ("mp4" . video/mp4)
+     ("qt" . video/quicktime)
+     ("mov" . video/quicktime)
+     ("ogv" . video/ogg)
+     ("mxu" . video/vnd.mpegurl)
+     ("flv" . video/x-flv)
+     ("lsf" . video/x-la-asf)
+     ("lsx" . video/x-la-asf)
+     ("mng" . video/x-mng)
+     ("asf" . video/x-ms-asf)
+     ("asx" . video/x-ms-asf)
+     ("wm" . video/x-ms-wm)
+     ("wmv" . video/x-ms-wmv)
+     ("wmx" . video/x-ms-wmx)
+     ("wvx" . video/x-ms-wvx)
+     ("avi" . video/x-msvideo)
+     ("movie" . video/x-sgi-movie)
+     ("mpv" . video/x-matroska)
+     ("mkv" . video/x-matroska)
+     ("ice" . x-conference/x-cooltalk)
+     ("sisx" . x-epoc/x-sisx-app)
+     ("vrm" . x-world/x-vrml)
+     ("vrml" . x-world/x-vrml)
+     ("wrl" . x-world/x-vrml))))
+
+(define %file-ext-regexp
+  (make-regexp "(\\.(.*)|[~%])$"))
+
+(define (file-extension file-name)
+  "Return the file extension for FILE-NAME, or #f if one is not
+found."
+  (and=> (regexp-exec %file-ext-regexp file-name)
+         (lambda (match)
+           (or (match:substring match 2)
+               (match:substring match 1)))))
+
+(define (mime-type file-name)
+  "Guess the MIME type for FILE-NAME based upon its file extension."
+  (or (hash-ref %mime-types (file-extension file-name))
+      'text/plain))

haunt/serve/web-server.scm

@@ -0,0 +1,149 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of Haunt.
+;;;
+;;; Haunt is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Haunt is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Haunt.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Simple HTTP server.
+;;
+;;; Code:
+
+(define-module (haunt serve web-server)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-1)
+  #:use-module (sxml simple)
+  #:use-module (web server)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (haunt serve mime-types)
+  #:export (serve))
+
+(define (stat:directory? stat)
+  "Return #t if STAT is a directory."
+  (eq? (stat:type stat) 'directory))
+
+(define (directory? file-name)
+  "Return #t if FILE-NAME is a directory."
+  (stat:directory? (stat file-name)))
+
+(define (directory-contents dir)
+  "Return a list of the files contained within DIR."
+  (define name+directory?
+    (match-lambda
+     ((name stat)
+      (list name (stat:directory? stat)))))
+
+  (define (same-dir? other stat)
+    (string=? dir other))
+
+  (match (file-system-tree dir same-dir?)
+    ;; We are not interested in the parent directory, only the
+    ;; children.
+    ((_ _ children ...)
+     (map name+directory? children))))
+
+(define (work-dir+path->file-name work-dir path)
+  "Convert the URI PATH to an absolute file name relative to the
+directory WORK-DIR."
+  (string-append work-dir path))
+
+(define (resolve-file-name file-name)
+  "If FILE-NAME is a directory with an 'index.html' file,
+return that file name.  If FILE-NAME does not exist, return #f.
+Otherwise, return FILE-NAME as-is."
+  (let ((index-file-name (string-append file-name "/index.html")))
+    (cond
+     ((file-exists? index-file-name) index-file-name)
+     ((file-exists? file-name) file-name)
+     (else #f))))
+
+(define (dump-file file-name port)
+  "Write the contents of FILE-NAME to PORT."
+  (with-input-from-file file-name
+    (lambda ()
+      (let loop ((char (read-char)))
+        (unless (eof-object? char)
+          (write-char char port)
+          (loop (read-char)))))))
+
+(define (render-file file-name)
+  "Return a 200 OK HTTP response that renders the contents of
+FILE-NAME."
+  (values `((content-type . (,(mime-type file-name))))
+          (lambda (port)
+            (dump-file file-name port))))
+
+(define (render-directory path dir)
+  "Render the contents of DIR represented by the URI PATH."
+  (define render-child
+    (match-lambda
+     ((file-name directory?)
+      `(li
+        (a (@ (href ,(string-append path "/" file-name)))
+           ,(if directory?
+                (string-append file-name "/")
+                file-name))))))
+
+  (define file-name<
+    (match-lambda*
+     (((name-a _) (name-b _))
+      (string< name-a name-b))))
+
+  (let* ((children (sort (directory-contents dir) file-name<))
+         (title (string-append "Directory listing for " path))
+         (view `(html
+                (head
+                 (title ,title))
+                (body
+                 (h1 ,title)
+                 (h2 "<i>foobar</i>")
+                 (ul ,@(map render-child children))))))
+    (values '((content-type . (text/html)))
+            (lambda (port)
+              (display "<!DOCTYPE html>" port)
+              (sxml->xml view port)))))
+
+(define (not-found path)
+  "Return a 404 not found HTTP response for PATH."
+  (values (build-response #:code 404)
+          (string-append "Resource not found: " path)))
+
+(define (serve-file work-dir path)
+  "Return an HTTP response for the file represented by PATH."
+  (match (resolve-file-name
+          (work-dir+path->file-name work-dir path))
+    (#f (not-found path))
+    ((? directory? dir)
+     (render-directory path dir))
+    (file-name
+     (render-file file-name))))
+
+(define (make-handler work-dir)
+  (lambda (request body)
+    "Serve the file asked for in REQUEST."
+    (let ((path (uri-path (request-uri request))))
+      (format #t "~a ~a~%" (request-method request) path)
+      (serve-file work-dir path))))
+
+(define* (serve work-dir #:key (open-params '()))
+  "Run a simple HTTP server that serves files in WORK-DIR."
+  (run-server (make-handler work-dir) 'http open-params))

haunt/ui.scm

@@ -24,12 +24,29 @@
 
 (define-module (haunt ui)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
-  #:export (haunt-main))
+  #:use-module (srfi srfi-26)
+  #:export (program-name
+            haunt-error
+            option?
+            haunt-main))
+
+(define commands
+  '(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.~%~%"))
+Run COMMAND with ARGS.~%~%")
+  (format #t "COMMAND must be one of the sub-commands listed below:~%~%")
+  (format #t "~{   ~a~%~}" (sort commands string<?)))
 
 (define (show-haunt-usage)
   (format #t "Try `haunt --help' for more information.~%")
@@ -38,6 +55,18 @@ Run COMMAND with ARGS.~%~%"))
 (define (option? str)
   (string-prefix? "-" str))
 
+(define (run-haunt-command command . args)
+  (let* ((module
+          (catch 'misc-error
+            (lambda ()
+              (resolve-interface `(haunt ui ,command)))
+            (lambda -
+              (haunt-error "~a: command not found" command)
+              (show-haunt-usage))))
+         (command-main (module-ref module (symbol-append 'haunt- command))))
+    (parameterize ((program-name command))
+      (apply command-main args))))
+
 (define* (haunt-main arg0 . args)
   (match args
     (()
@@ -48,4 +77,6 @@ Run COMMAND with ARGS.~%~%"))
      (format (current-error-port)
              "haunt: unrecognized option '~a'~%"
              opt)
-     (show-haunt-usage))))
+     (show-haunt-usage))
+    ((command args ...)
+     (apply run-haunt-command (string->symbol command) args))))

haunt/ui/serve.scm

@@ -0,0 +1,49 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of Haunt.
+;;;
+;;; Haunt is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Haunt is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Haunt.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Haunt serve sub-command.
+;;
+;;; Code:
+
+(define-module (haunt ui serve)
+  #:use-module (ice-9 match)
+  #:use-module (haunt config)
+  #:use-module (haunt ui)
+  #:use-module (haunt serve web-server)
+  #:export (haunt-serve))
+
+(define (show-serve-help)
+  (format #t "Usage: haunt serve [OPTION]
+Start an HTTP server for the current site.~%")
+  (display "
+  -h, --help             display this help and exit")
+  (newline))
+
+(define haunt-serve
+  (match-lambda*
+   (() (serve (haunt-output-directory)))
+   ((or ("-h") ("--help"))
+    (show-serve-help))
+   (((? option? opt) _ ...)
+    (haunt-error "invalid option: ~a" opt)
+    (exit 1))
+   ((arg _ ...)
+    (haunt-error "invalid argument: ~a" arg)
+    (exit 1))))