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 <pho at cielonegro dot org>
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
Network.HTTP.Lucu.Response
Network.HTTP.Lucu.StaticFile
Network.HTTP.Lucu.Utils
+
Other-Modules:
Network.HTTP.Lucu.Chunk
Network.HTTP.Lucu.ContentCoding
Network.HTTP.Lucu.Preprocess
Network.HTTP.Lucu.RequestReader
Network.HTTP.Lucu.ResponseWriter
+
Extensions:
BangPatterns, DeriveDataTypeable, ScopedTypeVariables, UnboxedTuples
+
ghc-options:
-Wall
-funbox-strict-fields
Buildable: True
else
Buildable: False
+
Main-Is: ImplantFile.hs
+
Extensions:
BangPatterns, ScopedTypeVariables, UnboxedTuples
+
ghc-options:
-Wall
-funbox-strict-fields
+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)
-- * Resource Tree
, ResourceDef(..)
+ , emptyResource
, ResTree
, mkResTree
module Network.HTTP.Lucu.Resource
(
- -- * Monad
+ -- * Types
Resource
, FormData(..)
, runRes -- private
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 は全部一致してゐるに決まってゐる（でな
-- | Repository of the resources in httpd.
module Network.HTTP.Lucu.Resource.Tree
( ResourceDef(..)
+ , emptyResource
+
, ResTree
, FallbackHandler
, 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.
--
-- ]
-- @
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)
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
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
+import System.FilePath.Posix
import System.Posix.Files
-- '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.
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
-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 $@ $<
+{-# LANGUAGE PackageImports #-}
import Control.Monad
-import Control.Monad.Trans
+import "mtl" Control.Monad.Trans
import Data.Time.Clock
import Network
import Network.HTTP.Lucu
projects / Lucu.git / commitdiff