From 11c3854540c46bfcd9e88c2164ed554f3b6550a5 Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 3 Oct 2007 10:53:03 +0900 Subject: [PATCH] Say good bye to the ugliness of "text" "plain". darcs-hash:20071003015303-62b54-a6a9f98028f94790d6f88c9388d7f3c9ab0fb979.gz --- .boring | 2 + Lucu.cabal | 1 + Network/HTTP/Lucu.hs | 3 - Network/HTTP/Lucu/ContentCoding.hs | 46 +++ Network/HTTP/Lucu/MIMEType.hs | 36 +- .../HTTP/Lucu/MIMEType/DefaultExtensionMap.hs | 344 +++++++++--------- Network/HTTP/Lucu/MIMEType/Guess.hs | 20 +- Network/HTTP/Lucu/Resource.hs | 43 +-- data/Makefile | 2 + examples/HelloWorld.hs | 4 +- 10 files changed, 251 insertions(+), 250 deletions(-) create mode 100644 Network/HTTP/Lucu/ContentCoding.hs create mode 100644 data/Makefile diff --git a/.boring b/.boring index 3d85b5e..320eabe 100644 --- a/.boring +++ b/.boring @@ -53,3 +53,5 @@ ^Setup$ ^\.setup-config$ ^.installed-pkg-config$ + +^examples/HelloWorld$ diff --git a/Lucu.cabal b/Lucu.cabal index 0fb5c07..8eb1c62 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -39,6 +39,7 @@ Exposed-Modules: Network.HTTP.Lucu.Utils Other-Modules: Network.HTTP.Lucu.Chunk + Network.HTTP.Lucu.ContentCoding Network.HTTP.Lucu.DefaultPage Network.HTTP.Lucu.Format Network.HTTP.Lucu.Headers diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 9859e53..80012b0 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -61,9 +61,6 @@ module Network.HTTP.Lucu -- *** MIME Type , MIMEType(..) - , () - , (<:>) - , (<=>) -- * Utility diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs new file mode 100644 index 0000000..37adda3 --- /dev/null +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -0,0 +1,46 @@ +module Network.HTTP.Lucu.ContentCoding + ( acceptEncodingListP + , normalizeCoding + , unnormalizeCoding + , orderAcceptEncodings + ) + where + +import Data.Char +import Data.Maybe +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Parser.Http + + +acceptEncodingListP :: Parser [(String, Maybe Double)] +acceptEncodingListP = allowEOF $! listOf accEncP + + +accEncP :: Parser (String, Maybe Double) +accEncP = do coding <- token + qVal <- option Nothing + $ do string ";q=" + q <- qvalue + return $ Just q + return (normalizeCoding coding, qVal) + + +normalizeCoding :: String -> String +normalizeCoding coding + = case map toLower coding of + "x-gzip" -> "gzip" + "x-compress" -> "compress" + other -> other + + +unnormalizeCoding :: String -> String +unnormalizeCoding coding + = case map toLower coding of + "gzip" -> "x-gzip" + "compress" -> "x-compress" + other -> other + + +orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering +orderAcceptEncodings (_, q1) (_, q2) + = fromMaybe 0 q1 `compare` fromMaybe 0 q2 diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 9f65323..396a164 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -3,9 +3,7 @@ -- |Manipulation of MIME Types. module Network.HTTP.Lucu.MIMEType ( MIMEType(..) - , () - , (<:>) - , (<=>) + , parseMIMEType , mimeTypeP , mimeTypeListP ) @@ -40,31 +38,15 @@ instance Show MIMEType where value -infix 9 , <=> -infixl 8 <:> +instance Read MIMEType where + readsPrec _ s = [(parseMIMEType s, "")] --- |@\"major\" \<\/\> \"minor\"@ constructs a MIME Type --- \"major\/minor\". -() :: String -> String -> MIMEType -maj min - = MIMEType maj min [] - --- |This operator appends a @(name, value)@ pair to a MIME Type. -(<:>) :: MIMEType -> (String, String) -> MIMEType -mt@(MIMEType _ _ params) <:> pair - = pair `seq` - mt { - mtParams = mtParams mt ++ [pair] - } - --- |This operator takes two strings and makes a tuple of them. So you --- can say --- --- > "text" "xml" <:> "charset" <=> "UTF-8" <:> "q" <=> "0.9" --- --- to represent \"text\/xml; charset=UTF-8; q=0.9\". -(<=>) :: String -> String -> (String, String) -name <=> value = (name, value) +-- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an +-- exception for parse error. +parseMIMEType :: String -> MIMEType +parseMIMEType str = case parseStr mimeTypeP str of + (Success t, _) -> t + _ -> error ("Unparsable MIME Type: " ++ str) mimeTypeP :: Parser MIMEType diff --git a/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs index 6d33cd6..5d02ade 100644 --- a/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs +++ b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs @@ -8,186 +8,176 @@ module Network.HTTP.Lucu.MIMEType.DefaultExtensionMap (defaultExtensionMap) where -import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.MIMEType () import Network.HTTP.Lucu.MIMEType.Guess import qualified Data.Map as M defaultExtensionMap :: ExtMap defaultExtensionMap = M.fromList - [("3gp", "application" "x-3gp"), ("669", "audio" "x-mod"), - ("Z", "application" "x-compress"), - ("a", "application" "x-ar"), ("ac3", "audio" "x-ac3"), - ("ai", "application" "postscript"), - ("aif", "audio" "x-aiff"), ("aifc", "audio" "x-aiff"), - ("aiff", "audio" "x-aiff"), ("amf", "audio" "x-mod"), - ("anx", "application" "ogg"), - ("ape", "application" "x-ape"), ("asc", "text" "plain"), - ("asf", "video" "x-ms-asf"), - ("atom", "application" "atom+xml"), ("au", "audio" "x-au"), - ("avi", "video" "x-msvideo"), - ("bcpio", "application" "x-bcpio"), - ("bin", "application" "octet-stream"), - ("bmp", "image" "bmp"), ("bz2", "application" "x-bzip"), - ("cabal", "text" "x-cabal"), - ("cdf", "application" "x-netcdf"), ("cgm", "image" "cgm"), - ("class", "application" "octet-stream"), - ("cpio", "application" "x-cpio"), - ("cpt", "application" "mac-compactpro"), - ("csh", "application" "x-csh"), ("css", "text" "css"), - ("dcr", "application" "x-director"), - ("dif", "video" "x-dv"), - ("dir", "application" "x-director"), - ("djv", "image" "vnd.djvu"), ("djvu", "image" "vnd.djvu"), - ("dll", "application" "octet-stream"), - ("dmg", "application" "octet-stream"), - ("dms", "application" "octet-stream"), - ("doc", "application" "msword"), ("dsm", "audio" "x-mod"), - ("dtd", "application" "xml-dtd"), ("dv", "video" "x-dv"), - ("dvi", "application" "x-dvi"), - ("dxr", "application" "x-director"), - ("eps", "application" "postscript"), - ("etx", "text" "x-setext"), - ("exe", "application" "octet-stream"), - ("ez", "application" "andrew-inset"), - ("far", "audio" "x-mod"), ("flac", "audio" "x-flac"), - ("flc", "video" "x-fli"), ("fli", "video" "x-fli"), - ("flv", "video" "x-flv"), ("gdm", "audio" "x-mod"), - ("gif", "image" "gif"), ("gram", "application" "srgs"), - ("grxml", "application" "srgs+xml"), - ("gtar", "application" "x-gtar"), - ("gz", "application" "x-gzip"), - ("hdf", "application" "x-hdf"), - ("hi", "application" "octet-stream"), - ("hqx", "application" "mac-binhex40"), - ("hs", "text" "x-haskell"), ("htm", "text" "html"), - ("html", "text" "html"), - ("ice", "x-conference" "x-cooltalk"), - ("ico", "image" "x-icon"), ("ics", "text" "calendar"), - ("ief", "image" "ief"), ("ifb", "text" "calendar"), - ("iff", "audio" "x-svx"), ("iges", "model" "iges"), - ("igs", "model" "iges"), ("ilbc", "audio" "iLBC-sh"), - ("imf", "audio" "x-mod"), ("it", "audio" "x-mod"), - ("jng", "image" "x-jng"), - ("jnlp", "application" "x-java-jnlp-file"), - ("jp2", "image" "jp2"), ("jpe", "image" "jpeg"), - ("jpeg", "image" "jpeg"), ("jpg", "image" "jpeg"), - ("js", "application" "x-javascript"), - ("kar", "audio" "midi"), - ("latex", "application" "x-latex"), - ("lha", "application" "octet-stream"), - ("lzh", "application" "octet-stream"), - ("m3u", "audio" "x-mpegurl"), ("m4a", "audio" "mp4a-latm"), - ("m4p", "audio" "mp4a-latm"), - ("m4u", "video" "vnd.mpegurl"), ("m4v", "video" "mpeg4"), - ("mac", "image" "x-macpaint"), - ("man", "application" "x-troff-man"), - ("mathml", "application" "mathml+xml"), - ("me", "application" "x-troff-me"), - ("med", "audio" "x-mod"), ("mesh", "model" "mesh"), - ("mid", "audio" "midi"), ("midi", "audio" "midi"), - ("mif", "application" "vnd.mif"), - ("mka", "video" "x-matroska"), - ("mkv", "video" "x-matroska"), ("mng", "video" "x-mng"), - ("mod", "audio" "x-mod"), ("mov", "video" "quicktime"), - ("movie", "video" "x-sgi-movie"), ("mp2", "audio" "mpeg"), - ("mp3", "audio" "mpeg"), ("mp4", "video" "mp4"), - ("mpc", "audio" "x-musepack"), ("mpe", "video" "mpeg"), - ("mpeg", "video" "mpeg"), ("mpg", "video" "mpeg"), - ("mpga", "audio" "mpeg"), - ("ms", "application" "x-troff-ms"), - ("msh", "model" "mesh"), ("mtm", "audio" "x-mod"), - ("mve", "video" "x-mve"), ("mxu", "video" "vnd.mpegurl"), - ("nar", "application" "x-nar"), - ("nc", "application" "x-netcdf"), - ("nist", "audio" "x-nist"), ("nuv", "video" "x-nuv"), - ("o", "application" "octet-stream"), - ("oda", "application" "oda"), ("ogg", "application" "ogg"), - ("ogm", "application" "ogg"), ("okt", "audio" "x-mod"), - ("paf", "audio" "x-paris"), - ("pbm", "image" "x-portable-bitmap"), - ("pct", "image" "pict"), ("pdb", "chemical" "x-pdb"), - ("pdf", "application" "pdf"), - ("pgm", "image" "x-portable-graymap"), - ("pgn", "application" "x-chess-pgn"), - ("pic", "image" "pict"), ("pict", "image" "pict"), - ("png", "image" "png"), - ("pnm", "image" "x-portable-anymap"), - ("pnt", "image" "x-macpaint"), - ("pntg", "image" "x-macpaint"), - ("ppm", "image" "x-portable-pixmap"), - ("ppt", "application" "vnd.ms-powerpoint"), - ("ps", "application" "postscript"), - ("qif", "image" "x-quicktime"), - ("qt", "video" "quicktime"), - ("qti", "image" "x-quicktime"), - ("qtif", "image" "x-quicktime"), - ("ra", "audio" "x-pn-realaudio"), - ("ram", "text" "uri-list"), ("rar", "application" "x-rar"), - ("ras", "image" "x-sun-raster"), - ("rdf", "application" "rdf+xml"), ("rgb", "image" "x-rgb"), - ("rm", "application" "vnd.rn-realmedia"), - ("roff", "application" "x-troff"), ("rtf", "text" "rtf"), - ("rtx", "text" "richtext"), ("s3m", "audio" "x-mod"), - ("sam", "audio" "x-mod"), ("sds", "audio" "x-sds"), - ("sf", "audio" "x-ircam"), ("sgm", "text" "sgml"), - ("sgml", "text" "sgml"), ("sh", "application" "x-sh"), - ("shar", "application" "x-shar"), - ("shn", "audio" "x-shorten"), ("sid", "audio" "x-sid"), - ("silo", "model" "mesh"), - ("sit", "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" "x-au"), - ("so", "application" "octet-stream"), - ("spc", "application" "x-spc"), - ("spl", "application" "x-futuresplash"), - ("src", "application" "x-wais-source"), - ("stm", "audio" "x-mod"), ("stx", "audio" "x-mod"), - ("sv4cpio", "application" "x-sv4cpio"), - ("sv4crc", "application" "x-sv4crc"), - ("svg", "image" "svg+xml"), ("svx", "audio" "x-svx"), - ("swf", "application" "x-shockwave-flash"), - ("swfl", "application" "x-shockwave-flash"), - ("t", "application" "x-troff"), - ("tar", "application" "x-tar"), - ("tbz", "application" "x-bzip"), - ("tcl", "application" "x-tcl"), - ("tex", "application" "x-tex"), - ("texi", "application" "x-texinfo"), - ("texinfo", "application" "x-texinfo"), - ("tgz", "application" "x-gzip"), ("tif", "image" "tiff"), - ("tiff", "image" "tiff"), ("tr", "application" "x-troff"), - ("ts", "video" "mpegts"), - ("tsv", "text" "tab-separated-values"), - ("tta", "audio" "x-ttafile"), ("txt", "text" "plain"), - ("ult", "audio" "x-mod"), - ("ustar", "application" "x-ustar"), - ("vcd", "application" "x-cdlink"), - ("voc", "audio" "x-voc"), ("vrml", "model" "vrml"), - ("vxml", "application" "voicexml+xml"), - ("w64", "audio" "x-w64"), ("wav", "audio" "x-wav"), - ("wbmp", "image" "vnd.wap.wbmp"), - ("wbxml", "application" "vnd.wap.wbxml"), - ("wm", "video" "x-ms-asf"), ("wma", "video" "x-ms-asf"), - ("wml", "text" "vnd.wap.wml"), - ("wmlc", "application" "vnd.wap.wmlc"), - ("wmls", "text" "vnd.wap.wmlscript"), - ("wmlsc", "application" "vnd.wap.wmlscriptc"), - ("wmv", "video" "x-ms-asf"), ("wrl", "model" "vrml"), - ("wv", "application" "x-wavpack"), - ("wvc", "application" "x-wavpack-correction"), - ("wvp", "application" "x-wavpack"), - ("xbm", "image" "x-xbitmap"), ("xcf", "image" "x-xcf"), - ("xht", "application" "xhtml+xml"), - ("xhtml", "application" "xhtml+xml"), - ("xls", "application" "vnd.ms-excel"), - ("xm", "audio" "x-mod"), ("xml", "application" "xml"), - ("xpm", "image" "x-xpixmap"), ("xsl", "application" "xml"), - ("xslt", "application" "xslt+xml"), - ("xul", "application" "vnd.mozilla.xul+xml"), - ("xwd", "image" "x-xwindowdump"), - ("xyz", "chemical" "x-xyz"), ("zip", "application" "zip")] + [("3gp", read "application/x-3gp"), ("669", read "audio/x-mod"), + ("Z", read "application/x-compress"), + ("a", read "application/x-ar"), ("ac3", read "audio/x-ac3"), + ("ai", read "application/postscript"), + ("aif", read "audio/x-aiff"), ("aifc", read "audio/x-aiff"), + ("aiff", read "audio/x-aiff"), ("amf", read "audio/x-mod"), + ("anx", read "application/ogg"), ("ape", read "application/x-ape"), + ("asc", read "text/plain"), ("asf", read "video/x-ms-asf"), + ("atom", read "application/atom+xml"), ("au", read "audio/x-au"), + ("avi", read "video/x-msvideo"), + ("bcpio", read "application/x-bcpio"), + ("bin", read "application/octet-stream"), + ("bmp", read "image/bmp"), ("bz2", read "application/x-bzip"), + ("cabal", read "text/x-cabal"), + ("cdf", read "application/x-netcdf"), ("cgm", read "image/cgm"), + ("class", read "application/octet-stream"), + ("cpio", read "application/x-cpio"), + ("cpt", read "application/mac-compactpro"), + ("csh", read "application/x-csh"), ("css", read "text/css"), + ("dcr", read "application/x-director"), ("dif", read "video/x-dv"), + ("dir", read "application/x-director"), + ("djv", read "image/vnd.djvu"), ("djvu", read "image/vnd.djvu"), + ("dll", read "application/octet-stream"), + ("dmg", read "application/octet-stream"), + ("dms", read "application/octet-stream"), + ("doc", read "application/msword"), ("dsm", read "audio/x-mod"), + ("dtd", read "application/xml-dtd"), ("dv", read "video/x-dv"), + ("dvi", read "application/x-dvi"), + ("dxr", read "application/x-director"), + ("eps", read "application/postscript"), + ("etx", read "text/x-setext"), + ("exe", read "application/octet-stream"), + ("ez", read "application/andrew-inset"), + ("far", read "audio/x-mod"), ("flac", read "audio/x-flac"), + ("flc", read "video/x-fli"), ("fli", read "video/x-fli"), + ("flv", read "video/x-flv"), ("gdm", read "audio/x-mod"), + ("gif", read "image/gif"), ("gram", read "application/srgs"), + ("grxml", read "application/srgs+xml"), + ("gtar", read "application/x-gtar"), + ("gz", read "application/x-gzip"), + ("hdf", read "application/x-hdf"), + ("hi", read "application/octet-stream"), + ("hqx", read "application/mac-binhex40"), + ("hs", read "text/x-haskell"), ("htm", read "text/html"), + ("html", read "text/html"), + ("ice", read "x-conference/x-cooltalk"), + ("ico", read "image/x-icon"), ("ics", read "text/calendar"), + ("ief", read "image/ief"), ("ifb", read "text/calendar"), + ("iff", read "audio/x-svx"), ("iges", read "model/iges"), + ("igs", read "model/iges"), ("ilbc", read "audio/iLBC-sh"), + ("imf", read "audio/x-mod"), ("it", read "audio/x-mod"), + ("jng", read "image/x-jng"), + ("jnlp", read "application/x-java-jnlp-file"), + ("jp2", read "image/jp2"), ("jpe", read "image/jpeg"), + ("jpeg", read "image/jpeg"), ("jpg", read "image/jpeg"), + ("js", read "application/x-javascript"), + ("kar", read "audio/midi"), ("latex", read "application/x-latex"), + ("lha", read "application/octet-stream"), + ("lzh", read "application/octet-stream"), + ("m3u", read "audio/x-mpegurl"), ("m4a", read "audio/mp4a-latm"), + ("m4p", read "audio/mp4a-latm"), ("m4u", read "video/vnd.mpegurl"), + ("m4v", read "video/mpeg4"), ("mac", read "image/x-macpaint"), + ("man", read "application/x-troff-man"), + ("mathml", read "application/mathml+xml"), + ("me", read "application/x-troff-me"), ("med", read "audio/x-mod"), + ("mesh", read "model/mesh"), ("mid", read "audio/midi"), + ("midi", read "audio/midi"), ("mif", read "application/vnd.mif"), + ("mka", read "video/x-matroska"), ("mkv", read "video/x-matroska"), + ("mng", read "video/x-mng"), ("mod", read "audio/x-mod"), + ("mov", read "video/quicktime"), + ("movie", read "video/x-sgi-movie"), ("mp2", read "audio/mpeg"), + ("mp3", read "audio/mpeg"), ("mp4", read "video/mp4"), + ("mpc", read "audio/x-musepack"), ("mpe", read "video/mpeg"), + ("mpeg", read "video/mpeg"), ("mpg", read "video/mpeg"), + ("mpga", read "audio/mpeg"), ("ms", read "application/x-troff-ms"), + ("msh", read "model/mesh"), ("mtm", read "audio/x-mod"), + ("mve", read "video/x-mve"), ("mxu", read "video/vnd.mpegurl"), + ("nar", read "application/x-nar"), + ("nc", read "application/x-netcdf"), ("nist", read "audio/x-nist"), + ("nuv", read "video/x-nuv"), + ("o", read "application/octet-stream"), + ("oda", read "application/oda"), ("ogg", read "application/ogg"), + ("ogm", read "application/ogg"), ("okt", read "audio/x-mod"), + ("paf", read "audio/x-paris"), + ("pbm", read "image/x-portable-bitmap"), + ("pct", read "image/pict"), ("pdb", read "chemical/x-pdb"), + ("pdf", read "application/pdf"), + ("pgm", read "image/x-portable-graymap"), + ("pgn", read "application/x-chess-pgn"), + ("pic", read "image/pict"), ("pict", read "image/pict"), + ("png", read "image/png"), ("pnm", read "image/x-portable-anymap"), + ("pnt", read "image/x-macpaint"), + ("pntg", read "image/x-macpaint"), + ("ppm", read "image/x-portable-pixmap"), + ("ppt", read "application/vnd.ms-powerpoint"), + ("ps", read "application/postscript"), + ("qif", read "image/x-quicktime"), ("qt", read "video/quicktime"), + ("qti", read "image/x-quicktime"), + ("qtif", read "image/x-quicktime"), + ("ra", read "audio/x-pn-realaudio"), ("ram", read "text/uri-list"), + ("rar", read "application/x-rar"), + ("ras", read "image/x-sun-raster"), + ("rdf", read "application/rdf+xml"), ("rgb", read "image/x-rgb"), + ("rm", read "application/vnd.rn-realmedia"), + ("roff", read "application/x-troff"), ("rtf", read "text/rtf"), + ("rtx", read "text/richtext"), ("s3m", read "audio/x-mod"), + ("sam", read "audio/x-mod"), ("sds", read "audio/x-sds"), + ("sf", read "audio/x-ircam"), ("sgm", read "text/sgml"), + ("sgml", read "text/sgml"), ("sh", read "application/x-sh"), + ("shar", read "application/x-shar"), + ("shn", read "audio/x-shorten"), ("sid", read "audio/x-sid"), + ("silo", read "model/mesh"), ("sit", read "application/x-stuffit"), + ("skd", read "application/x-koan"), + ("skm", read "application/x-koan"), + ("skp", read "application/x-koan"), + ("skt", read "application/x-koan"), + ("smi", read "application/smil"), + ("smil", read "application/smil"), ("snd", read "audio/x-au"), + ("so", read "application/octet-stream"), + ("spc", read "application/x-spc"), + ("spl", read "application/x-futuresplash"), + ("src", read "application/x-wais-source"), + ("stm", read "audio/x-mod"), ("stx", read "audio/x-mod"), + ("sv4cpio", read "application/x-sv4cpio"), + ("sv4crc", read "application/x-sv4crc"), + ("svg", read "image/svg+xml"), ("svx", read "audio/x-svx"), + ("swf", read "application/x-shockwave-flash"), + ("swfl", read "application/x-shockwave-flash"), + ("t", read "application/x-troff"), + ("tar", read "application/x-tar"), + ("tbz", read "application/x-bzip"), + ("tcl", read "application/x-tcl"), + ("tex", read "application/x-tex"), + ("texi", read "application/x-texinfo"), + ("texinfo", read "application/x-texinfo"), + ("tgz", read "application/x-gzip"), ("tif", read "image/tiff"), + ("tiff", read "image/tiff"), ("tr", read "application/x-troff"), + ("ts", read "video/mpegts"), + ("tsv", read "text/tab-separated-values"), + ("tta", read "audio/x-ttafile"), ("txt", read "text/plain"), + ("ult", read "audio/x-mod"), ("ustar", read "application/x-ustar"), + ("vcd", read "application/x-cdlink"), ("voc", read "audio/x-voc"), + ("vrml", read "model/vrml"), + ("vxml", read "application/voicexml+xml"), + ("w64", read "audio/x-w64"), ("wav", read "audio/x-wav"), + ("wbmp", read "image/vnd.wap.wbmp"), + ("wbxml", read "application/vnd.wap.wbxml"), + ("wm", read "video/x-ms-asf"), ("wma", read "video/x-ms-asf"), + ("wml", read "text/vnd.wap.wml"), + ("wmlc", read "application/vnd.wap.wmlc"), + ("wmls", read "text/vnd.wap.wmlscript"), + ("wmlsc", read "application/vnd.wap.wmlscriptc"), + ("wmv", read "video/x-ms-asf"), ("wrl", read "model/vrml"), + ("wv", read "application/x-wavpack"), + ("wvc", read "application/x-wavpack-correction"), + ("wvp", read "application/x-wavpack"), + ("xbm", read "image/x-xbitmap"), ("xcf", read "image/x-xcf"), + ("xht", read "application/xhtml+xml"), + ("xhtml", read "application/xhtml+xml"), + ("xls", read "application/vnd.ms-excel"), + ("xm", read "audio/x-mod"), ("xml", read "application/xml"), + ("xpm", read "image/x-xpixmap"), ("xsl", read "application/xml"), + ("xslt", read "application/xslt+xml"), + ("xul", read "application/vnd.mozilla.xul+xml"), + ("xwd", read "image/x-xwindowdump"), + ("xyz", read "chemical/x-xyz"), ("zip", read "application/zip")] diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index a0ea164..6f46326 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -88,7 +88,7 @@ serializeExtMap extMap moduleName variableName = let hsModule = HsModule undefined modName (Just exports) imports decls modName = Module moduleName exports = [HsEVar (UnQual (HsIdent variableName))] - imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing + imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing (Just (False, [])) , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing ] @@ -113,19 +113,5 @@ serializeExtMap extMap moduleName variableName = HsTuple [HsLit (HsString ext), mimeToExp mime] mimeToExp :: MIMEType -> HsExp - mimeToExp (MIMEType maj min params) - = foldl appendParam (HsInfixApp - (HsLit (HsString maj)) - (HsQVarOp (UnQual (HsSymbol ""))) - (HsLit (HsString min))) params - - appendParam :: HsExp -> (String, String) -> HsExp - appendParam x param - = HsInfixApp x (HsQVarOp (UnQual (HsSymbol "<:>"))) $ paramToExp param - - paramToExp :: (String, String) -> HsExp - paramToExp (name, value) - = HsInfixApp - (HsLit (HsString name)) - (HsQVarOp (UnQual (HsSymbol "<=>"))) - (HsLit (HsString value)) \ No newline at end of file + mimeToExp mt + = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt)) diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index fcf2359..7b64629 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -81,6 +81,7 @@ module Network.HTTP.Lucu.Resource , getHeader , getAccept , getAcceptEncoding + , isEncodingAcceptable , getContentType -- ** Finding an entity @@ -133,18 +134,17 @@ import Control.Monad.Reader import Data.Bits import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Char import Data.List import Data.Maybe import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ContentCoding import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request @@ -285,7 +285,8 @@ getAccept = do acceptM <- getHeader "Accept" (Just $ "Unparsable Accept: " ++ accept) -- |Get a list of @(contentCoding, qvalue)@ enumerated on header --- \"Accept-Encoding\". +-- \"Accept-Encoding\". The list is sorted in descending order by +-- qvalue. getAcceptEncoding :: Resource [(String, Maybe Double)] getAcceptEncoding = do accEncM <- getHeader "Accept-Encoding" @@ -303,28 +304,18 @@ getAcceptEncoding -- identity のみが許される。 -> return [("identity", Nothing)] Just accEnc - -> case parseStr accEncListP accEnc of - (Success x, _) -> return x + -> case parseStr acceptEncodingListP accEnc of + (Success x, _) -> return $ reverse $ sortBy orderAcceptEncodings x _ -> abort BadRequest [] (Just $ "Unparsable Accept-Encoding: " ++ accEnc) - where - accEncListP :: Parser [(String, Maybe Double)] - accEncListP = allowEOF $! listOf accEncP - - accEncP :: Parser (String, Maybe Double) - accEncP = do coding <- token - qVal <- option Nothing - $ do string ";q=" - q <- qvalue - return $ Just q - return (normalizeCoding coding, qVal) - - normalizeCoding :: String -> String - normalizeCoding coding - = case map toLower coding of - "x-gzip" -> "gzip" - "x-compress" -> "compress" - other -> other + +-- |Check whether a given content-coding is acceptable. +isEncodingAcceptable :: String -> Resource Bool +isEncodingAcceptable coding + = do accList <- getAcceptEncoding + return (flip any accList $ \ (c, q) -> + (c == "*" || c `noCaseEq` coding) && q /= Just 0) + -- |Get the header \"Content-Type\" as -- 'Network.HTTP.Lucu.MIMEType.MIMEType'. @@ -764,7 +755,11 @@ setLocation uri -- header \"Content-Encoding\" to @codings@. setContentEncoding :: [String] -> Resource () setContentEncoding codings - = setHeader "Content-Encoding" $ joinWith ", " codings + = do ver <- getRequestVersion + let tr = case ver of + HttpVersion 1 0 -> unnormalizeCoding + HttpVersion 1 1 -> id + setHeader "Content-Encoding" $ joinWith ", " $ map tr codings {- DecidingBody 時に使用するアクション群 -} diff --git a/data/Makefile b/data/Makefile new file mode 100644 index 0000000..ab7e1e3 --- /dev/null +++ b/data/Makefile @@ -0,0 +1,2 @@ +../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: mime.types + ./CompileMimeTypes.hs $< $@ diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index 468de85..ad1263b 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -24,7 +24,7 @@ helloWorld , resGet = Just $ do --time <- liftIO $ getClockTime --foundEntity (strongETag "abcde") time - setContentType $ "text" "hello" + setContentType $ read "text/hello" outputChunk "Hello, " outputChunk "World!\n" , resHead = Nothing @@ -32,7 +32,7 @@ helloWorld = Just $ do str1 <- inputChunk 3 str2 <- inputChunk 3 str3 <- inputChunk 3 - setContentType $ "text" "hello" + setContentType $ read "text/hello" output ("[" ++ str1 ++ " - " ++ str2 ++ "#" ++ str3 ++ "]") , resPut = Nothing , resDelete = Nothing -- 2.40.0