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.
This commit is contained in:
David Thompson
39
haunt/config.scm
Normal file
39
haunt/config.scm
Normal file
@@ -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"))
|
||||
556
haunt/serve/mime-types.scm
Normal file
556
haunt/serve/mime-types.scm
Normal file
@@ -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))
|
||||
149
haunt/serve/web-server.scm
Normal file
149
haunt/serve/web-server.scm
Normal file
@@ -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))
|
||||
37
haunt/ui.scm
37
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))))
|
||||
|
||||
49
haunt/ui/serve.scm
Normal file
49
haunt/ui/serve.scm
Normal file
@@ -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))))
|
||||
Reference in New Issue
Block a user