Lucu 0.4 → 0.4.1
raw patch · 23 files changed
+282/−229 lines, 23 filesdep +filepath
Dependencies added: filepath
Files
- ImplantFile.hs +20/−19
- Lucu.cabal +10/−3
- NEWS +21/−0
- Network/HTTP/Lucu.hs +1/−0
- Network/HTTP/Lucu/Abortion.hs +1/−2
- Network/HTTP/Lucu/ContentCoding.hs +3/−1
- Network/HTTP/Lucu/DefaultPage.hs +9/−13
- Network/HTTP/Lucu/Format.hs +39/−35
- Network/HTTP/Lucu/Headers.hs +3/−2
- Network/HTTP/Lucu/Interaction.hs +13/−18
- Network/HTTP/Lucu/Parser.hs +3/−0
- Network/HTTP/Lucu/Parser/Http.hs +1/−1
- Network/HTTP/Lucu/Postprocess.hs +14/−21
- Network/HTTP/Lucu/Preprocess.hs +12/−16
- Network/HTTP/Lucu/Request.hs +12/−12
- Network/HTTP/Lucu/Resource.hs +6/−5
- Network/HTTP/Lucu/Resource/Tree.hs +61/−24
- Network/HTTP/Lucu/ResponseWriter.hs +24/−32
- Network/HTTP/Lucu/StaticFile.hs +9/−9
- Network/HTTP/Lucu/Utils.hs +1/−1
- examples/HelloWorld.hs +2/−7
- examples/Makefile +15/−7
- examples/SSL.hs +2/−1
ImplantFile.hs view
@@ -78,11 +78,11 @@ main = withOpenSSL $ do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs - when (not $ null errors)+ unless (null errors) $ do mapM_ putStr errors exitWith $ ExitFailure 1 - when (any (\ x -> x == OptHelp) opts)+ when (any (== OptHelp) opts) $ do printUsage exitWith ExitSuccess @@ -106,7 +106,7 @@ output <- openOutput opts eTag <- getETag opts input - let compParams = defaultCompressParams { compressLevel = BestCompression }+ let compParams = defaultCompressParams { compressLevel = bestCompression } gzippedData = compressWith compParams input originalLen = L.length input gzippedLen = L.length gzippedData@@ -371,12 +371,12 @@ _ -> False) opts -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を -- 小文字にしたものを使ふ。- defaultSymName = mkDefault modName- mkDefault = headToLower . getLastComp- headToLower = \ str -> case str of- [] -> error "module name must not be empty"- (x:xs) -> toLower x : xs- getLastComp = reverse . fst . break (== '.') . reverse+ defaultSymName = mkDefault modName+ mkDefault = headToLower . getLastComp+ headToLower str = case str of+ [] -> error "module name must not be empty"+ (x:xs) -> toLower x : xs+ getLastComp = reverse . fst . break (== '.') . reverse in case symNameOpts of [] -> return defaultSymName@@ -400,8 +400,8 @@ getLastModified :: FilePath -> IO UTCTime getLastModified "-" = getCurrentTime-getLastModified fpath = getFileStatus fpath- >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime+getLastModified fpath = fmap (posixSecondsToUTCTime . fromRational . toRational . modificationTime)+ $ getFileStatus fpath getETag :: [CmdOpt] -> Lazy.ByteString -> IO String@@ -411,25 +411,26 @@ _ -> False) opts in case eTagOpts of- [] -> getDigestByName "SHA1" >>= return . mkETagFromInput . fromJust+ [] -> fmap (mkETagFromInput . fromJust) (getDigestByName "SHA1") (OptETag str):[] -> return str _ -> error "too many --etag options." where mkETagFromInput :: Digest -> String- mkETagFromInput sha1 = "SHA-1:" ++ (toHex $ digestLBS sha1 input)+ mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input) - toHex :: [Char] -> String- toHex [] = ""- toHex (x:xs) = hexByte (fromEnum x) ++ toHex xs+ toHex :: String -> String+ toHex = foldr ((++) . hexByte . fromEnum) "" hexByte :: Int -> String hexByte n- = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []+ = [ hex4bit ((n `shiftR` 4) .&. 0x0F)+ , hex4bit ( n .&. 0x0F)+ ] hex4bit :: Int -> Char hex4bit n- | n < 10 = (chr $ ord '0' + n )- | n < 16 = (chr $ ord 'a' + n - 10)+ | n < 10 = chr $ ord '0' + n+ | n < 16 = chr $ ord 'a' + n - 10 | otherwise = undefined
Lucu.cabal view
@@ -8,7 +8,7 @@ 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>@@ -44,8 +44,9 @@ 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 @@ 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 @@ 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 @@ Buildable: True else Buildable: False+ Main-Is: ImplantFile.hs+ Extensions: BangPatterns, ScopedTypeVariables, UnboxedTuples+ ghc-options: -Wall -funbox-strict-fields
NEWS view
@@ -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)
Network/HTTP/Lucu.hs view
@@ -43,6 +43,7 @@ -- * Resource Tree , ResourceDef(..)+ , emptyResource , ResTree , mkResTree
Network/HTTP/Lucu/Abortion.hs view
@@ -109,7 +109,6 @@ Nothing -> let res' = res { resStatus = aboStatus abo } res'' = foldl (.) id [setHeader name value- | (name, value) <- fromHeaders $ aboHeaders abo]- $ res'+ | (name, value) <- fromHeaders $ aboHeaders abo] res' in getDefaultPage conf reqM res''
Network/HTTP/Lucu/ContentCoding.hs view
@@ -7,6 +7,7 @@ where import Data.Char+import Data.Ord import Data.Maybe import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http@@ -43,4 +44,5 @@ orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering orderAcceptEncodings (_, q1) (_, q2)- = fromMaybe 0 q1 `compare` fromMaybe 0 q2+ = comparing (fromMaybe 0) q1 q2+
Network/HTTP/Lucu/DefaultPage.hs view
@@ -29,9 +29,8 @@ getDefaultPage :: Config -> Maybe Request -> Response -> String-getDefaultPage conf req res- = conf `seq` req `seq` res `seq`- let msgA = getMsg req res+getDefaultPage !conf !req !res+ = let msgA = getMsg req res in unsafePerformIO $ do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA@@ -42,10 +41,9 @@ writeDefaultPage :: Interaction -> STM ()-writeDefaultPage itr- = itr `seq`- -- Content-Type が正しくなければ補完できない。- do res <- readItr itr itrResponse id+writeDefaultPage !itr+ -- Content-Type が正しくなければ補完できない。+ = do res <- readItr itr itrResponse id when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType) $ do reqM <- readItr itr itrRequest id @@ -57,9 +55,8 @@ mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree-mkDefaultPage conf status msgA- = conf `seq` status `seq` msgA `seq`- let (# sCode, sMsg #) = statusCode status+mkDefaultPage !conf !status !msgA+ = let (# sCode, sMsg #) = statusCode status sig = C8.unpack (cnfServerSoftware conf) ++ " at " ++ C8.unpack (cnfServerHost conf)@@ -85,9 +82,8 @@ {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-} getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree-getMsg req res- = req `seq` res `seq`- case resStatus res of+getMsg !req !res+ = case resStatus res of -- 1xx は body を持たない -- 2xx の body は補完しない
Network/HTTP/Lucu/Format.hs view
@@ -24,7 +24,7 @@ where fmt' :: Int -> String fmt' m- | m < base = (intToChar upperCase m) : []+ | m < base = [intToChar upperCase m] | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base) @@ -40,50 +40,54 @@ fmtDec2 :: Int -> String fmtDec2 n | n < 0 || n >= 100 = fmtInt 10 undefined 2 '0' False n -- fallback- | n < 10 = '0'- : intToChar undefined n- : []- | otherwise = intToChar undefined (n `div` 10)- : intToChar undefined (n `mod` 10)- : []+ | n < 10 = [ '0'+ , intToChar undefined n+ ]+ | otherwise = [ intToChar undefined (n `div` 10)+ , intToChar undefined (n `mod` 10)+ ] fmtDec3 :: Int -> String fmtDec3 n | n < 0 || n >= 1000 = fmtInt 10 undefined 3 '0' False n -- fallback- | n < 10 = '0' : '0'- : intToChar undefined n- : []- | n < 100 = '0'- : intToChar undefined ((n `div` 10) `mod` 10)- : intToChar undefined ( n `mod` 10)- : []- | otherwise = intToChar undefined ((n `div` 100) `mod` 10)- : intToChar undefined ((n `div` 10) `mod` 10)- : intToChar undefined ( n `mod` 10)- : []+ | n < 10 = [ '0'+ , '0'+ , intToChar undefined n+ ]+ | n < 100 = [ '0'+ , intToChar undefined ((n `div` 10) `mod` 10)+ , intToChar undefined ( n `mod` 10)+ ]+ | otherwise = [ intToChar undefined ((n `div` 100) `mod` 10)+ , intToChar undefined ((n `div` 10) `mod` 10)+ , intToChar undefined ( n `mod` 10)+ ] fmtDec4 :: Int -> String fmtDec4 n | n < 0 || n >= 10000 = fmtInt 10 undefined 4 '0' False n -- fallback- | n < 10 = '0' : '0' : '0'- : intToChar undefined n- : []- | n < 100 = '0' : '0'- : intToChar undefined ((n `div` 10) `mod` 10)- : intToChar undefined ( n `mod` 10)- : []- | n < 1000 = '0'- : intToChar undefined ((n `div` 100) `mod` 10)- : intToChar undefined ((n `div` 10) `mod` 10)- : intToChar undefined ( n `mod` 10)- : []- | otherwise = intToChar undefined ((n `div` 1000) `mod` 10)- : intToChar undefined ((n `div` 100) `mod` 10)- : intToChar undefined ((n `div` 10) `mod` 10)- : intToChar undefined ( n `mod` 10)- : []+ | n < 10 = [ '0'+ , '0'+ , '0'+ , intToChar undefined n+ ]+ | n < 100 = [ '0'+ , '0'+ , intToChar undefined ((n `div` 10) `mod` 10)+ , intToChar undefined ( n `mod` 10)+ ]+ | n < 1000 = [ '0'+ , intToChar undefined ((n `div` 100) `mod` 10)+ , intToChar undefined ((n `div` 10) `mod` 10)+ , intToChar undefined ( n `mod` 10)+ ]+ | otherwise = [ intToChar undefined ((n `div` 1000) `mod` 10)+ , intToChar undefined ((n `div` 100) `mod` 10)+ , intToChar undefined ((n `div` 10) `mod` 10)+ , intToChar undefined ( n `mod` 10)+ ] fmtHex :: Bool -> Int -> Int -> String
Network/HTTP/Lucu/Headers.hs view
@@ -21,6 +21,7 @@ import Data.List import Data.Map (Map) import qualified Data.Map as M+import Data.Ord import Data.Word import Foreign.ForeignPtr import Foreign.Ptr@@ -76,7 +77,7 @@ | otherwise = do c1 <- peek p1 c2 <- peek p2- case toLower (w2c c1) `compare` toLower (w2c c2) of+ case comparing (toLower . w2c) c1 c2 of EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1) x -> return x @@ -194,7 +195,7 @@ normalize :: String -> String normalize = trimBody . trim isWhiteSpace - trimBody = foldr (++) []+ trimBody = concat . map (\ s -> if head s == ' ' then " " else
Network/HTTP/Lucu/Interaction.hs view
@@ -84,8 +84,8 @@ newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction newInteraction !conf !addr !cert !req- = do request <- newTVarIO $ req- responce <- newTVarIO $ Response {+ = do request <- newTVarIO req+ responce <- newTVarIO Response { resVersion = HttpVersion 1 1 , resStatus = Ok , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)]@@ -115,7 +115,7 @@ wroteContinue <- newTVarIO False wroteHeader <- newTVarIO False - return $ Interaction {+ return Interaction { itrConfig = conf , itrRemoteAddr = addr , itrRemoteCert = cert@@ -150,33 +150,28 @@ writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()-writeItr itr accessor value- = itr `seq` accessor `seq` value `seq`- writeTVar (accessor itr) value+writeItr !itr !accessor !value+ = writeTVar (accessor itr) value readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b-readItr itr accessor reader- = itr `seq` accessor `seq` reader `seq`- readTVar (accessor itr) >>= return . reader+readItr !itr !accessor !reader+ = fmap reader $ readTVar (accessor itr) readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)-readItrF itr accessor reader- = itr `seq` accessor `seq` reader `seq`- readItr itr accessor (fmap reader)+readItrF !itr !accessor !reader+ = readItr itr accessor (fmap reader) {-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-} updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()-updateItr itr accessor updator- = itr `seq` accessor `seq` updator `seq`- do old <- readItr itr accessor id+updateItr !itr !accessor !updator+ = do old <- readItr itr accessor id writeItr itr accessor (updator old) updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()-updateItrF itr accessor updator- = itr `seq` accessor `seq` updator `seq`- updateItr itr accessor (fmap updator)+updateItrF !itr !accessor !updator+ = updateItr itr accessor (fmap updator) {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
Network/HTTP/Lucu/Parser.hs view
@@ -93,6 +93,9 @@ return !x = Parser $! return $! Success x fail _ = Parser $! return $! IllegalInput +instance Functor Parser where+ fmap f p = p >>= return . f+ -- |@'failP'@ is just a synonym for @'Prelude.fail' -- 'Prelude.undefined'@. failP :: Parser a
Network/HTTP/Lucu/Parser/Http.hs view
@@ -87,7 +87,7 @@ -- |'text' accepts one character which doesn't satisfy 'isCtl'. text :: Parser Char-text = satisfy (\ c -> not (isCtl c))+text = satisfy (not . isCtl) -- |'separator' accepts one character which satisfies 'isSeparator'. separator :: Parser Char
Network/HTTP/Lucu/Postprocess.hs view
@@ -56,13 +56,12 @@ -} postprocess :: Interaction -> STM ()-postprocess itr- = itr `seq`- do reqM <- readItr itr itrRequest id+postprocess !itr+ = do reqM <- readItr itr itrRequest id res <- readItr itr itrResponse id let sc = resStatus res - when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])+ unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError]) $ abortSTM InternalServerError [] $ Just ("The status code is not good for a final status: " ++ show sc)@@ -119,10 +118,8 @@ conn <- readHeader (C8.pack "Connection") case conn of Nothing -> return ()- Just value -> if value `noCaseEq` C8.pack "close" then- writeItr itr itrWillClose True- else- return ()+ Just value -> when (value `noCaseEq` C8.pack "close")+ $ writeItr itr itrWillClose True willClose <- readItr itr itrWillClose id when willClose@@ -132,20 +129,17 @@ $ writeTVar (itrWillDiscardBody itr) True readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)- readHeader name- = name `seq`- readItr itr itrResponse $ getHeader name+ readHeader !name+ = readItr itr itrResponse $ getHeader name updateRes :: (Response -> Response) -> STM ()- updateRes updator - = updator `seq`- updateItr itr itrResponse updator+ updateRes !updator + = updateItr itr itrResponse updator completeUnconditionalHeaders :: Config -> Response -> IO Response-completeUnconditionalHeaders conf res- = conf `seq` res `seq`- return res >>= compServer >>= compDate >>= return+completeUnconditionalHeaders !conf !res+ = compServer res >>= compDate where compServer res' = case getHeader (C8.pack "Server") res' of@@ -177,7 +171,6 @@ where mostlyEq :: UTCTime -> UTCTime -> Bool mostlyEq a b- = if utctDay a == utctDay b then- fromEnum (utctDayTime a) == fromEnum (utctDayTime b)- else- False+ = (utctDay a == utctDay b)+ &&+ (fromEnum (utctDayTime a) == fromEnum (utctDayTime b))
Network/HTTP/Lucu/Preprocess.hs view
@@ -100,7 +100,7 @@ portStr = case port of Just 80 -> Just ""- Just n -> Just $ ":" ++ show n+ Just n -> Just $ ':' : show n Nothing -> Nothing case portStr of Just str -> updateAuthority host (C8.pack str)@@ -110,10 +110,10 @@ -- いと思ふ。stderr？ Nothing -> setStatus InternalServerError else- do case getHeader (C8.pack "Host") req of- Just str -> let (host, portStr) = parseHost str- in updateAuthority host portStr- Nothing -> setStatus BadRequest+ case getHeader (C8.pack "Host") req of+ Just str -> let (host, portStr) = parseHost str+ in updateAuthority host portStr+ Nothing -> setStatus BadRequest parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)@@ -148,13 +148,11 @@ case getHeader (C8.pack "Transfer-Encoding") req of Nothing -> return ()- Just value -> if value `noCaseEq` C8.pack "identity" then- return ()- else- if value `noCaseEq` C8.pack "chunked" then- writeItr itr itrRequestIsChunked True- else- setStatus NotImplemented+ Just value -> unless (value `noCaseEq` C8.pack "identity")+ $ if value `noCaseEq` C8.pack "chunked" then+ writeItr itr itrRequestIsChunked True+ else+ setStatus NotImplemented case getHeader (C8.pack "Content-Length") req of Nothing -> return ()@@ -167,7 +165,5 @@ case getHeader (C8.pack "Connection") req of Nothing -> return ()- Just value -> if value `noCaseEq` C8.pack "close" then- writeItr itr itrWillClose True- else- return ()+ Just value -> when (value `noCaseEq` C8.pack "close")+ $ writeItr itr itrWillClose True
Network/HTTP/Lucu/Request.hs view
@@ -67,19 +67,19 @@ methodP :: Parser Method-methodP = (let methods = [ ("OPTIONS", OPTIONS)- , ("GET" , GET )- , ("HEAD" , HEAD )- , ("POST" , POST )- , ("PUT" , PUT )- , ("DELETE" , DELETE )- , ("TRACE" , TRACE )- , ("CONNECT", CONNECT)- ]- in foldl (<|>) failP $ map (\ (str, mth)- -> string str >> return mth) methods)+methodP = ( let methods = [ ("OPTIONS", OPTIONS)+ , ("GET" , GET )+ , ("HEAD" , HEAD )+ , ("POST" , POST )+ , ("PUT" , PUT )+ , ("DELETE" , DELETE )+ , ("TRACE" , TRACE )+ , ("CONNECT", CONNECT)+ ]+ in choice $ map (\ (str, mth)+ -> string str >> return mth) methods ) <|>- token >>= return . ExtensionMethod+ fmap ExtensionMethod token uriP :: Parser URI
Network/HTTP/Lucu/Resource.hs view
@@ -60,7 +60,7 @@ module Network.HTTP.Lucu.Resource (- -- * Monad+ -- * Types Resource , FormData(..) , runRes -- private@@ -285,14 +285,15 @@ 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 は全部一致してゐるに決まってゐる（でな
Network/HTTP/Lucu/Resource/Tree.hs view
@@ -3,6 +3,8 @@ -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree ( ResourceDef(..)+ , emptyResource+ , ResTree , FallbackHandler @@ -13,6 +15,7 @@ ) where +import Control.Arrow import Control.Concurrent import Control.Concurrent.STM import Control.Exception@@ -98,11 +101,37 @@ , 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 +141,22 @@ -- ] -- @ mkResTree :: [ ([String], ResourceDef) ] -> ResTree-mkResTree xs = xs `seq` processRoot xs+mkResTree = processRoot . map (first canonicalisePath) where+ canonicalisePath :: [String] -> [String]+ canonicalisePath = filter (/= "")+ 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 +169,31 @@ 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@@ -199,10 +236,10 @@ driftTo Done ) itr )- $ \ exc -> processException exc+ processException where fork :: IO () -> IO ThreadId- fork = if (resUsesNativeThread def)+ fork = if resUsesNativeThread def then forkOS else forkIO @@ -223,12 +260,12 @@ setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods) allowedMethods :: [String]- allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]- , methods resHead ["GET", "HEAD"]- , methods resPost ["POST"]- , methods resPut ["PUT"]- , methods resDelete ["DELETE"]- ]+ allowedMethods = nub $ concat [ methods resGet ["GET"]+ , methods resHead ["GET", "HEAD"]+ , methods resPost ["POST"]+ , methods resPut ["PUT"]+ , methods resDelete ["DELETE"]+ ] methods :: (ResourceDef -> Maybe a) -> [String] -> [String] methods f xs = case f def of@@ -253,7 +290,7 @@ if state <= DecidingHeader then flip runRes itr $ do setStatus $ aboStatus abo- mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo+ mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo output $ abortPage conf reqM res abo else when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
Network/HTTP/Lucu/ResponseWriter.hs view
@@ -35,30 +35,28 @@ awaitSomethingToWrite :: IO () awaitSomethingToWrite = {-# SCC "awaitSomethingToWrite" #-}- do action- <- atomically $!- -- キューが空でなくなるまで待つ- do queue <- readTVar tQueue- -- GettingBody 状態にあり、Continue が期待され- -- てゐて、それがまだ送信前なのであれば、- -- Continue を送信する。- case S.viewr queue of- EmptyR -> retry- _ :> itr -> do state <- readItr itr itrState id+ join $!+ atomically $!+ -- キューが空でなくなるまで待つ+ do queue <- readTVar tQueue+ -- GettingBody 状態にあり、Continue が期待されてゐ+ -- て、それがまだ送信前なのであれば、Continue を送+ -- 信する。+ case S.viewr queue of+ EmptyR -> retry+ _ :> itr -> do state <- readItr itr itrState id - if state == GettingBody then- writeContinueIfNecessary itr- else- if state >= DecidingBody then- writeHeaderOrBodyIfNecessary itr- else- retry- action+ if state == GettingBody then+ writeContinueIfNecessary itr+ else+ if state >= DecidingBody then+ writeHeaderOrBodyIfNecessary itr+ else+ retry writeContinueIfNecessary :: Interaction -> STM (IO ())- writeContinueIfNecessary itr+ writeContinueIfNecessary !itr = {-# SCC "writeContinueIfNecessary" #-}- itr `seq` do expectedContinue <- readItr itr itrExpectedContinue id if expectedContinue then do wroteContinue <- readItr itr itrWroteContinue id@@ -75,13 +73,12 @@ retry writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())- writeHeaderOrBodyIfNecessary itr+ writeHeaderOrBodyIfNecessary !itr -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が -- 空でなければ、それを出力する。空である時は、もし状態が -- Done であれば後処理をする。 = {-# SCC "writeHeaderOrBodyIfNecessary" #-}- itr `seq` do wroteHeader <- readItr itr itrWroteHeader id if not wroteHeader then@@ -100,9 +97,8 @@ return $! writeBodyChunk itr writeContinue :: Interaction -> IO ()- writeContinue itr+ writeContinue !itr = {-# SCC "writeContinue" #-}- itr `seq` do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue@@ -115,9 +111,8 @@ awaitSomethingToWrite writeHeader :: Interaction -> IO ()- writeHeader itr+ writeHeader !itr = {-# SCC "writeHeader" #-}- itr `seq` do res <- atomically $! do writeItr itr itrWroteHeader True readItr itr itrResponse id hPutResponse h res@@ -125,9 +120,8 @@ awaitSomethingToWrite writeBodyChunk :: Interaction -> IO ()- writeBodyChunk itr+ writeBodyChunk !itr = {-# SCC "writeBodyChunk" #-}- itr `seq` do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id willChunkBody <- atomically $! readItr itr itrWillChunkBody id chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id@@ -145,18 +139,16 @@ awaitSomethingToWrite finishBodyChunk :: Interaction -> IO ()- finishBodyChunk itr+ finishBodyChunk !itr = {-# SCC "finishBodyChunk" #-}- itr `seq` do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id willChunkBody <- atomically $! readItr itr itrWillChunkBody id when (not willDiscardBody && willChunkBody) $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h finalize :: Interaction -> IO ()- finalize itr+ finalize !itr = {-# SCC "finalize" #-}- itr `seq` do finishBodyChunk itr willClose <- atomically $! do queue <- readTVar tQueue
Network/HTTP/Lucu/StaticFile.hs view
@@ -23,6 +23,7 @@ import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Utils+import System.FilePath.Posix import System.Posix.Files @@ -64,7 +65,7 @@ $ abort Forbidden [] Nothing -- 讀める tag <- liftIO $ generateETagFromFile path- lastMod <- return $ posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat+ let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat foundEntity tag lastMod -- MIME Type を推定@@ -74,7 +75,7 @@ Just mime -> setContentType mime -- 實際にファイルを讀んで送る- (liftIO $ B.readFile path) >>= outputLBS+ liftIO (B.readFile path) >>= outputLBS else abort Forbidden [] Nothing else@@ -134,16 +135,15 @@ -- '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.
Network/HTTP/Lucu/Utils.hs view
@@ -19,7 +19,7 @@ splitBy :: (a -> Bool) -> [a] -> [[a]] splitBy isSep src = case break isSep src- of (last , [] ) -> last : []+ of (last , [] ) -> [last] (first, _sep:rest) -> first : splitBy isSep rest -- |> joinWith ":" ["ab", "c", "def"]
examples/HelloWorld.hs view
@@ -23,22 +23,17 @@ 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 }
examples/Makefile view
@@ -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 $@ $<
examples/SSL.hs view
@@ -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