From: pho <pho@cielonegro.org>
Date: Thu, 12 Apr 2007 17:24:11 +0000 (+0900)
Subject: Network.HTTP.Lucu
X-Git-Tag: RELEASE-0_2_1~57
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=40c0d61e88920807a91b8f3c4419b08032988d76;p=Lucu.git

Network.HTTP.Lucu

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

diff --git a/Lucu.cabal b/Lucu.cabal
index 8c31520..4ff675d 100644
--- 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 39dd65c..ee4aa8e 100644
--- 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
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 6c03e8b..6f09f53 100644
--- 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 6fc49d4..e4fa662 100644
--- 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 43e21d2..20be0ce 100644
--- 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"