From 40c0d61e88920807a91b8f3c4419b08032988d76 Mon Sep 17 00:00:00 2001 From: pho Date: Fri, 13 Apr 2007 02:24:11 +0900 Subject: [PATCH] Network.HTTP.Lucu darcs-hash:20070412172411-62b54-6cdd9b7f068ce513d382b85fbee1b6e2cb1e7efb.gz --- Lucu.cabal | 13 +++---- Makefile | 5 ++- Network/HTTP/Lucu.hs | 54 ++++++++++++++++++++++++++++++ Network/HTTP/Lucu/Abortion.hs | 43 ++++++++++++------------ Network/HTTP/Lucu/Resource/Tree.hs | 13 ++++--- examples/HelloWorld.hs | 4 +-- 6 files changed, 95 insertions(+), 37 deletions(-) create mode 100644 Network/HTTP/Lucu.hs 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" -- 2.40.0