From 195fd2318fb0ad21c2fd60f61e7df72a8f25d12c Mon Sep 17 00:00:00 2001 From: pho Date: Fri, 11 Dec 2009 14:57:00 +0900 Subject: [PATCH] Changes from 0.4 to 0.4.1 Ignore-this: b9fb008aaf935609f83af26c28e87151 ------------------------- * Network.HTTP.Lucu.Resource: (Thanks: Voker57) - getPathInfo now un-escapes the resulting path info. This may break backward compatibility in very confusing way, if your code relies on the previous implementation. Sorry for any inconvenience. * Network.HTTP.Lucu.Resource.Tree: (Thanks: Voker57) - Fix: mkResTree wasn't working correctly for a resource path [""], which should be treated as same as [] the root. - Fix: Greedy resources on the root of resource tree wasn't really greedy. * Network.HTTP.Lucu.Resource.Tree: - New constant: emptyResource darcs-hash:20091211055700-62b54-d8105b747cc8a7629dcadea2d8fa7cbaf7fa959b.gz --- Lucu.cabal | 13 ++++-- NEWS | 21 +++++++++ Network/HTTP/Lucu.hs | 1 + Network/HTTP/Lucu/Resource.hs | 11 ++--- Network/HTTP/Lucu/Resource/Tree.hs | 69 +++++++++++++++++++++++------- Network/HTTP/Lucu/StaticFile.hs | 14 +++--- examples/HelloWorld.hs | 9 +--- examples/Makefile | 22 +++++++--- examples/SSL.hs | 3 +- 9 files changed, 118 insertions(+), 45 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index 8bb57b6..19ff8b2 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -8,7 +8,7 @@ Description: messing around FastCGI. It is also intended to be run behind a reverse-proxy so it doesn't have some facilities like logging, client filtering or such like. -Version: 0.4 +Version: 0.4.1 License: PublicDomain License-File: COPYING Author: PHO @@ -44,8 +44,9 @@ Flag build-lucu-implant-file Library Build-Depends: HsOpenSSL, base >= 4 && < 5, bytestring, containers, dataenc, - directory, haskell-src, hxt, mtl, network, stm, time, unix, - zlib + filepath, directory, haskell-src, hxt, mtl, network, stm, + time, unix, zlib + Exposed-Modules: Network.HTTP.Lucu Network.HTTP.Lucu.Abortion @@ -66,6 +67,7 @@ Library Network.HTTP.Lucu.Response Network.HTTP.Lucu.StaticFile Network.HTTP.Lucu.Utils + Other-Modules: Network.HTTP.Lucu.Chunk Network.HTTP.Lucu.ContentCoding @@ -79,8 +81,10 @@ Library Network.HTTP.Lucu.Preprocess Network.HTTP.Lucu.RequestReader Network.HTTP.Lucu.ResponseWriter + Extensions: BangPatterns, DeriveDataTypeable, ScopedTypeVariables, UnboxedTuples + ghc-options: -Wall -funbox-strict-fields @@ -90,9 +94,12 @@ Executable lucu-implant-file Buildable: True else Buildable: False + Main-Is: ImplantFile.hs + Extensions: BangPatterns, ScopedTypeVariables, UnboxedTuples + ghc-options: -Wall -funbox-strict-fields diff --git a/NEWS b/NEWS index ff66a4e..0eae2a6 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,24 @@ +Changes from 0.4 to 0.4.1 +------------------------- +* Network.HTTP.Lucu.Resource: (Thanks: Voker57) + + - getPathInfo now un-escapes the resulting path info. This may + break backward compatibility in very confusing way, if your code + relies on the previous implementation. Sorry for any + inconvenience. + +* Network.HTTP.Lucu.Resource.Tree: (Thanks: Voker57) + + - Fix: mkResTree wasn't working correctly for a resource path + [""], which should be treated as same as [] the root. + + - Fix: Greedy resources on the root of resource tree wasn't really + greedy. + +* Network.HTTP.Lucu.Resource.Tree: + + - New constant: emptyResource + Changes from 0.3.3 to 0.4 ------------------------- * Network.HTTP.Lucu.Resource: (Thanks: Voker57) diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 034502f..e6ae3ee 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -43,6 +43,7 @@ module Network.HTTP.Lucu -- * Resource Tree , ResourceDef(..) + , emptyResource , ResTree , mkResTree diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index e456fd2..ec5818c 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -60,7 +60,7 @@ module Network.HTTP.Lucu.Resource ( - -- * Monad + -- * Types Resource , FormData(..) , runRes -- private @@ -285,14 +285,15 @@ getResourcePath = do itr <- getInteraction return $! fromJust $! itrResourcePath itr --- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if --- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not --- greedy. See 'getResourcePath'. +-- |This is an analogy of CGI PATH_INFO. The result is +-- URI-unescaped. It is always @[]@ if the +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See +-- 'getResourcePath'. getPathInfo :: Resource [String] getPathInfo = do rsrcPath <- getResourcePath uri <- getRequestURI let reqPathStr = uriPath uri - reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""] + reqPath = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""] -- rsrcPath と reqPath の共通する先頭部分を reqPath か -- ら全部取り除くと、それは PATH_INFO のやうなものにな -- る。rsrcPath は全部一致してゐるに決まってゐる（でな diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 06fed17..660d8ff 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -3,6 +3,8 @@ -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree ( ResourceDef(..) + , emptyResource + , ResTree , FallbackHandler @@ -98,11 +100,37 @@ data ResourceDef = ResourceDef { , resDelete :: !(Maybe (Resource ())) } +-- |'emptyResource' is a resource definition with no actual +-- handlers. You can construct a 'ResourceDef' by selectively +-- overriding 'emptyResource'. It is defined as follows: +-- +-- @ +-- emptyResource = ResourceDef { +-- resUsesNativeThread = False +-- , resIsGreedy = False +-- , resGet = Nothing +-- , resHead = Nothing +-- , resPost = Nothing +-- , resPut = Nothing +-- , resDelete = Nothing +-- } +-- @ +emptyResource :: ResourceDef +emptyResource = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet = Nothing + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + -- |'ResTree' is an opaque structure which is a map from resource path -- to 'ResourceDef'. newtype ResTree = ResTree ResNode -- root だから Map ではない type ResSubtree = Map String ResNode -data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree +data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. -- @@ -112,18 +140,25 @@ data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree -- ] -- @ mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree xs = xs `seq` processRoot xs +mkResTree = processRoot . mapFirst canonicalisePath where + mapFirst :: (a -> a') -> [(a, b)] -> [(a', b)] + mapFirst f = map (\ (a, b) -> (f a, b)) + + canonicalisePath :: [String] -> [String] + canonicalisePath = filter (\ x -> x /= "") + processRoot :: [ ([String], ResourceDef) ] -> ResTree processRoot list = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list children = processNonRoot nonRoots in if null roots then - -- "/" にリソースが定義されない。"/foo" とかにはあるかも。 + -- The root has no resources. Maybe there's one at + -- somewhere like "/foo". ResTree (ResNode Nothing children) else - -- "/" がある。 + -- There is a root resource. let (_, def) = last roots in ResTree (ResNode (Just def) children) @@ -136,27 +171,31 @@ mkResTree xs = xs `seq` processRoot xs node name = let defs = [def | (path, def) <- list, path == [name]] in if null defs then - -- この位置にリソースが定義されない。 - -- もっと下にはあるかも。 + -- No resources are defined + -- here. Maybe there's one at + -- somewhere below this node. ResNode Nothing children else - -- この位置にリソースがある。 + -- There is a resource here. ResNode (Just $ last defs) children children = processNonRoot [(path, def) - | (_:path, def) <- list, not (null path)] + | (_:path, def) <- list] in subtree findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef)) findResource (ResTree (ResNode rootDefM subtree)) fbs uri - = do let pathStr = uriPath uri - path = [x | x <- splitBy (== '/') pathStr, x /= ""] - foundInTree = if null path then - do def <- rootDefM - return (path, def) - else - walkTree subtree path [] + = do let pathStr = uriPath uri + path = [unEscapeString x | x <- splitBy (== '/') pathStr, x /= ""] + haveGreedyRoot = case rootDefM of + Just def -> resIsGreedy def + Nothing -> False + foundInTree = if haveGreedyRoot || null path then + do def <- rootDefM + return ([], def) + else + walkTree subtree path [] if isJust foundInTree then return foundInTree else diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 5b0ce57..7ceb787 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -23,6 +23,7 @@ import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Utils +import System.FilePath.Posix import System.Posix.Files @@ -134,16 +135,15 @@ staticDir path -- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use -- 'staticDir' instead of this. handleStaticDir :: FilePath -> Resource () -handleStaticDir basePath - = basePath `seq` - do extraPath <- getPathInfo +handleStaticDir !basePath + = do extraPath <- getPathInfo securityCheck extraPath - let path = basePath ++ "/" ++ joinWith "/" extraPath + let path = basePath joinPath extraPath handleStaticFile path where securityCheck :: Monad m => [String] -> m () - securityCheck pathElems - = pathElems `seq` - when (any (== "..") pathElems) $ fail ("security error: " + securityCheck !pathElems + = when (any (== "..") pathElems) $ fail ("security error: " ++ joinWith "/" pathElems) +-- TODO: implement directory listing. diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index 00cb337..187bd34 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -23,22 +23,17 @@ main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } helloWorld :: ResourceDef helloWorld - = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet + = emptyResource { + resGet = Just $ do --time <- liftIO $ getClockTime --foundEntity (strongETag "abcde") time setContentType $ read "text/hello" outputChunk "Hello, " outputChunk "World!\n" - , resHead = Nothing , resPost = Just $ do str1 <- inputChunk 3 str2 <- inputChunk 3 str3 <- inputChunk 3 setContentType $ read "text/hello" output ("[" ++ str1 ++ " - " ++ str2 ++ "#" ++ str3 ++ "]") - , resPut = Nothing - , resDelete = Nothing } \ No newline at end of file diff --git a/examples/Makefile b/examples/Makefile index 69da81e..002f481 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -1,15 +1,23 @@ -build: MiseRafturai.hs SmallFile.hs SSL.hs - ghc --make HelloWorld -threaded -O3 -fwarn-unused-imports - ghc --make Implanted -threaded -O3 -fwarn-unused-imports - ghc --make ImplantedSmall -threaded -O3 -fwarn-unused-imports - ghc --make Multipart -threaded -O3 -fwarn-unused-imports - ghc --make SSL -threaded -O3 -fwarn-unused-imports +TARGETS = \ + HelloWorld \ + MiseRafturai \ + Implanted \ + ImplantedSmall \ + Multipart \ + SSL \ + StaticDir \ + $(NULL) + +build: $(TARGETS) + +%: %.hs + ghc --make $@ -threaded -O3 -fwarn-unused-imports run: build ./HelloWorld clean: - rm -f HelloWorld Implanted MiseRafturai.hs ImplantedSmall SmallFile.hs Multipart SSL *.hi *.o + rm -f $(TARGETS) *.hi *.o MiseRafturai.hs: mise-rafturai.html lucu-implant-file -m MiseRafturai -o $@ $< diff --git a/examples/SSL.hs b/examples/SSL.hs index 3efdcae..129316e 100644 --- a/examples/SSL.hs +++ b/examples/SSL.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE PackageImports #-} import Control.Monad -import Control.Monad.Trans +import "mtl" Control.Monad.Trans import Data.Time.Clock import Network import Network.HTTP.Lucu -- 2.40.0