data/mime.types

darcs-hash:20070408090826-62b54-74b112b523ee0d67bc38d4f5d4f418ca3dd94cf1.gz

diff --git a/Lucu.cabal b/Lucu.cabal
index da7ecca56ecfe9f293d6412d80bcc498f38d020a..529e438780d5d012e43f87dccdc1ba7eb4d477b9 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -1,20 +1,36 @@
 Name: Lucu
 Synopsis: HTTP Daemon Library
 Name: Lucu
 Synopsis: HTTP Daemon Library

-Version: 0
+Version: 0.1

 License: PublicDomain
 Author: PHO
 Homepage: http://ccm.sherry.jp/
 Category: Incomplete
 Build-Depends:
 License: PublicDomain
 Author: PHO
 Homepage: http://ccm.sherry.jp/
 Category: Incomplete
 Build-Depends:

-         base, mtl, network, stm, parsec, hxt
+         base, mtl, network, stm, parsec, hxt, haskell-src

 Exposed-Modules:
 Exposed-Modules:

+        Network.HTTP.Lucu.Abortion
+        Network.HTTP.Lucu.Chunk

         Network.HTTP.Lucu.Config
         Network.HTTP.Lucu.Config

+        Network.HTTP.Lucu.DefaultPage
+        Network.HTTP.Lucu.ETag

         Network.HTTP.Lucu.Headers
         Network.HTTP.Lucu.Headers

-        Network.HTTP.Lucu.Httpd

         Network.HTTP.Lucu.HttpVersion
         Network.HTTP.Lucu.HttpVersion

-        Network.HTTP.Lucu.Response
-        Network.HTTP.Lucu.Resource
+        Network.HTTP.Lucu.Httpd
+        Network.HTTP.Lucu.Interaction
+        Network.HTTP.Lucu.MIMEType
+        Network.HTTP.Lucu.MIMEType.Guess
+        Network.HTTP.Lucu.Parser
+        Network.HTTP.Lucu.Parser.Http
+        Network.HTTP.Lucu.Postprocess
+        Network.HTTP.Lucu.Preprocess
+        Network.HTTP.Lucu.RFC1123DateTime

         Network.HTTP.Lucu.Request
         Network.HTTP.Lucu.Request

+        Network.HTTP.Lucu.RequestReader
+        Network.HTTP.Lucu.Resource
+        Network.HTTP.Lucu.Resource.Tree
+        Network.HTTP.Lucu.Response
+        Network.HTTP.Lucu.ResponseWriter
+        Network.HTTP.Lucu.Utils

 ghc-options: -threaded -fglasgow-exts
 
 Executable: HelloWorld
 ghc-options: -threaded -fglasgow-exts
 
 Executable: HelloWorld

diff --git a/Makefile b/Makefile
index 80beeebd03181c74791cd3fda1911ac2bfa7d1f0..39dd65c69b739ebaacdf90d332ff70bba690c3ac 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -19,4 +19,7 @@ clean:
        rm -rf dist Setup Setup.o Setup.hi .setup-config
        find . -name '*~' -exec rm -f {} \;
 
        rm -rf dist Setup Setup.o Setup.hi .setup-config
        find . -name '*~' -exec rm -f {} \;
 

-.PHONY: run build clean
\ No newline at end of file
+install: build
+       ./Setup install
+
+.PHONY: run build clean install
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs
index 4932a142ca095a62df2a26fe83394f877aa1980c..999672f165c420a609b3e3c5e78146344e6cd6d1 100644 (file)
--- a/Network/HTTP/Lucu/Config.hs
+++ b/Network/HTTP/Lucu/Config.hs
@@ -4,9 +4,13 @@ module Network.HTTP.Lucu.Config
     )
     where
 
     )
     where
 

-import Network
-import Network.BSD
-import System.IO.Unsafe
+import qualified Data.Map as M
+import           Data.Map (Map)
+import           Network
+import           Network.BSD
+import           Network.HTTP.Lucu.MIMEType
+import           System.IO.Unsafe
+

 
 data Config = Config {
       cnfServerSoftware   :: String
 
 data Config = Config {
       cnfServerSoftware   :: String


@@ -15,8 +19,10 @@ data Config = Config {
     , cnfMaxPipelineDepth :: Int
     , cnfMaxEntityLength  :: Int
     , cnfMaxURILength     :: Int
     , cnfMaxPipelineDepth :: Int
     , cnfMaxEntityLength  :: Int
     , cnfMaxURILength     :: Int

+    , cnfExtToMIMEType    :: Map String MIMEType

     }
 
     }
 

+

 defaultConfig = Config {
                   cnfServerSoftware   = "Lucu/1.0"
                 , cnfServerHost       = unsafePerformIO getHostName
 defaultConfig = Config {
                   cnfServerSoftware   = "Lucu/1.0"
                 , cnfServerHost       = unsafePerformIO getHostName


@@ -24,4 +30,5 @@ defaultConfig = Config {
                 , cnfMaxPipelineDepth = 100
                 , cnfMaxEntityLength  = 16 * 1024 * 1024 -- 16 MiB
                 , cnfMaxURILength     = 4 * 1024         -- 4 KiB
                 , cnfMaxPipelineDepth = 100
                 , cnfMaxEntityLength  = 16 * 1024 * 1024 -- 16 MiB
                 , cnfMaxURILength     = 4 * 1024         -- 4 KiB

-                }
\ No newline at end of file
+                , cnfExtToMIMEType    = undefined -- FIXME
+                }

diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs
index 0341f5ac382b245638575477b0474ec0b1fafe40..86dd429e265100b8318716679ebfd4d0554120b0 100644 (file)
--- a/Network/HTTP/Lucu/ETag.hs
+++ b/Network/HTTP/Lucu/ETag.hs
@@ -1,13 +1,17 @@
 module Network.HTTP.Lucu.ETag
     ( ETag
 module Network.HTTP.Lucu.ETag
     ( ETag

-    , mkETag    -- Bool -> String -> ETag
+    , mkETag     -- Bool -> String -> ETag
+    , strongETag -- String -> ETag
+    , weakETag   -- String -> ETag

     , eTagP     -- Parser ETag
     , eTagListP -- Parser [ETag]
     )
     where
 
     , eTagP     -- Parser ETag
     , eTagListP -- Parser [ETag]
     )
     where
 

+import           Control.Monad

 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Parser.Http
 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Parser.Http

+import           Network.HTTP.Lucu.Utils

 
 
 data ETag = ETag {
 
 
 data ETag = ETag {


@@ -15,24 +19,27 @@ data ETag = ETag {
     , etagToken  :: String
     } deriving (Eq)
 
     , etagToken  :: String
     } deriving (Eq)
 

-

 instance Show ETag where
     show (ETag isWeak token) = (if isWeak then
                                     "W/"
                                 else
                                     "")
                                ++
 instance Show ETag where
     show (ETag isWeak token) = (if isWeak then
                                     "W/"
                                 else
                                     "")
                                ++

-                               foldr (++) "" (["\""] ++ map quote token ++ ["\""])
-        where
-          quote :: Char -> String
-          quote '"' = "\\\""
-          quote c   = [c]
+                               quoteStr token

 
 
 mkETag :: Bool -> String -> ETag
 mkETag = ETag
 
 
 
 
 mkETag :: Bool -> String -> ETag
 mkETag = ETag
 
 

+strongETag :: String -> ETag
+strongETag = ETag False
+
+
+weakETag :: String -> ETag
+weakETag = ETag True
+
+

 eTagP :: Parser ETag
 eTagP = do isWeak <- option False (string "W/" >> return True)
            str    <- quotedStr
 eTagP :: Parser ETag
 eTagP = do isWeak <- option False (string "W/" >> return True)
            str    <- quotedStr


@@ -41,6 +48,7 @@ eTagP = do isWeak <- option False (string "W/" >> return True)
 
 eTagListP :: Parser [ETag]
 eTagListP = allowEOF
 
 eTagListP :: Parser [ETag]
 eTagListP = allowEOF

-            $ sepBy1 eTagP (do many sp
-                               char ','
-                               many sp)
+            $ do xs <- listOf eTagP
+                 when (null xs)
+                          $ fail ""
+                 return xs

diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs
index 7b0a565f2b1bc08ea56a93f40e7bc4c643c66a02..2be87368b4b436d2d16c8e0c43b044b69ecdda67 100644 (file)
--- a/Network/HTTP/Lucu/Httpd.hs
+++ b/Network/HTTP/Lucu/Httpd.hs
@@ -12,6 +12,7 @@ import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.RequestReader
 import           Network.HTTP.Lucu.Resource
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.RequestReader
 import           Network.HTTP.Lucu.Resource

+import           Network.HTTP.Lucu.Resource.Tree

 import           Network.HTTP.Lucu.ResponseWriter
 import           System.IO
 
 import           Network.HTTP.Lucu.ResponseWriter
 import           System.IO
 

diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
new file mode 100644 (file)
index 0000000..bd799e0
--- /dev/null
+++ b/Network/HTTP/Lucu/MIMEType.hs
@@ -0,0 +1,78 @@
+module Network.HTTP.Lucu.MIMEType
+    ( MIMEType(..)
+    , (+/+)         -- String -> String -> MIMEType
+    , (+:+)         -- MIMEType -> (String, String) -> MIMEType
+    , (+=+)         -- String -> String -> (String, String)
+    , mimeTypeP     -- Parser MIMEType
+    , mimeTypeListP -- Parser [MIMEType]
+    )
+    where
+
+import           Network.HTTP.Lucu.Parser
+import           Network.HTTP.Lucu.Parser.Http
+import           Network.HTTP.Lucu.Utils
+
+
+data MIMEType = MIMEType {
+      mtMajor  :: String
+    , mtMinor  :: String
+    , mtParams :: [ (String, String) ]
+    } deriving (Eq)
+
+
+instance Show MIMEType where
+    show (MIMEType maj min params)
+        = maj ++ "/" ++ min ++
+          if null params then
+              ""
+          else
+              "; " ++ joinWith "; " (map showPair params)
+        where
+          showPair :: (String, String) -> String
+          showPair (name, value)
+              = name ++ "=" ++ if any (not . isToken) value then
+                                   quoteStr value
+                               else
+                                   value
+
+
+infix  9 +/+, +=+
+infixl 8 +:+
+
+
+(+/+) :: String -> String -> MIMEType
+maj +/+ min
+    = MIMEType maj min []
+
+
+(+:+) :: MIMEType -> (String, String) -> MIMEType
+mt@(MIMEType _ _ params) +:+ pair
+    = mt {
+        mtParams = mtParams mt ++ [pair]
+      }
+
+
+(+=+) :: String -> String -> (String, String)
+name +=+ value = (name, value)
+
+
+
+mimeTypeP :: Parser MIMEType
+mimeTypeP = allowEOF $
+            do maj <- token
+               char '/'
+               min <- token
+               params <- many paramP
+               return $ MIMEType maj min params
+    where
+      paramP :: Parser (String, String)
+      paramP = do many lws
+                  char ';'
+                  many lws
+                  name <- token
+                  char '='
+                  value <- token <|> quotedStr
+                  return (name, value)
+
+mimeTypeListP :: Parser [MIMEType]
+mimeTypeListP = allowEOF $ listOf mimeTypeP

diff --git a/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs
new file mode 100644 (file)
index 0000000..642afb2
--- /dev/null
+++ b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs
@@ -0,0 +1,189 @@
+{- !!! WARNING !!!
+   This file is automatically generated from data/mime.types.
+   DO NOT EDIT BY HAND OR YOU WILL REGRET -}
+
+module Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
+       (defaultExtensionMap) where
+import Network.HTTP.Lucu.MIMEType
+import qualified Data.Map as M
+import Data.Map (Map)
+ 
+defaultExtensionMap :: Map String MIMEType
+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")]

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
new file mode 100644 (file)
index 0000000..309f7fe
--- /dev/null
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -0,0 +1,105 @@
+module Network.HTTP.Lucu.MIMEType.Guess
+    ( parseExtMapFile  -- FilePath -> IO (Map String MIMEType)
+    , outputExtMapAsHS -- Map String MIMEType -> FilePath -> IO ()
+    )
+    where
+
+import qualified Data.ByteString.Lazy.Char8 as B
+import           Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.Map as M
+import           Data.Map (Map)
+import           Data.Maybe
+import           Language.Haskell.Pretty
+import           Language.Haskell.Syntax
+import           Network.HTTP.Lucu.MIMEType
+import           Network.HTTP.Lucu.Parser
+import           Network.HTTP.Lucu.Parser.Http
+import           System.IO
+
+import Debug.Trace
+
+parseExtMapFile :: FilePath -> IO (Map String MIMEType)
+parseExtMapFile fpath
+    = do file <- B.readFile fpath
+         case parse (allowEOF extMapP) file of
+           (Success xs, _) -> return $ compile xs
+           (_, input')     -> let near = B.unpack $ B.take 100 input'
+                              in 
+                                fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
+
+
+extMapP :: Parser [ (MIMEType, [String]) ]
+extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
+             eof
+             return $ catMaybes xs
+    where
+      spc = oneOf " \t"
+
+      comment = do many spc
+                   char '#'
+                   many $ satisfy (/= '\n')
+                   return Nothing
+
+      validLine = do many spc
+                     mime <- mimeTypeP
+                     many spc
+                     exts <- sepBy token (many spc)
+                     return $ Just (mime, exts)
+
+      emptyLine = oneOf " \t\n" >> return Nothing
+
+
+compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
+compile = M.fromList . foldr (++) [] . map tr
+    where
+      tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
+      tr (mime, exts) = [ (ext, mime) | ext <- exts ]
+
+
+outputExtMapAsHS :: Map String MIMEType -> FilePath -> IO ()
+outputExtMapAsHS extMap fpath
+    = let hsModule = HsModule undefined modName (Just exports) imports decls
+          modName  = Module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap"
+          exports  = [HsEVar (UnQual (HsIdent "defaultExtensionMap"))]
+          imports  = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
+                     , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
+                     , HsImportDecl undefined (Module "Data.Map") False Nothing (Just (False, [HsIAbs (HsIdent "Map")]))
+                     ]
+          decls    = [ HsTypeSig undefined [HsIdent "defaultExtensionMap"]
+                                     (HsQualType [] (HsTyApp (HsTyApp (HsTyCon (UnQual (HsIdent "Map")))
+                                                                      (HsTyCon (UnQual (HsIdent "String"))))
+                                                             (HsTyCon (UnQual (HsIdent "MIMEType")))))
+                     , HsFunBind [HsMatch undefined (HsIdent "defaultExtensionMap")
+                                  [] (HsUnGuardedRhs extMapExp) []]
+                     ]
+          extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
+          comment =    "{- !!! WARNING !!!\n"
+                    ++ "   This file is automatically generated from data/mime.types.\n"
+                    ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
+      in
+        writeFile fpath $ comment ++ prettyPrint hsModule ++ "\n"
+    where
+      records :: [HsExp]
+      records = map record $ M.assocs extMap
+
+      record :: (String, MIMEType) -> HsExp
+      record (ext, mime)
+          = 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

diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
index 534577c7e6c1c26d388590f5e7966eef4bd00b6a..93fc14d9c80077cf3f2ba63270b215c8fc3f7442 100644 (file)
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -2,6 +2,8 @@ module Network.HTTP.Lucu.Parser.Http
     ( isCtl       -- Char -> Bool
     , isSeparator -- Char -> Bool
     , isChar      -- Char -> Bool
     ( isCtl       -- Char -> Bool
     , isSeparator -- Char -> Bool
     , isChar      -- Char -> Bool

+    , isToken     -- Char -> Bool
+    , listOf      -- Parser a -> Parser [a]

     , token       -- Parser String
     , lws         -- Parser String
     , text        -- Parser Char
     , token       -- Parser String
     , lws         -- Parser String
     , text        -- Parser Char


@@ -32,8 +34,19 @@ isChar c
     | otherwise   = False
 
 
     | otherwise   = False
 
 

+isToken :: Char -> Bool
+isToken c = not (isCtl c || isSeparator c)
+
+
+listOf :: Parser a -> Parser [a]
+listOf p = do many lws
+              sepBy p (do many lws
+                          char ','
+                          many lws)
+
+

 token :: Parser String
 token :: Parser String

-token = many1 $ satisfy (\ c -> not (isCtl c || isSeparator c))
+token = many1 $ satisfy isToken

 
 
 lws :: Parser String
 
 
 lws :: Parser String

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 42eda0e7cb8efcec541eed78f19ba4f1d557b241..00d3b03ea5251a3b1fe12ae5c2dccb5a7caa339b 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -25,10 +25,10 @@ import           Network.HTTP.Lucu.Preprocess
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.Resource
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.Resource

+import           Network.HTTP.Lucu.Resource.Tree

 import           Prelude hiding (catch)
 import           System.IO
 
 import           Prelude hiding (catch)
 import           System.IO
 

-import GHC.Conc (unsafeIOToSTM)

 
 requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
 requestReader cnf tree h host tQueue
 
 requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
 requestReader cnf tree h host tQueue

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 883cc149188a404f2007425cf88d6bcfc8a2b1d8..3ac8fb9cc1560bc293c8a93e1a1945700c5c2119 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,16 +1,13 @@
 module Network.HTTP.Lucu.Resource
 module Network.HTTP.Lucu.Resource

-    ( ResourceDef(..)
-    , Resource
-    , ResTree
-    , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
-    , findResource -- ResTree -> URI -> Maybe ResourceDef
-    , runResource  -- ResourceDef -> Interaction -> IO ThreadId
+    ( Resource

 
     , getMethod -- Resource Method
     , getHeader -- String -> Resource (Maybe String)
 
     , getMethod -- Resource Method
     , getHeader -- String -> Resource (Maybe String)

+    , getAccept -- Resource [MIMEType]
+    , getContentType -- Resource (Maybe MIMEType)

 
 

-    , foundEntity    -- Bool -> String -> ClockTime -> Resource ()
-    , foundETag      -- Bool -> String -> Resource ()
+    , foundEntity    -- ETag -> ClockTime -> Resource ()
+    , foundETag      -- ETag -> Resource ()

     , foundTimeStamp -- ClockTime -> Resource ()
     , foundNoEntity  -- Maybe String -> Resource ()
 
     , foundTimeStamp -- ClockTime -> Resource ()
     , foundNoEntity  -- Maybe String -> Resource ()
 


@@ -23,26 +20,24 @@ module Network.HTTP.Lucu.Resource
     , setStatus -- StatusCode -> Resource ()
     , setHeader -- String -> String -> Resource ()
     , redirect  -- StatusCode -> URI -> Resource ()
     , setStatus -- StatusCode -> Resource ()
     , setHeader -- String -> String -> Resource ()
     , redirect  -- StatusCode -> URI -> Resource ()

-    , setETag   -- Bool -> String -> Resource ()
+    , setETag   -- ETag -> Resource ()

     , setLastModified -- ClockTime -> Resource ()
     , setLastModified -- ClockTime -> Resource ()

+    , setContentType  -- MIMEType -> Resource ()

 
     , output        -- String -> Resource ()
     , outputChunk   -- String -> Resource ()
     , outputBS      -- ByteString -> Resource ()
     , outputChunkBS -- ByteString -> Resource ()
 
     , output        -- String -> Resource ()
     , outputChunk   -- String -> Resource ()
     , outputBS      -- ByteString -> Resource ()
     , outputChunkBS -- ByteString -> Resource ()

+
+    , driftTo -- InteractionState -> Resource ()

     )
     where
 
     )
     where
 

-import           Control.Concurrent

 import           Control.Concurrent.STM
 import           Control.Concurrent.STM

-import           Control.Exception

 import           Control.Monad.Reader
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Control.Monad.Reader
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)

-import           Data.Dynamic

 import           Data.List
 import           Data.List

-import qualified Data.Map as M
-import           Data.Map (Map)

 import           Data.Maybe
 import           GHC.Conc (unsafeIOToSTM)
 import           Network.HTTP.Lucu.Abortion
 import           Data.Maybe
 import           GHC.Conc (unsafeIOToSTM)
 import           Network.HTTP.Lucu.Abortion


@@ -57,174 +52,15 @@ import           Network.HTTP.Lucu.Postprocess
 import           Network.HTTP.Lucu.RFC1123DateTime
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.RFC1123DateTime
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response

+import           Network.HTTP.Lucu.MIMEType

 import           Network.HTTP.Lucu.Utils
 import           Network.URI
 import           Network.HTTP.Lucu.Utils
 import           Network.URI

-import           Prelude hiding (catch)
-import           System.IO
-import           System.IO.Error hiding (catch)

 import           System.Time
 
 
 type Resource a = ReaderT Interaction IO a
 
 
 import           System.Time
 
 
 type Resource a = ReaderT Interaction IO a
 
 

-{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
-   れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
-   /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
-   される。 -}
-data ResourceDef = ResourceDef {
-      resUsesNativeThread :: Bool
-    , resIsGreedy         :: Bool
-    , resGet              :: Maybe (Resource ())
-    , resHead             :: Maybe (Resource ())
-    , resPost             :: Maybe (Resource ())
-    , resPut              :: Maybe (Resource ())
-    , resDelete           :: Maybe (Resource ())
-    }
-type ResTree    = ResNode -- root だから Map ではない
-type ResSubtree = Map String ResNode
-data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
-
-
-mkResTree :: [ ([String], ResourceDef) ] -> ResTree
-mkResTree list = processRoot list
-    where
-      processRoot :: [ ([String], ResourceDef) ] -> ResTree
-      processRoot list
-          = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
-                children = processNonRoot nonRoots
-            in
-              if null roots then
-                  -- / にリソースが定義されない。/foo とかにはあるかも。
-                  ResNode Nothing children
-              else
-                  -- / がある。
-                  let (_, def) = last roots
-                  in 
-                    ResNode (Just def) children
-
-      processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
-      processNonRoot list
-          = let subtree    = M.fromList [(name, node name)
-                                             | name <- childNames]
-                childNames = [name | (name:_, _) <- list]
-                node name  = let defs = [def | (path, def) <- list, path == [name]]
-                             in
-                               if null defs then
-                                   -- この位置にリソースが定義されない。
-                                   -- もっと下にはあるかも。
-                                   ResNode Nothing children
-                               else
-                                   -- この位置にリソースがある。
-                                   ResNode (Just $ last defs) children
-                children   = processNonRoot [(path, def)
-                                                 | (_:path, def) <- list, not (null path)]
-            in
-              subtree
-
-
-findResource :: ResTree -> URI -> Maybe ResourceDef
-findResource (ResNode rootDefM subtree) uri
-    = let pathStr = uriPath uri
-          path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
-      in
-        if null path then
-            rootDefM
-        else
-            walkTree subtree path
-    where
-      walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
-
-      walkTree subtree (name:[])
-          = case M.lookup name subtree of
-              Nothing               -> Nothing
-              Just (ResNode defM _) -> defM
-
-      walkTree subtree (x:xs)
-          = case M.lookup x subtree of
-              Nothing                      -> Nothing
-              Just (ResNode defM children) -> case defM of
-                                                Just (ResourceDef { resIsGreedy = True })
-                                                    -> defM
-                                                _   -> walkTree children xs
-
-
-runResource :: ResourceDef -> Interaction -> IO ThreadId
-runResource def itr
-    = fork
-      $ catch ( runReaderT ( do fromMaybe notAllowed rsrc 
-                                driftTo Done
-                           ) itr
-              )
-      $ \ exc -> processException (itrConfig itr) exc
-    where
-      fork :: IO () -> IO ThreadId
-      fork = if (resUsesNativeThread def)
-             then forkOS
-             else forkIO
-      
-      rsrc :: Maybe (Resource ())
-      rsrc = case reqMethod $ fromJust $ itrRequest itr of
-               GET    -> resGet def
-               HEAD   -> case resHead def of
-                           Just r  -> Just r
-                           Nothing -> resGet def
-               POST   -> resPost def
-               PUT    -> resPut def
-               DELETE -> resDelete def
-
-      notAllowed :: Resource ()
-      notAllowed = do setStatus MethodNotAllowed
-                      setHeader "Allow" $ joinWith ", " allowedMethods
-
-      allowedMethods :: [String]
-      allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
-                                           , methods resHead   ["GET", "HEAD"]
-                                           , methods resPost   ["POST"]
-                                           , methods resPut    ["PUT"]
-                                           , methods resDelete ["DELETE"]
-                                           ]
-
-      methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
-      methods f xs = case f def of
-                       Just _  -> xs
-                       Nothing -> []
-
-      processException :: Config -> Exception -> IO ()
-      processException conf exc
-          = do let abo = case exc of
-                           ErrorCall    msg  -> Abortion InternalServerError [] msg
-                           IOException  ioE  -> Abortion InternalServerError [] $ formatIOE ioE
-                           DynException dynE -> case fromDynamic dynE of
-                                                  Just (abo :: Abortion) -> abo
-                                                  Nothing
-                                                      -> Abortion InternalServerError []
-                                                         $ show exc
-                           _                 -> Abortion InternalServerError [] $ show exc
-               -- まだ DecidingHeader 以前の状態だったら、この途中終了
-               -- を應答に反映させる餘地がある。さうでなければ stderr
-               -- にでも吐くしか無い。
-               state <- atomically $ readItr itr itrState id
-               if state <= DecidingHeader then
-                   flip runReaderT itr
-                      $ do setStatus $ aboStatus abo
-                           -- FIXME: 同じ名前で複數の値があった時は、こ
-                           -- れではまずいと思ふ。
-                           mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
-                           setHeader "Content-Type" "application/xhtml+xml"
-                           output $ aboPage conf abo
-                 else
-                   hPutStrLn stderr $ show abo
-
-               flip runReaderT itr $ driftTo Done
-
-      formatIOE :: IOError -> String
-      formatIOE ioE = if isUserError ioE then
-                          ioeGetErrorString ioE
-                      else
-                          show ioE
-
-

 getMethod :: Resource Method
 getMethod = do itr <- ask
                return $ reqMethod $ fromJust $ itrRequest itr
 getMethod :: Resource Method
 getMethod = do itr <- ask
                return $ reqMethod $ fromJust $ itrRequest itr


@@ -235,25 +71,44 @@ getHeader name = do itr <- ask
                     return $ H.getHeader name $ fromJust $ itrRequest itr
 
 
                     return $ H.getHeader name $ fromJust $ itrRequest itr
 
 

+getAccept :: Resource [MIMEType]
+getAccept = do accept <- getHeader "Accept"
+               if accept == Nothing then
+                   return []
+                 else
+                   case parseStr mimeTypeListP $ fromJust accept of
+                     (Success xs, _) -> return xs
+                     _               -> return []
+
+
+getContentType :: Resource (Maybe MIMEType)
+getContentType = do cType <- getHeader "Content-Type"
+                    if cType == Nothing then
+                        return Nothing
+                      else
+                        case parseStr mimeTypeP $ fromJust cType of
+                          (Success t, _) -> return $ Just t
+                          _              -> return Nothing
+
+
+

 {- ExaminingRequest 時に使用するアクション群 -}
 
 {- ExaminingRequest 時に使用するアクション群 -}
 

-foundEntity :: Bool -> String -> ClockTime -> Resource ()
-foundEntity isWeak token timeStamp
+foundEntity :: ETag -> ClockTime -> Resource ()
+foundEntity tag timeStamp

     = do driftTo ExaminingRequest
 
          method <- getMethod
          when (method == GET || method == HEAD)
                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
     = do driftTo ExaminingRequest
 
          method <- getMethod
          when (method == GET || method == HEAD)
                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp

-         foundETag isWeak token
+         foundETag tag

 
          driftTo GettingBody
 
 
 
          driftTo GettingBody
 
 

-foundETag :: Bool -> String -> Resource ()
-foundETag isWeak token
+foundETag :: ETag -> Resource ()
+foundETag tag

     = do driftTo ExaminingRequest
     = do driftTo ExaminingRequest

-
-         let tag = mkETag isWeak token

       
          method <- getMethod
          when (method == GET || method == HEAD)
       
          method <- getMethod
          when (method == GET || method == HEAD)


@@ -513,9 +368,9 @@ redirect code uri
          setHeader "Location" (uriToString id uri $ "")
 
 
          setHeader "Location" (uriToString id uri $ "")
 
 

-setETag :: Bool -> String -> Resource ()
-setETag isWeak token
-    = setHeader "ETag" $ show $ mkETag isWeak token
+setETag :: ETag -> Resource ()
+setETag tag
+    = setHeader "ETag" $ show tag

 
 
 setLastModified :: ClockTime -> Resource ()
 
 
 setLastModified :: ClockTime -> Resource ()


@@ -523,6 +378,11 @@ setLastModified lastmod
     = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
 
 
     = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
 
 

+setContentType :: MIMEType -> Resource ()
+setContentType mType
+    = setHeader "Content-Type" $ show mType
+
+

 {- DecidingBody 時に使用するアクション群 -}
 
 output :: String -> Resource ()
 {- DecidingBody 時に使用するアクション群 -}
 
 output :: String -> Resource ()

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
new file mode 100644 (file)
index 0000000..062ffdc
--- /dev/null
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -0,0 +1,188 @@
+module Network.HTTP.Lucu.Resource.Tree
+    ( ResourceDef(..)
+    , Resource
+    , ResTree
+    , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
+
+    , findResource -- ResTree -> URI -> Maybe ResourceDef
+    , runResource  -- ResourceDef -> Interaction -> IO ThreadId
+    )
+    where
+
+import           Control.Concurrent
+import           Control.Concurrent.STM
+import           Control.Exception
+import           Control.Monad.Reader
+import           Data.Dynamic
+import           Data.List
+import qualified Data.Map as M
+import           Data.Map (Map)
+import           Data.Maybe
+import           Network.HTTP.Lucu.Abortion
+import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.Request
+import           Network.HTTP.Lucu.Resource
+import           Network.HTTP.Lucu.Response
+import           Network.HTTP.Lucu.Interaction
+import           Network.HTTP.Lucu.Utils
+import           Network.URI
+import           System.IO
+import           System.IO.Error hiding (catch)
+import           Prelude hiding (catch)
+
+
+{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
+   れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
+   /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
+   される。 -}
+data ResourceDef = ResourceDef {
+      resUsesNativeThread :: Bool
+    , resIsGreedy         :: Bool
+    , resGet              :: Maybe (Resource ())
+    , resHead             :: Maybe (Resource ())
+    , resPost             :: Maybe (Resource ())
+    , resPut              :: Maybe (Resource ())
+    , resDelete           :: Maybe (Resource ())
+    }
+type ResTree    = ResNode -- root だから Map ではない
+type ResSubtree = Map String ResNode
+data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
+
+
+mkResTree :: [ ([String], ResourceDef) ] -> ResTree
+mkResTree list = processRoot list
+    where
+      processRoot :: [ ([String], ResourceDef) ] -> ResTree
+      processRoot list
+          = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
+                children = processNonRoot nonRoots
+            in
+              if null roots then
+                  -- / にリソースが定義されない。/foo とかにはあるかも。
+                  ResNode Nothing children
+              else
+                  -- / がある。
+                  let (_, def) = last roots
+                  in 
+                    ResNode (Just def) children
+
+      processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
+      processNonRoot list
+          = let subtree    = M.fromList [(name, node name)
+                                             | name <- childNames]
+                childNames = [name | (name:_, _) <- list]
+                node name  = let defs = [def | (path, def) <- list, path == [name]]
+                             in
+                               if null defs then
+                                   -- この位置にリソースが定義されない。
+                                   -- もっと下にはあるかも。
+                                   ResNode Nothing children
+                               else
+                                   -- この位置にリソースがある。
+                                   ResNode (Just $ last defs) children
+                children   = processNonRoot [(path, def)
+                                                 | (_:path, def) <- list, not (null path)]
+            in
+              subtree
+
+
+findResource :: ResTree -> URI -> Maybe ResourceDef
+findResource (ResNode rootDefM subtree) uri
+    = let pathStr = uriPath uri
+          path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
+      in
+        if null path then
+            rootDefM
+        else
+            walkTree subtree path
+    where
+      walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
+
+      walkTree subtree (name:[])
+          = case M.lookup name subtree of
+              Nothing               -> Nothing
+              Just (ResNode defM _) -> defM
+
+      walkTree subtree (x:xs)
+          = case M.lookup x subtree of
+              Nothing                      -> Nothing
+              Just (ResNode defM children) -> case defM of
+                                                Just (ResourceDef { resIsGreedy = True })
+                                                    -> defM
+                                                _   -> walkTree children xs
+
+
+runResource :: ResourceDef -> Interaction -> IO ThreadId
+runResource def itr
+    = fork
+      $ catch ( runReaderT ( do fromMaybe notAllowed rsrc 
+                                driftTo Done
+                           ) itr
+              )
+      $ \ exc -> processException (itrConfig itr) exc
+    where
+      fork :: IO () -> IO ThreadId
+      fork = if (resUsesNativeThread def)
+             then forkOS
+             else forkIO
+      
+      rsrc :: Maybe (Resource ())
+      rsrc = case reqMethod $ fromJust $ itrRequest itr of
+               GET    -> resGet def
+               HEAD   -> case resHead def of
+                           Just r  -> Just r
+                           Nothing -> resGet def
+               POST   -> resPost def
+               PUT    -> resPut def
+               DELETE -> resDelete def
+
+      notAllowed :: Resource ()
+      notAllowed = do setStatus MethodNotAllowed
+                      setHeader "Allow" $ joinWith ", " allowedMethods
+
+      allowedMethods :: [String]
+      allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
+                                           , methods resHead   ["GET", "HEAD"]
+                                           , methods resPost   ["POST"]
+                                           , methods resPut    ["PUT"]
+                                           , methods resDelete ["DELETE"]
+                                           ]
+
+      methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
+      methods f xs = case f def of
+                       Just _  -> xs
+                       Nothing -> []
+
+      processException :: Config -> Exception -> IO ()
+      processException conf exc
+          = do let abo = case exc of
+                           ErrorCall    msg  -> Abortion InternalServerError [] msg
+                           IOException  ioE  -> Abortion InternalServerError [] $ formatIOE ioE
+                           DynException dynE -> case fromDynamic dynE of
+                                                  Just (abo :: Abortion) -> abo
+                                                  Nothing
+                                                      -> Abortion InternalServerError []
+                                                         $ show exc
+                           _                 -> Abortion InternalServerError [] $ show exc
+               -- まだ DecidingHeader 以前の状態だったら、この途中終了
+               -- を應答に反映させる餘地がある。さうでなければ stderr
+               -- にでも吐くしか無い。
+               state <- atomically $ readItr itr itrState id
+               if state <= DecidingHeader then
+                   flip runReaderT itr
+                      $ do setStatus $ aboStatus abo
+                           -- FIXME: 同じ名前で複數の値があった時は、こ
+                           -- れではまずいと思ふ。
+                           mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
+                           setHeader "Content-Type" "application/xhtml+xml"
+                           output $ aboPage conf abo
+                 else
+                   hPutStrLn stderr $ show abo
+
+               flip runReaderT itr $ driftTo Done
+
+      formatIOE :: IOError -> String
+      formatIOE ioE = if isUserError ioE then
+                          ioeGetErrorString ioE
+                      else
+                          show ioE

diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
new file mode 100644 (file)
index 0000000..cbbed1e
--- /dev/null
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -0,0 +1,13 @@
+module Network.HTTP.Lucu.StaticFile
+    (
+    )
+    where
+
+
+staticFile :: FilePath -> ResourceDef
+staticFile path
+    = ResourceDef {
+        resUsesNativeThread = False
+      , resIsGreedy         = False
+      , resGet
+          = Just $ do 
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
index df19a76d251fdd42c66161e381ea6c45bece2be1..58da6f50c2612ac1e64e4d8366e17dfa21712f50 100644 (file)
--- a/Network/HTTP/Lucu/Utils.hs
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -4,6 +4,7 @@ module Network.HTTP.Lucu.Utils
     , trim         -- (a -> Bool) -> [a] -> [a]
     , noCaseEq     -- String -> String -> Bool
     , isWhiteSpace -- Char -> Bool
     , trim         -- (a -> Bool) -> [a] -> [a]
     , noCaseEq     -- String -> String -> Bool
     , isWhiteSpace -- Char -> Bool

+    , quoteStr     -- String -> String

     )
     where
 
     )
     where
 


@@ -40,3 +41,11 @@ noCaseEq a b
 
 isWhiteSpace :: Char -> Bool
 isWhiteSpace = flip elem " \t\r\n"
 
 isWhiteSpace :: Char -> Bool
 isWhiteSpace = flip elem " \t\r\n"

+
+
+quoteStr :: String -> String
+quoteStr str = foldr (++) "" (["\""] ++ map quote str ++ ["\""])
+    where
+      quote :: Char -> String
+      quote '"' = "\\\""
+      quote c   = [c]
\ No newline at end of file

diff --git a/data/CompileMimeTypes.hs b/data/CompileMimeTypes.hs
new file mode 100755 (executable)
index 0000000..ff65a6d
--- /dev/null
+++ b/data/CompileMimeTypes.hs
@@ -0,0 +1,6 @@
+#!/usr/bin/env runghc
+
+import Network.HTTP.Lucu.MIMEType.Guess
+
+main = do extMap <- parseExtMapFile "/dev/stdin"
+          outputExtMapAsHS extMap "/dev/stdout"

diff --git a/data/mime.types b/data/mime.types
new file mode 100644 (file)
index 0000000..7d2fe08
--- /dev/null
+++ b/data/mime.types
@@ -0,0 +1,158 @@
+# MIME type                    Extensions
+application/andrew-inset       ez
+application/atom+xml           atom
+application/mac-binhex40       hqx
+application/mac-compactpro     cpt
+application/mathml+xml         mathml
+application/msword             doc
+application/octet-stream       bin dms lha lzh exe class so dll dmg hi o
+application/oda                        oda
+application/ogg                        anx ogg ogm
+application/pdf                        pdf
+application/postscript         ai eps ps
+application/rdf+xml            rdf
+application/smil               smi smil
+application/srgs               gram
+application/srgs+xml           grxml
+application/vnd.mif            mif
+application/vnd.mozilla.xul+xml        xul
+application/vnd.ms-excel       xls
+application/vnd.ms-powerpoint  ppt
+application/vnd.rn-realmedia   rm
+application/vnd.wap.wbxml      wbxml
+application/vnd.wap.wmlc       wmlc
+application/vnd.wap.wmlscriptc wmlsc
+application/voicexml+xml       vxml
+application/x-3gp           3gp
+application/x-ape           ape
+application/x-ar            a
+application/x-bcpio            bcpio
+application/x-bzip      bz2 tbz
+application/x-cdlink           vcd
+application/x-chess-pgn                pgn
+application/x-compress      Z
+application/x-cpio             cpio
+application/x-csh              csh
+application/x-director         dcr dir dxr
+application/x-dvi              dvi
+application/x-futuresplash     spl
+application/x-gtar             gtar
+application/x-gzip      gz tgz
+application/x-hdf              hdf
+application/x-javascript       js
+application/x-java-jnlp-file   jnlp
+application/x-koan             skp skd skt skm
+application/x-latex            latex
+application/x-nar       nar
+application/x-netcdf           nc cdf
+application/x-rar           rar
+application/x-sh               sh
+application/x-shar             shar
+application/x-shockwave-flash  swf swfl
+application/x-spc               spc
+application/x-stuffit          sit
+application/x-sv4cpio          sv4cpio
+application/x-sv4crc           sv4crc
+application/x-tar              tar
+application/x-tcl              tcl
+application/x-tex              tex
+application/x-texinfo          texinfo texi
+application/x-troff            t tr roff
+application/x-troff-man                man
+application/x-troff-me         me
+application/x-troff-ms         ms
+application/x-ustar            ustar
+application/x-wavpack   wv wvp
+application/x-wavpack-correction        wvc
+application/x-wais-source      src
+application/xhtml+xml          xhtml xht
+application/xslt+xml           xslt
+application/xml                        xml xsl
+application/xml-dtd            dtd
+application/zip                        zip
+audio/basic                    au snd
+audio/iLBC-sh       ilbc
+audio/midi                     mid midi kar
+audio/mp4a-latm                        m4a m4p
+audio/mpeg                     mpga mp2 mp3
+audio/x-ac3         ac3
+audio/x-aiff                   aif aiff aifc
+audio/x-au              au snd
+audio/x-ircam           sf
+audio/x-flac            flac
+audio/x-mod             669 amf dsm gdm far imf it med mod mtm okt sam s3m stm stx ult xm
+audio/x-mpegurl                        m3u
+audio/x-musepack        mpc
+audio/x-nist            nist
+audio/x-paris           paf
+audio/x-pn-realaudio           ram ra
+audio/x-sds                 sds
+audio/x-shorten             shn
+audio/x-sid                 sid
+audio/x-svx                 iff svx
+audio/x-ttafile             tta
+audio/x-voc                 voc
+audio/x-w64                 w64
+audio/x-wav                    wav
+chemical/x-pdb                 pdb
+chemical/x-xyz                 xyz
+image/bmp                      bmp
+image/cgm                      cgm
+image/gif                      gif
+image/ief                      ief
+image/jpeg                     jpeg jpg jpe
+image/jp2                      jp2
+image/pict                     pict pic pct
+image/png                      png
+image/svg+xml                  svg
+image/tiff                     tiff tif
+image/vnd.djvu                 djvu djv
+image/vnd.wap.wbmp             wbmp
+image/x-sun-raster             ras
+image/x-macpaint               pntg pnt mac
+image/x-icon                   ico
+image/x-jng             jng
+image/x-portable-anymap                pnm
+image/x-portable-bitmap                pbm
+image/x-portable-graymap       pgm
+image/x-portable-pixmap                ppm
+image/x-quicktime              qtif qti qif
+image/x-rgb                    rgb
+image/x-xbitmap                        xbm
+image/x-xcf             xcf
+image/x-xpixmap                        xpm
+image/x-xwindowdump            xwd
+model/iges                     igs iges
+model/mesh                     msh mesh silo
+model/vrml                     wrl vrml
+text/calendar                  ics ifb
+text/css                       css
+text/html                      html htm
+text/plain                     asc txt
+text/richtext                  rtx
+text/rtf                       rtf
+text/sgml                      sgml sgm
+text/tab-separated-values      tsv
+text/uri-list               ram
+text/vnd.wap.wml               wml
+text/vnd.wap.wmlscript         wmls
+text/x-cabal                cabal
+text/x-haskell          hs
+text/x-setext                  etx
+video/mp4                      mp4
+video/mpeg                     mpeg mpg mpe
+video/mpeg4         m4v
+video/mpegts        ts
+video/quicktime                        qt mov
+video/vnd.mpegurl              mxu m4u
+video/x-dv                     dv dif
+video/x-fli         flc fli
+video/x-flv         flv
+video/x-matroska    mkv  mka
+video/x-ms-asf      asf wm wma wmv
+video/x-msvideo                        avi
+video/x-mng             mng
+video/x-mve             mve
+video/x-nuv             nuv
+video/x-sgi-movie              movie
+x-conference/x-cooltalk                ice

diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs
index 2fb9ed98ccf3a5b381431fa72477765a2351570c..f3a36219fbd69fda04fefef40648dc1d5ca98b63 100644 (file)
--- a/examples/HelloWorld.hs
+++ b/examples/HelloWorld.hs
@@ -4,9 +4,12 @@ import Network
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.ETag
 import Network.HTTP.Lucu.Httpd
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.ETag
 import Network.HTTP.Lucu.Httpd

+import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEType.Guess

 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Resource
 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Resource

+import Network.HTTP.Lucu.Resource.Tree

 import Network.HTTP.Lucu.Response
 import Network.URI
 import System.Posix.Signals
 import Network.HTTP.Lucu.Response
 import Network.URI
 import System.Posix.Signals


@@ -27,8 +30,8 @@ helloWorld
       , resIsGreedy         = False
       , resGet
           = Just $ do time <- liftIO $ getClockTime
       , resIsGreedy         = False
       , resGet
           = Just $ do time <- liftIO $ getClockTime

-                      foundEntity False "abcde" time
-                      setHeader "Content-Type" "text/plain"
+                      foundEntity (strongETag "abcde") time
+                      setContentType $ "text" +/+ "hello"

                       outputChunk "Hello, "
                       outputChunk "World!\n"
       , resHead   = Nothing
                       outputChunk "Hello, "
                       outputChunk "World!\n"
       , resHead   = Nothing


@@ -36,7 +39,7 @@ helloWorld
           = Just $ do str1 <- inputChunk 3
                       str2 <- inputChunk 3
                       str3 <- inputChunk 3
           = Just $ do str1 <- inputChunk 3
                       str2 <- inputChunk 3
                       str3 <- inputChunk 3

-                      setHeader "Content-Type" "text/plain"
+                      setContentType $ "text" +/+ "hello"

                       output ("[" ++ str1 ++ " - " ++ str2 ++ "#" ++ str3 ++ "]")
       , resPut    = Nothing
       , resDelete = Nothing
                       output ("[" ++ str1 ++ " - " ++ str2 ++ "#" ++ str3 ++ "]")
       , resPut    = Nothing
       , resDelete = Nothing