Say good bye to the ugliness of "text" </> "plain".

darcs-hash:20071003015303-62b54-a6a9f98028f94790d6f88c9388d7f3c9ab0fb979.gz

diff --git a/.boring b/.boring
index 3d85b5e2174bad54711810e6e134a754f8b5dbdb..320eabe33aa7cb1d7729d0ab0006655c0d5482f7 100644 (file)
--- 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 0fb5c07c82c235aa4549a36d98ca3e4a73a7e69f..8eb1c62377b96fcb7c29db786aa26bc7fda6d60e 100644 (file)
--- 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 9859e538e8e5f15c514e3143e5c5f9b3f46cfe14..80012b07ff6f6ae8256e9912135db939f5324737 100644 (file)
--- 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 (file)
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 9f653230d3597ae298cdeec99fca07276242b9f6..396a1646dbe7a5b297c2d27c8f1b834b37131b4c 100644 (file)
--- 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 6d33cd602f093f503eb6be4b98c2f6f78fbc9511..5d02ade46d99bd842d118446833201c791a2ce1e 100644 (file)
--- 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 a0ea1646b4e8e3c29493e0e89743145db825b0c5..6f4632609c6b1b2ef0d940de4cdc6b5003f470ef 100644 (file)
--- 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 fcf23593e9ee89ca83d8c3e768242740c79ed717..7b64629bf832245669effa0acd8d55c5cc045a9c 100644 (file)
--- 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 (file)
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 468de85da37b3dfedad4940d8250248b230f8940..ad1263b530f133bde94f061b07e578fc212739a8 100644 (file)
--- 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