happstack-server 0.3.3 → 0.4.1

raw patch · 13 files changed

+478/−568 lines, 13 filesdep +filepathdep +sendfiledep ~happstack-datadep ~happstack-utildep ~networknew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: filepath, sendfile

Dependency ranges changed: happstack-data, happstack-util, network

API changes (from Hackage documentation)

Files

• happstack-server.cabal +6/−5
• src/Happstack/Server/Cookie.hs +4/−3
• src/Happstack/Server/HTTP/Client.hs +7/−6
• src/Happstack/Server/HTTP/FileServe.hs +286/−248
• src/Happstack/Server/HTTP/Handler.hs +40/−33
• src/Happstack/Server/HTTP/Listen.hs +10/−3
• src/Happstack/Server/HTTP/SocketTH.hs +2/−3
• src/Happstack/Server/HTTP/Types.hs +16/−7
• src/Happstack/Server/MessageWrap.hs +1/−1
• src/Happstack/Server/Parts.hs +1/−1
• src/Happstack/Server/S3.hs +0/−240
• src/Happstack/Server/SimpleHTTP.hs +89/−10
• tests/Happstack/Server/Tests.hs +16/−8

@@ -1,5 +1,5 @@ Name:                happstack-server-Version:             0.3.3+Version:             0.4.1 Synopsis:            Web related tools and services. Description:         Web framework License:             BSD3@@ -14,7 +14,7 @@ source-repository head     type:     darcs     subdir:   happstack-server-    location: http://patch-tag.com/publicrepos/happstack+    location: http://patch-tag.com/r/mae/happstack/pullrepo  Flag base4     Description: Choose the even newer, even smaller, split-up base package.@@ -43,7 +43,6 @@     Exposed-modules:                           Happstack.Server.Tests   Other-modules:       -                       Happstack.Server.S3                        Happstack.Server.HTTPClient.HTTP                        Happstack.Server.HTTPClient.Stream                        Happstack.Server.HTTPClient.TCP@@ -63,10 +62,11 @@                        containers,                        directory,                        extensible-exceptions,+                       filepath,                        HaXml >= 1.13 && < 1.14,                        hslogger >= 1.0.2,-                       happstack-data >= 0.3.2 && < 0.4,-                       happstack-util >= 0.3.2 && < 0.4,+                       happstack-data >= 0.4.1 && < 0.5,+                       happstack-util >= 0.4.1 && < 0.5,                        html,                        MaybeT,                        mtl,@@ -75,6 +75,7 @@                        old-time,                        parsec < 3,                        process,+                       sendfile >= 0.6.1 && < 0.7,                        template-haskell,                        time,                        utf8-string >= 0.3.4 && < 0.4,

@@ -28,11 +28,12 @@     , cookieDomain  :: String     , cookieName    :: String     , cookieValue   :: String+    , secure        :: Bool     } deriving(Show,Eq,Read,Typeable,Data)  -- | Creates a cookie with a default version of 1 and path of "/" mkCookie :: String -> String -> Cookie-mkCookie key val = Cookie "1" "/" "" key val+mkCookie key val = Cookie "1" "/" "" key val False  -- | Set a Cookie in the Result. -- The values are escaped as per RFC 2109, but some browsers may@@ -47,7 +48,7 @@         s f   = '\"' : concatMap e (f cookie) ++ "\""         e c | fctl c || c == '"' = ['\\',c]             | otherwise          = [c]-    in concat $ intersperse ";" ((cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ])+    in concat $ intersperse ";" ((cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ] ++ if secure cookie then ["Secure"] else [])  fctl :: Char -> Bool fctl ch = ch == chr 127 || ch <= chr 31@@ -74,7 +75,7 @@             val<-value             path<-option "" $ try (cookieSep >> cookie_path)             domain<-option "" $ try (cookieSep >> cookie_domain)-            return $ Cookie ver path domain (low name) val+            return $ Cookie ver path domain (low name) val False           cookie_version = cookie_special "$Version"           cookie_path = cookie_special "$Path"           cookie_domain = cookie_special "$Domain"

@@ -4,6 +4,7 @@ import Happstack.Server.HTTP.Handler import Happstack.Server.HTTP.Types import Data.Maybe+import Control.Monad import qualified Data.ByteString.Lazy.Char8 as L   import System.IO@@ -43,10 +44,10 @@   csv v x = x++", " ++ v  unrproxify :: String -> [(String, String)] -> Request -> Request-unrproxify defaultHost list rq = unproxify rq {rqPaths = host: rqPaths rq}-  where-  host::String-  host = maybe defaultHost (f .B.unpack) $-         getHeader "host" rq-  f = maybe defaultHost id . flip lookup list+unrproxify defaultHost list rq = +  let host::String+      host = fromMaybe defaultHost $ flip lookup list =<< B.unpack `liftM` getHeader "host" rq +      newrq = rq {rqPaths = host: rqPaths rq}+  in  unproxify newrq+ 

@@ -1,34 +1,54 @@ {-# LANGUAGE FlexibleContexts, Rank2Types #-}+-- |File Serving functions module Happstack.Server.HTTP.FileServe     (+     -- * Content-Type \/ Mime-Type      MimeMap,+     mimeTypes,+     asContentType,+     guessContentType,+     guessContentTypeM,+     -- * Low-Level+     sendFileResponse,     +     lazyByteStringResponse,+     strictByteStringResponse,+     filePathSendFile,+     filePathLazy,+     filePathStrict,+     -- * High-Level+     -- ** Serving a single file+     serveFile,+     serveFileUsing,+     -- ** Serving files from a directory+     fileServe',+     fileServe,+     fileServeLazy,+     fileServeStrict,+     -- * Other      blockDotFiles,+     defaultIxFiles,      doIndex,+     doIndex',+     doIndexLazy,      doIndexStrict,      errorwrapper,-     fileServe,-     fileServeStrict,-     isDot,-     mimeTypes+     isDot     ) where -import Control.Exception.Extensible--import Control.Monad.Reader-import Control.Monad.Trans-import Data.List-import Data.Maybe-import Data.Int-import Happstack.Server.SimpleHTTP hiding (path)-import System.Directory-import System.IO-import System.Locale(defaultTimeLocale)-import System.Log.Logger-import System.Time -- (formatCalendarTime, toUTCTime,TOD(..))-import qualified Data.ByteString.Char8 as P+import Control.Exception.Extensible (IOException, SomeException, Exception(fromException), bracket, handleJust)+import Control.Monad (MonadPlus)+import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as S+import Data.Maybe (fromMaybe)+import           Data.Map (Map) import qualified Data.Map as Map-import qualified Happstack.Server.SimpleHTTP as SH+import Happstack.Server.SimpleHTTP (FilterMonad, ServerMonad(askRq), Request(..), Response(..), WebMonad, toResponse, resultBS, setHeader, forbidden, nullRsFlags, result, require, rsfContentLength, seeOther, ifModifiedSince )+import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime)+import System.IO (IOMode(ReadMode), hFileSize, hClose, openBinaryFile)+import System.FilePath ((</>), addTrailingPathSeparator, joinPath, takeExtension)+import System.Log.Logger (Priority(DEBUG), logM)+import System.Time (CalendarTime, toUTCTime)  ioErrors :: SomeException -> Maybe IOException ioErrors = fromException@@ -45,269 +65,287 @@                      then fmap Just $ readFile loglocation                      else return Nothing +-- * Mime-Type / Content-Type -type MimeMap = Map.Map String String+type MimeMap = Map String String -type GetFileFunc = (MonadIO m) =>-    Map.Map String String-    -> String-    -> m (Either String ((ClockTime, Integer), (String, L.ByteString)))+-- | Ready collection of common mime types.+-- Except for the first two entries, the mappings come from an Ubuntu 8.04 /etc/mime.types file.+mimeTypes :: MimeMap+mimeTypes = Map.fromList [("gz","application/x-gzip"),("cabal","application/x-cabal"),("%","application/x-trash"),("323","text/h323"),("3gp","video/3gpp"),("7z","application/x-7z-compressed"),("abw","application/x-abiword"),("ai","application/postscript"),("aif","audio/x-aiff"),("aifc","audio/x-aiff"),("aiff","audio/x-aiff"),("alc","chemical/x-alchemy"),("art","image/x-jg"),("asc","text/plain"),("asf","video/x-ms-asf"),("asn","chemical/x-ncbi-asn1"),("aso","chemical/x-ncbi-asn1-binary"),("asx","video/x-ms-asf"),("atom","application/atom"),("atomcat","application/atomcat+xml"),("atomsrv","application/atomserv+xml"),("au","audio/basic"),("avi","video/x-msvideo"),("b","chemical/x-molconn-Z"),("bak","application/x-trash"),("bat","application/x-msdos-program"),("bcpio","application/x-bcpio"),("bib","text/x-bibtex"),("bin","application/octet-stream"),("bmp","image/x-ms-bmp"),("boo","text/x-boo"),("book","application/x-maker"),("bsd","chemical/x-crossfire"),("c","text/x-csrc"),("c++","text/x-c++src"),("c3d","chemical/x-chem3d"),("cab","application/x-cab"),("cac","chemical/x-cache"),("cache","chemical/x-cache"),("cap","application/cap"),("cascii","chemical/x-cactvs-binary"),("cat","application/vnd.ms-pki.seccat"),("cbin","chemical/x-cactvs-binary"),("cbr","application/x-cbr"),("cbz","application/x-cbz"),("cc","text/x-c++src"),("cdf","application/x-cdf"),("cdr","image/x-coreldraw"),("cdt","image/x-coreldrawtemplate"),("cdx","chemical/x-cdx"),("cdy","application/vnd.cinderella"),("cef","chemical/x-cxf"),("cer","chemical/x-cerius"),("chm","chemical/x-chemdraw"),("chrt","application/x-kchart"),("cif","chemical/x-cif"),("class","application/java-vm"),("cls","text/x-tex"),("cmdf","chemical/x-cmdf"),("cml","chemical/x-cml"),("cod","application/vnd.rim.cod"),("com","application/x-msdos-program"),("cpa","chemical/x-compass"),("cpio","application/x-cpio"),("cpp","text/x-c++src"),("cpt","application/mac-compactpro"),("crl","application/x-pkcs7-crl"),("crt","application/x-x509-ca-cert"),("csf","chemical/x-cache-csf"),("csh","application/x-csh"),("csm","chemical/x-csml"),("csml","chemical/x-csml"),("css","text/css"),("csv","text/csv"),("ctab","chemical/x-cactvs-binary"),("ctx","chemical/x-ctx"),("cu","application/cu-seeme"),("cub","chemical/x-gaussian-cube"),("cxf","chemical/x-cxf"),("cxx","text/x-c++src"),("d","text/x-dsrc"),("dat","chemical/x-mopac-input"),("dcr","application/x-director"),("deb","application/x-debian-package"),("dif","video/dv"),("diff","text/x-diff"),("dir","application/x-director"),("djv","image/vnd.djvu"),("djvu","image/vnd.djvu"),("dl","video/dl"),("dll","application/x-msdos-program"),("dmg","application/x-apple-diskimage"),("dms","application/x-dms"),("doc","application/msword"),("dot","application/msword"),("dv","video/dv"),("dvi","application/x-dvi"),("dx","chemical/x-jcamp-dx"),("dxr","application/x-director"),("emb","chemical/x-embl-dl-nucleotide"),("embl","chemical/x-embl-dl-nucleotide"),("eml","message/rfc822"),("ent","chemical/x-ncbi-asn1-ascii"),("eps","application/postscript"),("etx","text/x-setext"),("exe","application/x-msdos-program"),("ez","application/andrew-inset"),("fb","application/x-maker"),("fbdoc","application/x-maker"),("fch","chemical/x-gaussian-checkpoint"),("fchk","chemical/x-gaussian-checkpoint"),("fig","application/x-xfig"),("flac","application/x-flac"),("fli","video/fli"),("fm","application/x-maker"),("frame","application/x-maker"),("frm","application/x-maker"),("gal","chemical/x-gaussian-log"),("gam","chemical/x-gamess-input"),("gamin","chemical/x-gamess-input"),("gau","chemical/x-gaussian-input"),("gcd","text/x-pcs-gcd"),("gcf","application/x-graphing-calculator"),("gcg","chemical/x-gcg8-sequence"),("gen","chemical/x-genbank"),("gf","application/x-tex-gf"),("gif","image/gif"),("gjc","chemical/x-gaussian-input"),("gjf","chemical/x-gaussian-input"),("gl","video/gl"),("gnumeric","application/x-gnumeric"),("gpt","chemical/x-mopac-graph"),("gsf","application/x-font"),("gsm","audio/x-gsm"),("gtar","application/x-gtar"),("h","text/x-chdr"),("h++","text/x-c++hdr"),("hdf","application/x-hdf"),("hh","text/x-c++hdr"),("hin","chemical/x-hin"),("hpp","text/x-c++hdr"),("hqx","application/mac-binhex40"),("hs","text/x-haskell"),("hta","application/hta"),("htc","text/x-component"),("htm","text/html"),("html","text/html"),("hxx","text/x-c++hdr"),("ica","application/x-ica"),("ice","x-conference/x-cooltalk"),("ico","image/x-icon"),("ics","text/calendar"),("icz","text/calendar"),("ief","image/ief"),("iges","model/iges"),("igs","model/iges"),("iii","application/x-iphone"),("inp","chemical/x-gamess-input"),("ins","application/x-internet-signup"),("iso","application/x-iso9660-image"),("isp","application/x-internet-signup"),("ist","chemical/x-isostar"),("istr","chemical/x-isostar"),("jad","text/vnd.sun.j2me.app-descriptor"),("jar","application/java-archive"),("java","text/x-java"),("jdx","chemical/x-jcamp-dx"),("jmz","application/x-jmol"),("jng","image/x-jng"),("jnlp","application/x-java-jnlp-file"),("jpe","image/jpeg"),("jpeg","image/jpeg"),("jpg","image/jpeg"),("js","application/x-javascript"),("kar","audio/midi"),("key","application/pgp-keys"),("kil","application/x-killustrator"),("kin","chemical/x-kinemage"),("kml","application/vnd.google-earth.kml+xml"),("kmz","application/vnd.google-earth.kmz"),("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"),("lhs","text/x-literate-haskell"),("lsf","video/x-la-asf"),("lsx","video/x-la-asf"),("ltx","text/x-tex"),("lyx","application/x-lyx"),("lzh","application/x-lzh"),("lzx","application/x-lzx"),("m3u","audio/mpegurl"),("m4a","audio/mpeg"),("maker","application/x-maker"),("man","application/x-troff-man"),("mcif","chemical/x-mmcif"),("mcm","chemical/x-macmolecule"),("mdb","application/msaccess"),("me","application/x-troff-me"),("mesh","model/mesh"),("mid","audio/midi"),("midi","audio/midi"),("mif","application/x-mif"),("mm","application/x-freemind"),("mmd","chemical/x-macromodel-input"),("mmf","application/vnd.smaf"),("mml","text/mathml"),("mmod","chemical/x-macromodel-input"),("mng","video/x-mng"),("moc","text/x-moc"),("mol","chemical/x-mdl-molfile"),("mol2","chemical/x-mol2"),("moo","chemical/x-mopac-out"),("mop","chemical/x-mopac-input"),("mopcrt","chemical/x-mopac-input"),("mov","video/quicktime"),("movie","video/x-sgi-movie"),("mp2","audio/mpeg"),("mp3","audio/mpeg"),("mp4","video/mp4"),("mpc","chemical/x-mopac-input"),("mpe","video/mpeg"),("mpeg","video/mpeg"),("mpega","audio/mpeg"),("mpg","video/mpeg"),("mpga","audio/mpeg"),("ms","application/x-troff-ms"),("msh","model/mesh"),("msi","application/x-msi"),("mvb","chemical/x-mopac-vib"),("mxu","video/vnd.mpegurl"),("nb","application/mathematica"),("nc","application/x-netcdf"),("nwc","application/x-nwc"),("o","application/x-object"),("oda","application/oda"),("odb","application/vnd.oasis.opendocument.database"),("odc","application/vnd.oasis.opendocument.chart"),("odf","application/vnd.oasis.opendocument.formula"),("odg","application/vnd.oasis.opendocument.graphics"),("odi","application/vnd.oasis.opendocument.image"),("odm","application/vnd.oasis.opendocument.text-master"),("odp","application/vnd.oasis.opendocument.presentation"),("ods","application/vnd.oasis.opendocument.spreadsheet"),("odt","application/vnd.oasis.opendocument.text"),("oga","audio/ogg"),("ogg","application/ogg"),("ogv","video/ogg"),("ogx","application/ogg"),("old","application/x-trash"),("otg","application/vnd.oasis.opendocument.graphics-template"),("oth","application/vnd.oasis.opendocument.text-web"),("otp","application/vnd.oasis.opendocument.presentation-template"),("ots","application/vnd.oasis.opendocument.spreadsheet-template"),("ott","application/vnd.oasis.opendocument.text-template"),("oza","application/x-oz-application"),("p","text/x-pascal"),("p7r","application/x-pkcs7-certreqresp"),("pac","application/x-ns-proxy-autoconfig"),("pas","text/x-pascal"),("pat","image/x-coreldrawpattern"),("patch","text/x-diff"),("pbm","image/x-portable-bitmap"),("pcap","application/cap"),("pcf","application/x-font"),("pcf.Z","application/x-font"),("pcx","image/pcx"),("pdb","chemical/x-pdb"),("pdf","application/pdf"),("pfa","application/x-font"),("pfb","application/x-font"),("pgm","image/x-portable-graymap"),("pgn","application/x-chess-pgn"),("pgp","application/pgp-signature"),("php","application/x-httpd-php"),("php3","application/x-httpd-php3"),("php3p","application/x-httpd-php3-preprocessed"),("php4","application/x-httpd-php4"),("phps","application/x-httpd-php-source"),("pht","application/x-httpd-php"),("phtml","application/x-httpd-php"),("pk","application/x-tex-pk"),("pl","text/x-perl"),("pls","audio/x-scpls"),("pm","text/x-perl"),("png","image/png"),("pnm","image/x-portable-anymap"),("pot","text/plain"),("ppm","image/x-portable-pixmap"),("pps","application/vnd.ms-powerpoint"),("ppt","application/vnd.ms-powerpoint"),("prf","application/pics-rules"),("prt","chemical/x-ncbi-asn1-ascii"),("ps","application/postscript"),("psd","image/x-photoshop"),("py","text/x-python"),("pyc","application/x-python-code"),("pyo","application/x-python-code"),("qt","video/quicktime"),("qtl","application/x-quicktimeplayer"),("ra","audio/x-pn-realaudio"),("ram","audio/x-pn-realaudio"),("rar","application/rar"),("ras","image/x-cmu-raster"),("rd","chemical/x-mdl-rdfile"),("rdf","application/rdf+xml"),("rgb","image/x-rgb"),("rhtml","application/x-httpd-eruby"),("rm","audio/x-pn-realaudio"),("roff","application/x-troff"),("ros","chemical/x-rosdal"),("rpm","application/x-redhat-package-manager"),("rss","application/rss+xml"),("rtf","application/rtf"),("rtx","text/richtext"),("rxn","chemical/x-mdl-rxnfile"),("sct","text/scriptlet"),("sd","chemical/x-mdl-sdfile"),("sd2","audio/x-sd2"),("sda","application/vnd.stardivision.draw"),("sdc","application/vnd.stardivision.calc"),("sdd","application/vnd.stardivision.impress"),("sdf","application/vnd.stardivision.math"),("sds","application/vnd.stardivision.chart"),("sdw","application/vnd.stardivision.writer"),("ser","application/java-serialized-object"),("sgf","application/x-go-sgf"),("sgl","application/vnd.stardivision.writer-global"),("sh","application/x-sh"),("shar","application/x-shar"),("shtml","text/html"),("sid","audio/prs.sid"),("sik","application/x-trash"),("silo","model/mesh"),("sis","application/vnd.symbian.install"),("sisx","x-epoc/x-sisx-app"),("sit","application/x-stuffit"),("sitx","application/x-stuffit"),("skd","application/x-koan"),("skm","application/x-koan"),("skp","application/x-koan"),("skt","application/x-koan"),("smi","application/smil"),("smil","application/smil"),("snd","audio/basic"),("spc","chemical/x-galactic-spc"),("spl","application/futuresplash"),("spx","audio/ogg"),("src","application/x-wais-source"),("stc","application/vnd.sun.xml.calc.template"),("std","application/vnd.sun.xml.draw.template"),("sti","application/vnd.sun.xml.impress.template"),("stl","application/vnd.ms-pki.stl"),("stw","application/vnd.sun.xml.writer.template"),("sty","text/x-tex"),("sv4cpio","application/x-sv4cpio"),("sv4crc","application/x-sv4crc"),("svg","image/svg+xml"),("svgz","image/svg+xml"),("sw","chemical/x-swissprot"),("swf","application/x-shockwave-flash"),("swfl","application/x-shockwave-flash"),("sxc","application/vnd.sun.xml.calc"),("sxd","application/vnd.sun.xml.draw"),("sxg","application/vnd.sun.xml.writer.global"),("sxi","application/vnd.sun.xml.impress"),("sxm","application/vnd.sun.xml.math"),("sxw","application/vnd.sun.xml.writer"),("t","application/x-troff"),("tar","application/x-tar"),("taz","application/x-gtar"),("tcl","application/x-tcl"),("tex","text/x-tex"),("texi","application/x-texinfo"),("texinfo","application/x-texinfo"),("text","text/plain"),("tgf","chemical/x-mdl-tgf"),("tgz","application/x-gtar"),("tif","image/tiff"),("tiff","image/tiff"),("tk","text/x-tcl"),("tm","text/texmacs"),("torrent","application/x-bittorrent"),("tr","application/x-troff"),("ts","text/texmacs"),("tsp","application/dsptype"),("tsv","text/tab-separated-values"),("txt","text/plain"),("udeb","application/x-debian-package"),("uls","text/iuls"),("ustar","application/x-ustar"),("val","chemical/x-ncbi-asn1-binary"),("vcd","application/x-cdlink"),("vcf","text/x-vcard"),("vcs","text/x-vcalendar"),("vmd","chemical/x-vmd"),("vms","chemical/x-vamas-iso14976"),("vrm","x-world/x-vrml"),("vrml","model/vrml"),("vsd","application/vnd.visio"),("wad","application/x-doom"),("wav","audio/x-wav"),("wax","audio/x-ms-wax"),("wbmp","image/vnd.wap.wbmp"),("wbxml","application/vnd.wap.wbxml"),("wk","application/x-123"),("wm","video/x-ms-wm"),("wma","audio/x-ms-wma"),("wmd","application/x-ms-wmd"),("wml","text/vnd.wap.wml"),("wmlc","application/vnd.wap.wmlc"),("wmls","text/vnd.wap.wmlscript"),("wmlsc","application/vnd.wap.wmlscriptc"),("wmv","video/x-ms-wmv"),("wmx","video/x-ms-wmx"),("wmz","application/x-ms-wmz"),("wp5","application/wordperfect5.1"),("wpd","application/wordperfect"),("wrl","model/vrml"),("wsc","text/scriptlet"),("wvx","video/x-ms-wvx"),("wz","application/x-wingz"),("xbm","image/x-xbitmap"),("xcf","application/x-xcf"),("xht","application/xhtml+xml"),("xhtml","application/xhtml+xml"),("xlb","application/vnd.ms-excel"),("xls","application/vnd.ms-excel"),("xlt","application/vnd.ms-excel"),("xml","application/xml"),("xpi","application/x-xpinstall"),("xpm","image/x-xpixmap"),("xsl","application/xml"),("xtel","chemical/x-xtel"),("xul","application/vnd.mozilla.xul+xml"),("xwd","image/x-xwindowdump"),("xyz","chemical/x-xyz"),("zip","application/zip"),("zmt","chemical/x-mopac-input"),("~","application/x-trash")]  +guessContentType :: MimeMap -> FilePath -> Maybe String+guessContentType mimeMap filepath =+    case getExt filepath of+      "" -> Nothing+      ext -> Map.lookup ext mimeMap -doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-           [String] -> MimeMap -> String -> m Response-doIndex = doIndex' getFile+guessContentTypeM :: (Monad m) => MimeMap -> (FilePath -> m String)+guessContentTypeM mimeMap filePath = return $ fromMaybe "text/plain" $ guessContentType mimeMap filePath --- | A variant of 'doIndex' that relies on 'getFileStrict'-doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-                 [String] -> MimeMap -> String -> m Response-doIndexStrict = doIndex' getFileStrict+asContentType :: (Monad m) => String -> (FilePath -> m String)+asContentType = const . return +defaultIxFiles :: [String]+defaultIxFiles= ["index.html","index.xml","index.gif"] -doIndex' :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-            GetFileFunc-         -> [String]-         -> MimeMap-         -> String-         -> m Response-doIndex' _getFileFunc []           _mime _fp = forbidden $ toResponse "Directory index forbidden"-doIndex'  getFileFunc (index:rest)  mime  fp =-    do-    let path = fp++'/':index-    --print path-    fe <- liftIO $ doesFileExist path-    if fe then retFile path else doIndex rest mime fp-    where retFile = returnFile getFileFunc mime+fileNotFound :: (Monad m, FilterMonad Response m) => FilePath -> m Response+fileNotFound fp = return $ result 404 $ "File not found " ++ fp +-- | Similar to 'takeExtension' but does not include the extension separator char+getExt :: FilePath -> String+getExt fp = drop 1 $ takeExtension fp +-- | Prevents files of the form '.foo' or 'bar/.foo' from being served+blockDotFiles :: (Request -> IO Response) -> Request -> IO Response+blockDotFiles fn rq+    | isDot (joinPath (rqPaths rq)) = return $ result 403 "Dot files not allowed."+    | otherwise = fn rq -defaultIxFiles :: [String]-defaultIxFiles= ["index.html","index.xml","index.gif"]+-- | Returns True if the given String either starts with a . or is of the form+-- "foo/.bar", e.g. the typical *nix convention for hidden files.+isDot :: String -> Bool+isDot = isD . reverse+    where+    isD ('.':'/':_) = True+    isD ['.']       = True+    --isD ('/':_)     = False+    isD (_:cs)      = isD cs+    isD []          = False +-- * Low-level functions for generating a Response --- | Serve a file (lazy version). For efficiency reasons when serving large--- files, will escape the computation early if a file is successfully served,--- to prevent filters from being applied; if a filter were applied, we would--- need to compute the content-length (thereby forcing the spine of the--- ByteString into memory) rather than reading it from the filesystem.+-- | Use sendFile to send the contents of a Handle+sendFileResponse :: String  -- ^ content-type string+                 -> FilePath  -- ^ file path for content to send+                 -> Maybe (CalendarTime, Request) -- ^ mod-time for the handle (MUST NOT be later than server's time of message origination), incoming request (used to check for if-modified-since header)+                 -> Integer -- ^ offset into Handle+                 -> Integer -- ^ number of bytes to send+                 -> Response+sendFileResponse ct filePath mModTime _offset count =+    let res = ((setHeader "Content-Length" (show count)) .+               (setHeader "Content-Type" ct) $ +               (SendFile 200 Map.empty nullRsFlags{rsfContentLength=False} Nothing filePath 0 count)+              )+    in case mModTime of+         Nothing -> res+         (Just (modTime, request)) -> ifModifiedSince modTime request res++-- | Send the contents of a Lazy ByteString+lazyByteStringResponse :: String   -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@)+                       -> L.ByteString   -- ^ lazy bytestring content to send+                       -> Maybe (CalendarTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header)+                       -> Integer -- ^ offset into the bytestring+                       -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring)+                       -> Response+lazyByteStringResponse ct body mModTime offset count =+    let res = ((setHeader "Content-Type" ct) $+               resultBS 200 (L.take (fromInteger count) $ (L.drop (fromInteger offset))  body)+              )+    in case mModTime of+         Nothing -> res+         (Just (modTime, request)) -> ifModifiedSince modTime request res++-- | Send the contents of a Lazy ByteString+strictByteStringResponse :: String   -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@)+                         -> S.ByteString   -- ^ lazy bytestring content to send+                         -> Maybe (CalendarTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header)+                         -> Integer -- ^ offset into the bytestring+                         -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring)+                         -> Response+strictByteStringResponse ct body mModTime offset count =+    let res = ((setHeader "Content-Type" ct) $+               resultBS 200 (L.fromChunks [S.take (fromInteger count) $ S.drop (fromInteger offset) body])+              )+    in case mModTime of+         Nothing -> res+         (Just (modTime, request)) -> ifModifiedSince modTime request res++-- | Send the specified file with the specified mime-type using sendFile() ----- Note that using lazy fileServe can result in some filehandles staying open--- until the garbage collector gets around to closing them.-fileServe :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m) =>-             [FilePath]         -- ^ index files if the path is a directory-          -> FilePath           -- ^ file/directory to serve-          -> m Response-fileServe ixFiles localpath = do-    resp <- fileServe' localpath-                       (doIndex (ixFiles++defaultIxFiles))-                       mimeTypes-                       getFile+-- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'.+--+-- WARNING: No security checks are performed.+filePathSendFile :: (ServerMonad m, MonadIO m)+                 => String   -- ^ content-type string+                 -> FilePath -- ^ path to file on disk+                 -> m Response+filePathSendFile contentType fp =+    do handle  <- liftIO $ openBinaryFile fp ReadMode -- garbage collection should close this+       modtime <- liftIO $ getModificationTime fp+       count   <- liftIO $ hFileSize handle+       rq      <- askRq+       return $ sendFileResponse contentType fp (Just (toUTCTime modtime, rq)) 0 count -    escape' $ resp { rsFlags = RsFlags {rsfContentLength=False} }+-- | Send the specified file with the specified mime-type using Lazy ByteStrings+--+-- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'.+--+-- WARNING: No security checks are performed.+filePathLazy :: (ServerMonad m, MonadIO m)+                 => String   -- ^ content-type string+                 -> FilePath -- ^ path to file on disk+                 -> m Response+filePathLazy contentType fp =+    do handle  <- liftIO $ openBinaryFile fp ReadMode -- garbage collection should close this+       contents <- liftIO $ L.hGetContents handle+       modtime  <- liftIO $ getModificationTime fp+       count    <- liftIO $ hFileSize handle+       rq       <- askRq+       return $ lazyByteStringResponse contentType contents (Just (toUTCTime modtime, rq)) 0 count +-- | Send the specified file with the specified mime-type using Lazy ByteStrings+--+-- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'.+--+-- WARNING: No security checks are performed.+filePathStrict :: (ServerMonad m, MonadIO m)+                 => String   -- ^ content-type string+                 -> FilePath -- ^ path to file on disk+                 -> m Response+filePathStrict contentType fp =+    do contents <- liftIO $ S.readFile fp+       modtime  <- liftIO $ getModificationTime fp+       count    <- liftIO $ bracket (openBinaryFile fp ReadMode) hClose hFileSize+       rq       <- askRq+       return $ strictByteStringResponse contentType contents (Just (toUTCTime modtime, rq)) 0 count +-- * High-level functions for serving files --- | Serve a file (strict version). Reads the entire file strictly into--- memory, and ensures that the handle is properly closed. Unlike lazy--- fileServe, this function doesn't shortcut the computation early, and it--- allows for filtering (ex: gzip compression) to be applied-fileServeStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-                   [FilePath]   -- ^ index files if the path is a directory-                -> FilePath     -- ^ file/directory to serve-                -> m Response-fileServeStrict ixFiles localpath = do-    resp <- fileServe' localpath-                       (doIndex (ixFiles++defaultIxFiles))-                       mimeTypes-                       getFileStrict -    -- clear "Content-Length" because it could be modified by filters-    -- downstream-    let headers = rsHeaders resp-    return $ resp {rsHeaders = Map.delete (P.pack "content-length") headers}+-- ** Serve a single file +-- | Serve a single, specified file.+-- +-- example 1:+-- +--  Serve using sendfile() and the specified content-type+--+-- > serveFileUsing filePathSendFile (asContentType "image/jpeg") "/srv/data/image.jpg"+--+--+-- example 2:+-- +--  Serve using a lazy ByteString and the guess the content-type from the extension+-- +-- > serveFileUsing filePathLazy (guessContentTypeM mimeTypes) "/srv/data/image.jpg"+-- +-- WARNING: No security checks are performed.+serveFileUsing :: (ServerMonad m, FilterMonad Response m, MonadIO m) +               => (String -> FilePath -> m Response) -- ^ typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict'+               -> (FilePath -> m String)  -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM'+               -> FilePath -- ^ path to the file to serve+               -> m Response+serveFileUsing serveFn mimeFn fp = +    do fe <- liftIO $ doesFileExist fp+       if fe+          then do mt <- mimeFn fp+                  serveFn mt fp+          else fileNotFound fp +-- | Alias for 'serveFileUsing' 'filePathSendFile'+serveFile :: (ServerMonad m, FilterMonad Response m, MonadIO m) => (FilePath -> m String) -> FilePath -> m Response+serveFile = serveFileUsing filePathSendFile --- | Serve files with a mime type map under a directory.---   Uses the function to transform URIs to FilePaths.-fileServe' :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-              String-              -> (Map.Map String String -> String -> m Response)-              -> Map.Map String String-              -> GetFileFunc-              -> m Response-fileServe' localpath fdir mime getFileFunc = do+-- ** Serve files from a directory++-- | Serve files from a directory and it's subdirectories (parameterizable version)+-- +-- Parameterize this function to create functions like, 'fileServe', 'fileServeLazy', and 'fileServeStrict'+--+-- You supply:+--+--  1. a low-level function which takes a content-type and 'FilePath' and generates a Response+--  2. a function which determines the content-type from the 'FilePath'+--  3. a list of all the default index files+--+-- NOTE: unlike fileServe, there are no index files by default. See 'defaultIxFiles'.+fileServe' :: ( WebMonad Response m+              , ServerMonad m+              , FilterMonad Response m+              , MonadIO m+              ) +           => (String -> FilePath -> m Response) -- ^ function which takes a content-type and filepath and generates a response (typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict')+           -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath+           -> [FilePath]         -- ^ index files if the path is a directory+           -> FilePath           -- ^ file/directory to serve+           -> m Response+fileServe' serveFn mimeFn ixFiles localpath = do     rq <- askRq-    let fp2 = takeWhile (/=',') fp-        fp = filepath-        safepath = filter (\x->not (null x) && head x /= '.') (rqPaths rq)-        filepath = intercalate "/"  (localpath:safepath)-        fp' = if null safepath then "" else last safepath-    if "TESTH" `isPrefixOf` fp'-        then renderResponse mime $ fakeFile $ (read $ drop 5 $ fp' :: Integer)-        else do+    let safepath = filter (\x->not (null x) && x /= ".." && x /= ".") (rqPaths rq)+        fp = joinPath  (localpath:safepath)     fe <- liftIO $ doesFileExist fp-    fe2 <- liftIO $ doesFileExist fp2     de <- liftIO $ doesDirectoryExist fp-    -- error $ "show ilepath: " ++show (fp,de)     let status | de   = "DIR"                | fe   = "file"-               | fe2  = "group"                | True = "NOT FOUND"     liftIO $ logM "Happstack.Server.HTTP.FileServe" DEBUG ("fileServe: "++show fp++" \t"++status)-    if de then fdir mime fp else do-    getFileFunc mime fp >>= flip either (renderResponse mime)-        (const $ returnGroup localpath mime safepath)---returnFile :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-              GetFileFunc -> Map.Map String String -> String -> m Response-returnFile getFileFunc mime fp =-    getFileFunc mime fp >>=  either fileNotFound (renderResponse mime)----- if fp has , separated then return concatenation with content-type of last--- and last modified of latest-tr :: (Eq a) => a -> a -> [a] -> [a]-tr a b = map (\x->if x==a then b else x)-ltrim :: String -> String-ltrim = dropWhile (flip elem " \t\r")--returnGroup :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-               String -> Map.Map String String -> [String] -> m Response-returnGroup localPath mime fp = do-  let fps0 = map ((:[]). ltrim) $ lines $ tr ',' '\n' $ last fp-      fps = map (intercalate "/" . ((localPath:init fp) ++)) fps0--  -- if (head $ head fps0)=="TEST" then   renderResponse mime rq fakeFile else do--  mbFiles <-  mapM (getFile mime) $ fps-  let notFounds = [x | Left x <- mbFiles]-      files = [x | Right x <- mbFiles]-  if not $ null notFounds-    then fileNotFound $ drop (length localPath) $ head notFounds else do-  let totSize = sum $ map (snd . fst) files-      maxTime = maximum $ map (fst . fst) files :: ClockTime--  renderResponse mime ((maxTime,totSize),(fst $ snd $ head files,-                                             L.concat $ map (snd . snd) files))----fileNotFound :: (Monad m, FilterMonad Response m) => String -> m Response-fileNotFound fp = return $ result 404 $ "File not found " ++ fp-----fakeLen = 71* 1024-fakeFile :: (Integral a) =>-            a -> ((ClockTime, Int64), (String, L.ByteString))-fakeFile fakeLen = ((TOD 0 0,L.length body),("text/javascript",body))-    where-      body = L.pack $ (("//"++(show len)++" ") ++ ) $ (replicate len '0') ++ "\n"-      len = fromIntegral fakeLen---- | @getFile mimeMap path@ will lazily read the file as a ByteString--- with a content type provided by matching the file extension with the--- @mimeMap@.  getFile will return an error string or ((timeFetched,size), (contentType,fileContents))-getFile :: (MonadIO m) =>-           Map.Map String String-           -> String-           -> m (Either String ((ClockTime, Integer), (String, L.ByteString)))-getFile mime fp = do-  let ct = Map.findWithDefault "text/plain" (getExt fp) mime-  fe <- liftIO $ doesFileExist fp-  if not fe then return $ Left fp else do--  time <- liftIO $ getModificationTime fp-  h    <- liftIO $ openBinaryFile fp ReadMode-  size <- liftIO $ hFileSize h-  lbs  <- liftIO $ L.hGetContents h-  return $ Right ((time,size),(ct,lbs))---- | As 'getFile' but strictly fetches the file, instead of lazily.-getFileStrict :: (MonadIO m) =>-                 Map.Map String String-              -> String-              -> m (Either String ((ClockTime, Integer), (String, L.ByteString)))-getFileStrict mime fp = do-  let ct = Map.findWithDefault "text/plain" (getExt fp) mime-  fe     <- liftIO $ doesFileExist fp--  if not fe then return $ Left fp else do--  time     <- liftIO $ getModificationTime fp-  s        <- liftIO $ P.readFile fp-  let lbs  = L.fromChunks [s]-  let size = toInteger . P.length $ s-  return $ Right ((time,size),(ct,lbs))---renderResponse :: (Monad m,-                   ServerMonad m,-                   FilterMonad Response m,-                   Show t1) =>-                  t-                  -> ((ClockTime, t1), (String, L.ByteString))-                  -> m Response-renderResponse _ ((modtime,size),(ct,body)) = do-  rq <- askRq-  let notmodified = getHeader "if-modified-since" rq == Just (P.pack $ repr)-      repr = formatCalendarTime defaultTimeLocale-             "%a, %d %b %Y %X GMT" (toUTCTime modtime)-  -- "Mon, 07 Jan 2008 19:51:02 GMT"-  -- when (isJust $ getHeader "if-modified-since"  rq) $ error $ show $ getHeader "if-modified-since" rq-  if notmodified then-      return $ result 304 ""-    else do-      return $ ((setHeader "Last-modified" repr) .-                (setHeader "Content-Length" (show size)) .-                (setHeader "Content-Type" ct)) $-               resultBS 200 body+    if de+        then if last (rqUri rq) == '/'+             then doIndex' serveFn mimeFn (ixFiles++defaultIxFiles) fp+             else do let path' = addTrailingPathSeparator (rqUri rq)+                     seeOther path' (toResponse path')+        else if fe +                then serveFileUsing serveFn mimeFn fp+                else fileNotFound fp +-- | Serve files from a directory and it's subdirectories (sendFile version). Should perform much better than its predecessors.+fileServe :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m) =>+             [FilePath]         -- ^ index files if the path is a directory+          -> FilePath           -- ^ file/directory to serve+          -> m Response+fileServe ixFiles localPath = fileServe' filePathSendFile (guessContentTypeM mimeTypes) (ixFiles ++ defaultIxFiles) localPath +-- | Serve files from a directory and it's subdirectories (lazy ByteString version).+-- +-- May leak file handles.+fileServeLazy :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m) =>+             [FilePath]         -- ^ index files if the path is a directory+          -> FilePath           -- ^ file/directory to serve+          -> m Response+fileServeLazy ixFiles localPath = fileServe' filePathLazy (guessContentTypeM mimeTypes) (ixFiles ++ defaultIxFiles) localPath +-- | Serve files from a directory and it's subdirectories (strict ByteString version). +fileServeStrict :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m) =>+             [FilePath]         -- ^ index files if the path is a directory+          -> FilePath           -- ^ file/directory to serve+          -> m Response+fileServeStrict ixFiles localPath = fileServe' filePathStrict (guessContentTypeM mimeTypes) (ixFiles ++ defaultIxFiles) localPath -getExt :: String -> String-getExt = reverse . takeWhile (/='.') . reverse+-- * Index --- | Ready collection of common mime types.-mimeTypes :: MimeMap-mimeTypes = Map.fromList-	    [("xml","application/xml")-	    ,("xsl","application/xml")-	    ,("js","text/javascript")-	    ,("html","text/html")-	    ,("htm","text/html")-	    ,("css","text/css")-	    ,("gif","image/gif")-	    ,("jpg","image/jpeg")-	    ,("png","image/png")-	    ,("txt","text/plain")-	    ,("doc","application/msword")-	    ,("exe","application/octet-stream")-	    ,("pdf","application/pdf")-	    ,("zip","application/zip")-	    ,("gz","application/x-gzip")-	    ,("ps","application/postscript")-	    ,("rtf","application/rtf")-	    ,("wav","application/x-wav")-	    ,("hs","text/plain")]+doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m)+        => [String]+        -> MimeMap+        -> String+        -> m Response+doIndex ixFiles mimeMap localPath = doIndex' filePathSendFile (guessContentTypeM mimeMap) ixFiles localPath +doIndexLazy :: (ServerMonad m, FilterMonad Response m, MonadIO m)+        => [String]+        -> MimeMap+        -> String+        -> m Response+doIndexLazy ixFiles mimeMap localPath = doIndex' filePathLazy (guessContentTypeM mimeMap) ixFiles localPath --- | Prevents files of the form '.foo' or 'bar/.foo' from being served-blockDotFiles :: (Request -> IO Response) -> Request -> IO Response-blockDotFiles fn rq-    | isDot (intercalate "/" (rqPaths rq)) = return $ result 403 "Dot files not allowed."-    | otherwise = fn rq+doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m)+        => [String]+        -> MimeMap+        -> String+        -> m Response+doIndexStrict ixFiles mimeMap localPath = doIndex' filePathStrict (guessContentTypeM mimeMap) ixFiles localPath --- | Returns True if the given String either starts with a . or is of the form--- "foo/.bar", e.g. the typical *nix convention for hidden files.-isDot :: String -> Bool-isDot = isD . reverse-    where-    isD ('.':'/':_) = True-    isD ['.']       = True-    --isD ('/':_)     = False-    isD (_:cs)      = isD cs-    isD []          = False+doIndex' :: (ServerMonad m, FilterMonad Response m, MonadIO m)+        => (String -> FilePath -> m Response)+        -> (FilePath -> m String)+        -> [String]+        -> String+        -> m Response+doIndex' _serveFn _mime  []          _fp = forbidden $ toResponse "Directory index forbidden"+doIndex'  serveFn mimeFn (index:rest) fp =+    do let path = fp </> index+       fe <- liftIO $ doesFileExist path+       if fe +          then serveFileUsing serveFn mimeFn path +          else doIndex' serveFn mimeFn rest fp

@@ -33,6 +33,8 @@ import Happstack.Util.TimeOut import Happstack.Util.LogFormat (formatRequestCombined) import Data.Time.Clock (getCurrentTime)+import Network.Socket (Socket, fdSocket)+import Network.Socket.SendFile (unsafeSendFile') import System.Log.Logger (Priority(..), logM)  request :: Conf -> Handle -> Host -> (Request -> IO Response) -> IO ()@@ -84,18 +86,7 @@                          user = "-"                          requestLn = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req]                          responseCode = rsCode res-                         sendContentLength = rsfContentLength (rsFlags res)--                         -- don't force the bytestring if "sendContentLength"-                         -- is false, at least not if a content-length header-                         -- has been set-                         size = if not sendContentLength then-                                    maybe (toInteger $ L.length $ rsBody res)-                                          ((read . P.unpack) :: P.ByteString -> Integer)-                                          (getHeaderBS contentLengthC req)-                                  else-                                    toInteger $ L.length $ rsBody res-+                         size = maybe (-1) (read . B.unpack) (getHeader "Content-Length" res) -- -1 indicates unknown size                          referer = B.unpack $ fromMaybe (B.pack "") $ getHeader "Referer" req                          userAgent = B.unpack $ fromMaybe (B.pack "") $ getHeader "User-Agent" req                      logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host' user time requestLn responseCode size referer userAgent@@ -192,29 +183,45 @@     foldr (uncurry setHeaderBS) (mkHeaders [])     [ (serverC, happsC), (contentTypeC, textHtmlC) ] +-- FIXME: we should not be controlling the response headers in mysterious ways in this low level code+-- headers should be set by application code and the core http engine should be very lean. putAugmentedResult :: Handle -> Request -> Response -> IO ()-putAugmentedResult h req res = do-  let ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs-  raw <- getApproximateTime-  let cl = L.length $ rsBody res-  let put = P.hPut h-  -- TODO: Hoist static headers to the toplevel.-  let stdHeaders = staticHeaders `M.union`-                   M.fromList ( [ (dateCLower,       HeaderPair dateC [raw])-                                , (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC])-                                ] ++ if rsfContentLength (rsFlags res)-                                     then [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])]-                                     else [] )-      allHeaders = rsHeaders res `M.union` stdHeaders  -- 'union' prefers 'headers res' when duplicate keys are encountered.+putAugmentedResult outp req res = do+    case res of+        -- standard bytestring response+        Response {} -> do+            sendTop (fromIntegral (L.length (rsBody res)))+            when (rqMethod req /= HEAD) (L.hPut outp $ rsBody res)+        -- zero-copy sendfile response+        -- the handle *should* be closed by the garbage collector+        SendFile {} -> do+            let infp = sfFilePath res+                off = sfOffset res+                count = sfCount res+            sendTop count+            unsafeSendFile' outp infp off count+    hFlush outp+    where ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs+          sendTop cl = do+              allHeaders <- augmentHeaders req res cl+              mapM_ (P.hPut outp) $ concat+                [ (pversion $ rqVersion req)          -- Print HTTP version+                , [responseMessage $ rsCode res]      -- Print responseCode+                , concatMap ph (M.elems allHeaders)   -- Print all headers+                , [crlfC]+                ] -  mapM_ put $ concat-    [ (pversion $ rqVersion req)          -- Print HTTP version-    , [responseMessage $ rsCode res]      -- Print responseCode-    , concatMap ph (M.elems allHeaders)   -- Print all headers-    , [crlfC]-    ]-  when (rqMethod req /= HEAD) $ L.hPut h $ rsBody res-  hFlush h+augmentHeaders :: Request -> Response -> Integer -> IO Headers+augmentHeaders req res cl = do+    -- TODO: Hoist static headers to the toplevel.+    raw <- getApproximateTime+    let stdHeaders = staticHeaders `M.union`+          M.fromList ( [ (dateCLower,       HeaderPair dateC [raw])+                       , (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC])+                       ] ++ if rsfContentLength (rsFlags res)+                              then [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])]+                              else [] )+    return (rsHeaders res `M.union` stdHeaders) -- 'union' prefers 'headers res' when duplicate keys are encountered.  -- | Serializes the request to the given handle putRequest :: Handle -> Request -> IO ()

@@ -1,12 +1,12 @@ {-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}-module Happstack.Server.HTTP.Listen(listen) where+module Happstack.Server.HTTP.Listen(listen, listen') where  import Happstack.Server.HTTP.Types import Happstack.Server.HTTP.Handler import Happstack.Server.HTTP.Socket (acceptLite) import Control.Exception.Extensible as E import Control.Concurrent-import Network(PortID(..), listenOn, sClose)+import Network(PortID(..), listenOn, sClose, Socket) import System.IO {- #ifndef mingw32_HOST_OS@@ -19,8 +19,16 @@ log':: Priority -> String -> IO () log' = logM "Happstack.Server.HTTP.Listen" +-- | Bind and listen port listen :: Conf -> (Request -> IO Response) -> IO () listen conf hand = do+    let port' = port conf+    socket <- listenOn (PortNumber $ toEnum port')+    listen' socket conf hand++-- | Use a previously bind port and listen+listen' :: Socket -> Conf -> (Request -> IO Response) -> IO ()+listen' s conf hand = do {- #ifndef mingw32_HOST_OS -}@@ -30,7 +38,6 @@ -}   let port' = port conf   log' NOTICE ("Listening on port " ++ show port')-  s <- listenOn $ PortNumber $ toEnum port'   let work (h,hn,p) = do -- hSetBuffering h NoBuffering                          let eh (x::SomeException) = log' ERROR ("HTTP request failed with: "++show x)                          request conf h (hn,fromIntegral p) hand `E.catch` eh

@@ -8,9 +8,8 @@  -- find out at compile time if the SockAddr6 / HostAddress6 constructors are available supportsIPv6 :: Bool-supportsIPv6 = $(let c = "Network.Socket.SockAddrInet6"; d = ''SockAddr in+supportsIPv6 = $(let c = ["Network.Socket.SockAddrInet6", "Network.Socket.Internal.SockAddrInet6"] ; d = ''SockAddr in                  do TyConI (DataD _ _ _ cs _) <- reify d-                    if isJust (find (\(NormalC n _) -> show n == c) cs)+                    if isJust (find (\(NormalC n _) -> show n `elem` c) cs)                        then [| True |]                        else [| False |] )-                       

@@ -29,6 +29,7 @@ import Happstack.Server.Cookie import Data.List import Text.Show.Functions ()+import System.IO (Handle)  -- | HTTP version data Version = Version Int Int@@ -90,12 +91,21 @@  type Host = (String,Int) -data Response  = Response  { rsCode    :: Int,-                             rsHeaders :: Headers,-                             rsFlags   :: RsFlags,-                             rsBody    :: L.ByteString,-                             rsValidator:: Maybe (Response -> IO Response)-                           } deriving (Show,Typeable) +data Response  = Response  { rsCode      :: Int,+                             rsHeaders   :: Headers,+                             rsFlags     :: RsFlags,+                             rsBody      :: L.ByteString,+                             rsValidator :: Maybe (Response -> IO Response)+                           }+               | SendFile  { rsCode      :: Int,+                             rsHeaders   :: Headers,+                             rsFlags     :: RsFlags,+                             rsValidator :: Maybe (Response -> IO Response),+                             sfFilePath  :: FilePath,  -- file handle to send from+                             sfOffset    :: Integer, -- offset to start at+                             sfCount     :: Integer  -- number of bytes to send+                           }+               deriving (Show,Typeable)   data Request = Request { rqMethod  :: Method,                          rqPaths   :: [String],@@ -108,7 +118,6 @@                          rqBody    :: RqBody,                          rqPeer    :: Host                        } deriving(Show,Read,Typeable)-  -- | Converts a Request into a String representing the corresponding URL rqURL :: Request -> String

@@ -18,7 +18,7 @@                                xs    -> xs)  bodyInput :: Request -> [(String, Input)]-bodyInput req | rqMethod req /= POST = []+bodyInput req | (rqMethod req /= POST) && (rqMethod req /= PUT) = [] bodyInput req =     let ctype = getHeader "content-type" req >>= parseContentType . P.unpack         getBS (Body bs) = bs

@@ -137,7 +137,7 @@                  encoding1 :: GenParser Char st ([Char], Maybe Double)         encoding1 = do-            encoding <- many1 alphaNum <|> string "*"+            encoding <- many1 (alphaNum <|> char '-') <|> string "*"             ws             quality<-optionMaybe qual             return (encoding, fmap read quality)

@@ -1,240 +0,0 @@-{-# LANGUAGE PatternGuards #-}-module Happstack.Server.S3-    ( newS3        -- :: AccessKey -> SecretKey -> URI -> IO S3-    , closeS3      -- :: S3 -> IO ()-    , createBucket -- :: S3 -> BucketId -> IO ()-    , createObject -- :: S3 -> BucketId -> ObjectId -> String -> IO ()-    , getObject    -- :: S3 -> BucketId -> ObjectId -> IO String-    , deleteBucket -- :: S3 -> BucketId -> IO ()-    , deleteObject -- :: S3 -> BucketId -> ObjectId -> IO ()-    , listObjects  -- :: S3 -> BucketId -> IO [String]-    , sendRequest  -- :: S3 -> Request -> IO String-    , sendRequest_ -- :: S3 -> Request -> IO ()---    , sendRequests -- :: S3 -> [Request] -> IO ()-    , BucketId, ObjectId, AccessKey, SecretKey-    , amazonURI-    ) where--import Happstack.Crypto.HMAC             ( hmacSHA1 )-import Happstack.Server.HTTPClient.HTTP-import qualified Happstack.Server.HTTPClient.Stream as Stream--import Network.URI hiding (path)-import Control.Concurrent               ( newMVar, modifyMVar, swapMVar-                                        , modifyMVar_, MVar )-import Data.Maybe                       ( fromJust, fromMaybe )-import Data.List                        ( intersperse )-import System.Time                      ( getClockTime, toCalendarTime-                                        , formatCalendarTime )-import System.Locale                    ( defaultTimeLocale, rfc822DateFormat )--import Text.XML.HaXml                   ( xmlParse, Document(..), Content(..) )-import Text.XML.HaXml.Xtract.Parse      ( xtract )--type BucketId = String-type ObjectId = String-type AccessKey = String-type SecretKey = String--data S3-    = S3-    { s3AccessKey        :: AccessKey-    , s3SecretKey        :: SecretKey-    , s3URI              :: URI---    , s3KeepAliveTimeout :: Int-    , s3Conn             :: MVar (Maybe Connection)-    }--{- |-  Sign a request using the access key and secret key from the S3 data-  type.--}-signRequest :: S3 -> Request -> IO Request-signRequest s3-    = let akey = s3AccessKey s3-          skey = s3SecretKey s3-      in signRequest' akey skey--{- |-  Fill in necessary information (such as a date header) and then sign-  then request.--}-signRequest' :: AccessKey -> SecretKey -> Request -> IO Request-signRequest' akey skey request-    = do now <- getClockTime-         cal <- toCalendarTime now-         let isoDate = formatCalendarTime defaultTimeLocale rfc822DateFormat cal-             auth = fromJust (uriAuthority (rqURI request))---             authErr = error "S3.hs: internal error: failed to parse authority"-         let dat = concat $ intersperse "\n"-                   [show (rqMethod request)-                   ,lookupHeader HdrContentMD5-                   ,lookupHeader HdrContentType-                   ,isoDate-                   ,uriPath (rqURI request)]-             authorization = Header HdrAuthorization $ "AWS " ++ akey ++ ":" ++ signature-             signature = hmacSHA1 skey dat-             lookupHeader hn = fromMaybe "" (findHeader hn request)-             dateHdr = Header HdrDate isoDate-             lengthHdr = Header HdrContentLength (show $ length (rqBody request))-             connHdr = Header HdrConnection "Keep-Alive"-             hostHdr = Header HdrHost (uriRegName auth)-         return $ request-                    { rqHeaders = hostHdr:connHdr:lengthHdr:dateHdr:-                                  authorization:rqHeaders request-                    , rqURI = (rqURI request) { uriScheme = ""-                                              , uriAuthority = Nothing}}--{- |-  Return a connection to an S3 server. Will initiate a new-  connection if no previous was found.--}-getConnection :: S3 -> IO Connection-getConnection s3-    = modifyMVar (s3Conn s3) $ \mbConn ->-      case mbConn of-        Just conn -> return (mbConn,conn)-        Nothing -> do print (uriRegName auth, uriPort auth)-                      c <- openTCPPort (uriRegName auth) (if null $ uriPort auth then 80 else read$ uriPort auth)-                      return (Just c,c)-    where auth = fromJust (uriAuthority (s3URI s3))--createRequest :: S3 -> RequestMethod -> String -> String -> Request-createRequest _s3 method path body-    = Request uri method [] body-    where uri = localhost { uriPath = '/':escapeURIString isAllowedInURI path }--{- |-  Send a single request to an S3 server returning the body-  of the result.--}-sendRequest :: S3 -> Request -> IO String-sendRequest s3 request-    = loop =<< signRequest s3 request-    where loop request'-              = do c <- getConnection s3-                   ret <- sendHTTP c request'-                   case ret of-                     Left ErrorClosed-                         -> do putStrLn "Connection closed."-                               swapMVar (s3Conn s3) Nothing-                               loop request'-                     Left err  -> error ("Failed to connect: " ++ show err) -- FIXME-                     Right res-                         | (2,_,_) <- rspCode res -> return (rspBody res)-                         | otherwise -> error ("Server error: " ++ rspReason res)--{- |-  Same as 'sendRequest' except that it ignored the result.--}-sendRequest_ :: S3 -> Request -> IO ()-sendRequest_ s3 request-    = do sendRequest s3 request-         return ()--{--  Sign and send requests pipelined over a keep-alive connection.--}-{--  S3 imposes a quite severe limitation on pipelined requests.-  Sending too many requests or exceeding a size limit will-  result in a disconnect. The precise borders of these limits-  are hard-wired and unknown to the general public. At the time-  of this writing, sending three requests at a time seems optimal.--  Quote from Amazons web-forum:-  (http://developer.amazonwebservices.com/connect/thread.jspa?messageID=39883)-  "OK, we have located the cause of the behavior you are seeing.-   Your pipelined requests are being aborted because one of the-   network devices handling the connection has certain limitations-   on the amount of pipelined data it is willing to accept per-   connection, and that limit is being exceeded. Unfortunately, this-   limit is phrased in very low-level terms so it isn't possible to-   say in a platform or network independent way whether any given-   size, sequence or number of requests will exceed the limit and-   cause a disconnection or not. We have engaged with the device-   vendor and found out that this limit is hard-wired and that this-   behavior is not likely to change any time soon.--   In light of these facts, here is some guidance on pipelining HTTP-   requests to Amazon S3.-    1) Be optimistic and pipeline a modest number of GET or HEAD-       requests, say two to four.-    2) Handle asynchronous disconnects by re-connecting and re-sending-       unacknowledged requests left in your pipeline. (As Colin points-       out, correct HTTP clients must do this anyway)-    3) If possible, try to minimize the number of TCP segments your-       pipelined requests generate. In particular, leave the TCP socket-       no delay option off and send as many requests per socket write call-       as is practical."--}------------------------------------------------------------------- Initiate-----------------------------------------------------------------newS3 :: AccessKey -> SecretKey -> URI -> IO S3-newS3 akey skey uri-    = do conn <- newMVar Nothing-         return $ S3 { s3AccessKey = akey-                     , s3SecretKey = skey-                     , s3URI       = uri---                     , s3KeepAliveTimeout :: Int-                     , s3Conn      = conn-                     }--closeS3 :: S3 -> IO ()-closeS3 s3-    = modifyMVar_ (s3Conn s3) $ \mbConn ->-      case mbConn of-        Nothing -> return Nothing-        Just conn -> do Stream.close conn-                        return Nothing-------------------------------------------------------------------- Requests------------------------------------------------------------------createBucket :: S3 -> BucketId -> Request-createBucket s3 bucket-    = createRequest s3 PUT bucket ""--createObject :: S3 -> BucketId -> ObjectId -> String -> Request-createObject s3 bucket object-    = createRequest s3 PUT (bucket ++ "/" ++ object)--getObject :: S3 -> BucketId -> ObjectId -> Request-getObject s3 bucket object-    = createRequest s3 GET (bucket ++ "/" ++ object) ""--deleteBucket :: S3 -> BucketId -> Request-deleteBucket s3 bucket-    = createRequest s3 DELETE bucket ""--deleteObject :: S3 -> BucketId -> ObjectId -> Request-deleteObject s3 bucket object-    = createRequest s3 DELETE (bucket ++ "/" ++ object) ""------------------------------------------------------------------- Actions------------------------------------------------------------------listObjects :: S3 -> BucketId -> IO [String]-listObjects s3 bucket-    = do lst <- sendRequest s3 (createRequest s3 GET bucket "")-         return $ ppContent . auxFilter . getContent . xmlParse bucket $ lst-    where auxFilter = xtract "*/Key/-"-          getContent (Document _ _ e _) = CElem e--          ppContent xs  = [ s | CString _ s <- xs ]----amazonURI :: URI-amazonURI = fromJust $ parseURI "http://s3.amazonaws.com/"-localhost :: URI-localhost = fromJust $ parseURI "http://localhost/"-

@@ -28,7 +28,7 @@ -- like CGI\/FastCGI can used if so desired. -- -- So the general nature of 'simpleHTTP' is no different than what you'd expect--- from a web application container.  First you figure out when function is+-- from a web application container.  First you figure out which function is -- going to process your request, process the request to generate a response, -- then return that response to the client. The web application container is -- started with 'simpleHTTP', which takes a configuration and a@@ -108,6 +108,10 @@     -- * SimpleHTTP     , simpleHTTP     , simpleHTTP'+    , simpleHTTP''+    , simpleHTTPWithSocket+    , simpleHTTPWithSocket'+    , bindPort     , parseConfig     -- * ServerPartT     , ServerPartT(..)@@ -162,10 +166,13 @@     , addCookies     , addHeaderM     , setHeaderM+    , ifModifiedSince       -- * guards and building blocks     , guardRq     , dir+    , host+    , withHost     , method     , methodSP     , methodM@@ -174,6 +181,7 @@     , path     , anyPath     , anyPath'+    , trailingSlash     , withData     , withDataFn     , getDataFn@@ -224,11 +232,12 @@ import Happstack.Server.HTTP.Client              (getResponse, unproxify, unrproxify) import Happstack.Data.Xml.HaXml                  (toHaXmlEl) import qualified Happstack.Server.MinHaXML       as H-import qualified Happstack.Server.HTTP.Listen    as Listen (listen) -- So that we can disambiguate 'Writer.listen'+import qualified Happstack.Server.HTTP.Listen    as Listen (listen, listen') -- So that we can disambiguate 'Writer.listen' import Happstack.Server.XSLT                     (XSLTCmd, XSLPath, procLBSIO) import Happstack.Server.SURI                     (ToSURI) import Happstack.Util.Common                     (Seconds, readM) import Happstack.Data                            (Xml, normalize, fromPairs, Element, toXml, toPublicXml) -- used by default implementation of fromData+import Network                                   (listenOn, PortID(..), Socket) import Control.Applicative                       (Applicative, pure, (<*>)) import Control.Concurrent                        (forkIO) import Control.Exception                         (evaluate)@@ -252,6 +261,7 @@ import Control.Monad.Error                       ( ErrorT(ErrorT), runErrorT                                                  , Error, strMsg                                                  , MonadError, throwError, catchError+                                                 , mapErrorT                                                  ) import Control.Monad.Maybe                       (MaybeT(MaybeT), runMaybeT) import Data.Char                                 (ord)@@ -280,7 +290,9 @@                                                  , ArgOrder(Permute)                                                  , getOpt                                                  )+import System.Locale                             (defaultTimeLocale) import System.Process                            (runInteractiveProcess, waitForProcess)+import System.Time                               (CalendarTime, formatCalendarTime) import System.Exit                               (ExitCode(ExitSuccess, ExitFailure))  -- | An alias for WebT when using IO@@ -399,6 +411,10 @@     askRq = ServerPartT $ ask     localRq f m = ServerPartT $ local f (unServerPartT m) +instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where+    askRq     = lift askRq+    localRq f = mapErrorT $ localRq f+ ------------------------------- -- HERE BEGINS WebT definitions @@ -412,7 +428,7 @@ -- @ -- -- A simple way of sumerizing this is, if the right side is Append, then the--- right is appended to the left.  If the right side is Set, then the right side+-- right is appended to the left.  If the right side is Set, then the left side -- is ignored.  data SetAppend a = Set a | Append a@@ -676,7 +692,7 @@ simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO () simpleHTTP = simpleHTTP' id --- | a combination of simpleHTTP and 'mapServerPartT'.  See 'mapServerPartT' for a discussion+-- | a combination of simpleHTTP'' and 'mapServerPartT'.  See 'mapServerPartT' for a discussion -- of the first argument of this function. simpleHTTP' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)             -> Conf -> ServerPartT m a -> IO ()@@ -689,9 +705,36 @@ simpleHTTP'' :: (ToMessage b, Monad m, Functor m) => ServerPartT m b -> Request -> m Response simpleHTTP'' hs req =  (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id))     where-        standardNotFound = setHeader "Content-Type" "text/html" $ toResponse notFoundHtml+        standardNotFound = setHeader "Content-Type" "text/html" $ (toResponse notFoundHtml){rsCode=404} +-- | Run simpleHTTP with a previously bound socket. Useful if you want to run+-- happstack as user on port 80. Use something like this:+--+-- > import System.Posix.User (setUserID, UserEntry(..), getUserEntryForName)+-- >+-- > main = do+-- >     let conf = nullConf { port = 80 }+-- >     socket <- bindPort conf+-- >     -- do other stuff as root here+-- >     getUserEntryForName "www" >>= setUserID . userID+-- >     -- finally start handling incoming requests+-- >     tid <- forkIO $ socketSimpleHTTP socket conf impl+--+-- Note: It's important to use the same conf (or at least the same port) for+-- 'bindPort' and 'simpleHTTPWithSocket'.+simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO ()+simpleHTTPWithSocket = simpleHTTPWithSocket' id +-- | 'simpleHTTP'' with a socket+simpleHTTPWithSocket' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)+                      -> Socket -> Conf -> ServerPartT m a -> IO ()+simpleHTTPWithSocket' toIO socket conf hs =+    Listen.listen' socket conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))++-- | Bind port and return the socket for 'simpleHTTPWithSocket'+bindPort :: Conf -> IO Socket+bindPort conf = listenOn (PortNumber . toEnum . port $ conf)+ -- | This class is used by 'path' to parse a path component into a value. -- At present, the instances for number types (Int, Float, etc) just -- call 'readM'. The instance for 'String' however, just passes the@@ -870,6 +913,23 @@             (p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle             _ -> mzero +-- | Guard against the host+host :: (ServerMonad m, MonadPlus m) => String -> m a -> m a+host desiredHost handle =+    do rq <- askRq+       case getHeader "host" rq of+         (Just hostBS) | desiredHost == B.unpack hostBS -> handle+         _ -> mzero++-- | Lookup the host header and pass it to the handler+withHost :: (ServerMonad m, MonadPlus m) => (String -> m a) -> m a+withHost handle =+    do rq <- askRq+       case getHeader "host" rq of+         (Just hostBS) -> handle (B.unpack hostBS)+         _ -> mzero++ -- | Pop a path element and parse it using the 'fromReqURI' in the 'FromReqURI' class. path :: (FromReqURI a, MonadPlus m, ServerMonad m) => (a -> m b) -> m b path handle = do@@ -894,6 +954,11 @@ anyPath' = anyPath {-# DEPRECATED anyPath' "Use anyPath" #-} +-- | guard which checks that the Request URI ends in '\/'. +-- Useful for distinguishing between @foo@ and @foo/@+trailingSlash :: (ServerMonad m, MonadPlus m) => m ()+trailingSlash = guardRq $ \rq -> (last (rqUri rq)) == '/'+ -- | used to read parse your request with a RqData (a ReaderT, basically) -- For example here is a simple GET or POST variable based authentication -- guard.  It handles the request with errorHandler if authentication fails.@@ -987,7 +1052,7 @@ -- -- TODO: this would be more useful if it didn\'t call "escape", just like -- proxyServe'-rproxyServe :: (MonadIO m, WebMonad Response m) =>+rproxyServe :: (MonadIO m) =>     String -- ^ defaultHost     -> [(String, String)] -- ^ map to look up hostname mappings.  For the reverse proxy     -> ServerPartT m Response -- ^ the result is a ServerPartT that will reverse proxy for you.@@ -1050,6 +1115,21 @@ addCookies :: (FilterMonad Response m) => [(Seconds, Cookie)] -> m () addCookies = mapM_ (uncurry addCookie) +-- |honor if-modified-since header in Request+-- If the 'Request' includes the if-modified-since header and the+-- Response has not been modified, then return 304 (Not Modified),+-- otherwise return the 'Response'.+ifModifiedSince :: CalendarTime -- ^ mod-time for the Response (MUST NOT be later than server's time of message origination)+                -> Request -- ^ incoming request (used to check for if-modified-since)+                -> Response -- ^ Response to send if there are modifications+                -> Response+ifModifiedSince modTime request response =+    let repr = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %X GMT" modTime+        notmodified = getHeader "if-modified-since" request == Just (B.pack $ repr)+    in if notmodified+          then result 304 "" -- Not Modified+          else setHeader "Last-modified" repr response+ -- | same as setResponseCode status >> return val resp :: (FilterMonad Response m) => Int -> b -> m b resp status val = setResponseCode status >> return val@@ -1144,10 +1224,9 @@     parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6     headerName  = "WWW-Authenticate"     headerValue = "Basic realm=\"" ++ realmName ++ "\""-    err = do-        unauthorized ()-        setHeaderM headerName headerValue-        escape' $ toResponse "Not authorized"+    err = escape $ do+            setHeaderM headerName headerValue+            unauthorized $ toResponse "Not authorized"  -------------------------------------------------------------- -- Query/Post data validating

@@ -16,26 +16,34 @@     "cookieParserTest" ~:     [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2"         @?= (Right [-            Cookie "1" "/testpath" "example.com" "cookie1" "value1"-          , Cookie "1" "" "" "cookie2" "value2"+            Cookie "1" "/testpath" "example.com" "cookie1" "value1" False+          , Cookie "1" "" "" "cookie2" "value2" False           ])     ,parseCookies "  \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/  "         @?= (Right [-            Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|"+            Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|" False           ])     ,parseCookies " cookie1 = value1  "         @?= (Right [-            Cookie "" "" "" "cookie1" "value1"+            Cookie "" "" "" "cookie1" "value1" False           ])     ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe  "         @?= (Right [-            Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe"+            Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False           ])     ]  acceptEncodingParserTest :: Test acceptEncodingParserTest =     "acceptEncodingParserTest" ~:-    [either (Left . show) Right (parse encodings "" " gzip;q=1,*, compress ; q = 0.5 ")-        @?= (Right [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)])-    ]+    map (\(string, result) -> either (Left . show) Right (parse encodings "" string) @?= (Right result)) acceptEncodings+    where+      acceptEncodings =+       [ (" gzip;q=1,*, compress ; q = 0.5 ", [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)])+       , (" compress , gzip", [ ("compress", Nothing), ("gzip", Nothing)])+       , (" ", [])+       , (" *", [("*", Nothing)])+       , (" compress;q=0.5, gzip;q=1.0", [("compress", Just 0.5), ("gzip", Just 1.0)])+       , (" gzip;q=1.0, identity; q=0.5, *;q=0", [("gzip", Just 1.0), ("identity",Just 0.5), ("*", Just 0)])+       , (" x-gzip",[("x-gzip", Nothing)])+       ]