diff options
| -rw-r--r-- | Makefile.am | 6 | ||||
| -rw-r--r-- | haunt/config.scm | 39 | ||||
| -rw-r--r-- | haunt/serve/mime-types.scm | 556 | ||||
| -rw-r--r-- | haunt/serve/web-server.scm | 149 | ||||
| -rw-r--r-- | haunt/ui.scm | 37 | ||||
| -rw-r--r-- | haunt/ui/serve.scm | 49 |
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)))) |