summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2015-01-04 22:23:47 -0500
committerDavid Thompson <dthompson2@worcester.edu>2015-01-04 22:49:59 -0500
commitf299cca70928759f04d44d81d6c2f0f6f9388e1b (patch)
tree69c4fed80cf71f0efaf79d7b4b6a25f448d016ba
parent1cd43ba9677a7e5e988a2aaeb944434debaaa58b (diff)
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.
-rw-r--r--Makefile.am6
-rw-r--r--haunt/config.scm39
-rw-r--r--haunt/serve/mime-types.scm556
-rw-r--r--haunt/serve/web-server.scm149
-rw-r--r--haunt/ui.scm37
-rw-r--r--haunt/ui/serve.scm49
6 files changed, 832 insertions, 4 deletions
diff --git a/Makefile.am b/Makefile.am
index bd0437d..65d1d81 100644
--- a/Makefile.am
+++ b/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
diff --git a/haunt/config.scm b/haunt/config.scm
new file mode 100644
index 0000000..53dc404
--- /dev/null
+++ b/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"))
diff --git a/haunt/serve/mime-types.scm b/haunt/serve/mime-types.scm
new file mode 100644
index 0000000..4c9c0f1
--- /dev/null
+++ b/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))
diff --git a/haunt/serve/web-server.scm b/haunt/serve/web-server.scm
new file mode 100644
index 0000000..b6d001b
--- /dev/null
+++ b/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))
diff --git a/haunt/ui.scm b/haunt/ui.scm
index b2db00c..35e8eb3 100644
--- a/haunt/ui.scm
+++ b/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))))
diff --git a/haunt/ui/serve.scm b/haunt/ui/serve.scm
new file mode 100644
index 0000000..3ef7ede
--- /dev/null
+++ b/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))))