Network.HTTP.Lucu

darcs-hash:20070412172411-62b54-6cdd9b7f068ce513d382b85fbee1b6e2cb1e7efb.gz

diff --git a/Lucu.cabal b/Lucu.cabal
index 8c315207237b50fbb7713dcc219d48947e1a8ec5..4ff675df0ef1f5f871b49a8692e1fe0f7e624652 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -1,5 +1,5 @@
 Name: Lucu
-Synopsis: HTTP Daemon Library
+Synopsis: HTTP Daemonic Library
 Version: 0.1
 License: PublicDomain
 Author: PHO
@@ -8,6 +8,7 @@ Category: Incomplete
 Build-Depends:
          base, mtl, network, stm, parsec, hxt, haskell-src, unix
 Exposed-Modules:
+        Network.HTTP.Lucu
         Network.HTTP.Lucu.Abortion
         Network.HTTP.Lucu.Chunk
         Network.HTTP.Lucu.Config
@@ -33,9 +34,9 @@ Exposed-Modules:
         Network.HTTP.Lucu.ResponseWriter
         Network.HTTP.Lucu.StaticFile
         Network.HTTP.Lucu.Utils
-ghc-options: -threaded -fglasgow-exts
+ghc-options: -threaded -fglasgow-exts -O3
 
-Executable: HelloWorld
-Main-Is: HelloWorld.hs
-Hs-Source-Dirs: ., examples
-ghc-options: -threaded -fglasgow-exts
\ No newline at end of file
+--Executable: HelloWorld
+--Main-Is: HelloWorld.hs
+--Hs-Source-Dirs: ., examples
+--ghc-options: -threaded -fglasgow-exts
\ No newline at end of file

diff --git a/Makefile b/Makefile
index 39dd65c69b739ebaacdf90d332ff70bba690c3ac..ee4aa8edaadd6b9a6de72e52a3cc365da48bf45e 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -19,7 +19,10 @@ clean:
        rm -rf dist Setup Setup.o Setup.hi .setup-config
        find . -name '*~' -exec rm -f {} \;
 
+doc:
+       ./Setup haddock
+
 install: build
        ./Setup install
 
-.PHONY: run build clean install
\ No newline at end of file
+.PHONY: run build clean install doc
\ No newline at end of file

diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
new file mode 100644 (file)
index 0000000..3f4350b
--- /dev/null
+++ b/Network/HTTP/Lucu.hs
@@ -0,0 +1,54 @@
+module Network.HTTP.Lucu
+    ( -- Abortion
+      abort
+    , abortA
+
+      -- Config
+    , Config(..)
+    , defaultConfig
+
+      -- ETag
+    , ETag
+    , mkETag
+    , strongETag
+    , weakETag
+
+      -- Httpd
+    , runHttpd
+
+      -- MIMEType
+    , MIMEType(..)
+    , (+/+)
+    , (+:+)
+    , (+=+)
+    
+      -- Request
+    , Method(..)
+    , Request(..)
+
+      -- Resource (driftTo だけは要らないが)
+    , module Network.HTTP.Lucu.Resource
+
+      -- Resource.Tree
+    , ResourceDef(..)
+    , ResTree
+    , mkResTree
+
+      -- Response
+    , StatusCode(..)
+    
+      -- StaticFile
+    , module Network.HTTP.Lucu.StaticFile
+    )
+    where
+
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.ETag
+import Network.HTTP.Lucu.Httpd
+import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Resource.Tree
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.StaticFile

diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs
index 6c03e8b6732bf5332bbf14792edfda23631a03aa..6f09f534429afc9a0f0428d228161e50c1b05744 100644 (file)
--- a/Network/HTTP/Lucu/Abortion.hs
+++ b/Network/HTTP/Lucu/Abortion.hs
@@ -58,24 +58,25 @@ abortA status headers msg
 -- がある。
 abortPage :: Config -> Maybe Request -> Maybe Response -> Abortion -> String
 abortPage conf reqM resM abo
-    = let msg    = case aboMessage abo of
-                     Just msg -> msg
-                     Nothing  -> let res' = case resM of
-                                              Just res -> res { resStatus = aboStatus abo }
-                                              Nothing  -> Response {
-                                                            resVersion = HttpVersion 1 1
-                                                          , resStatus  = aboStatus abo
-                                                          , resHeaders = []
-                                                          }
-                                     res  = foldl (.) id [setHeader name value
-                                                              | (name, value) <- aboHeaders abo]
-                                            $ res'
-                                 in
-                                   getDefaultPage conf reqM res
-          [html] = unsafePerformIO 
-                   $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
-                            >>>
-                            writeDocumentToString [(a_indent, v_1)]
-                          )
-      in
-        html
+    = case aboMessage abo of
+        Just msg
+            -> let [html] = unsafePerformIO 
+                            $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
+                                     >>>
+                                     writeDocumentToString [(a_indent, v_1)]
+                                   )
+               in
+                 html
+        Nothing
+            -> let res' = case resM of
+                            Just res -> res { resStatus = aboStatus abo }
+                            Nothing  -> Response {
+                                          resVersion = HttpVersion 1 1
+                                        , resStatus  = aboStatus abo
+                                        , resHeaders = []
+                                        }
+                   res  = foldl (.) id [setHeader name value
+                                            | (name, value) <- aboHeaders abo]
+                          $ res'
+               in
+                 getDefaultPage conf reqM res

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index 6fc49d477891adfd16b80f37466f21d6d865d6f3..e4fa662688ad24ccdf642283f0790350779ad659 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -1,6 +1,5 @@
 module Network.HTTP.Lucu.Resource.Tree
     ( ResourceDef(..)
-    , Resource
     , ResTree
     , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
 
@@ -32,10 +31,10 @@ import           System.IO.Error hiding (catch)
 import           Prelude hiding (catch)
 
 
-{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
-   れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
-   /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
-   される。 -}
+-- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
+-- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
+-- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
+-- 無視される。
 data ResourceDef = ResourceDef {
       resUsesNativeThread :: Bool
     , resIsGreedy         :: Bool
@@ -59,10 +58,10 @@ mkResTree list = processRoot list
                 children = processNonRoot nonRoots
             in
               if null roots then
-                  -- / にリソースが定義されない。/foo とかにはあるかも。
+                  -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
                   ResNode Nothing children
               else
-                  -- / がある。
+                  -- "/" がある。
                   let (_, def) = last roots
                   in 
                     ResNode (Just def) children

diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs
index 43e21d2b5e039c89b58e0e973072c02041310dab..20be0ce1a9969dd4dc49fd0bfe5b4984fdb0ae06 100644 (file)
--- a/examples/HelloWorld.hs
+++ b/examples/HelloWorld.hs
@@ -41,8 +41,8 @@ helloWorld
         resUsesNativeThread = False
       , resIsGreedy         = False
       , resGet
-          = Just $ do time <- liftIO $ getClockTime
-                      foundEntity (strongETag "abcde") time
+          = Just $ do --time <- liftIO $ getClockTime
+                      --foundEntity (strongETag "abcde") time
                       setContentType $ "text" +/+ "hello"
                       outputChunk "Hello, "
                       outputChunk "World!\n"