From: pho Date: Thu, 12 Apr 2007 16:40:42 +0000 (+0900) Subject: staticDir X-Git-Tag: RELEASE-0_2_1~58 X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=854f6d1709d468f7e1bf0db2dcd2d30de6bd5f5e;p=Lucu.git staticDir darcs-hash:20070412164042-62b54-1f3cfc81356c7d9d53b5b25b77c8539789857843.gz --- diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 5f28c55..68c6c0e 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -24,11 +24,16 @@ import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response data Interaction = Interaction { - itrConfig :: Config - , itrRemoteHost :: HostName - , itrRequest :: Maybe Request - , itrResponse :: TVar (Maybe Response) - + itrConfig :: Config + , itrRemoteHost :: HostName + , itrResourcePath :: Maybe [String] + , itrRequest :: Maybe Request + , itrResponse :: TVar (Maybe Response) + + -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす + -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重 + -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって + -- からにすべき。 , itrRequestHasBody :: TVar Bool , itrRequestIsChunked :: TVar Bool , itrExpectedContinue :: TVar Bool @@ -99,10 +104,11 @@ newInteraction conf host req wroteHeader <- newTVarIO False return $ Interaction { - itrConfig = conf - , itrRemoteHost = host - , itrRequest = req - , itrResponse = responce + itrConfig = conf + , itrRemoteHost = host + , itrResourcePath = Nothing + , itrRequest = req + , itrResponse = responce , itrRequestHasBody = requestHasBody , itrRequestIsChunked = requestIsChunked diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 7fe5820..12f19e0 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -25,7 +25,7 @@ type ExtMap = Map String MIMEType guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType guessTypeByFileName extMap fpath - = let ext = head $ reverse $ splitBy (== '.') fpath + = let ext = last $ splitBy (== '.') fpath in M.lookup ext extMap >>= return diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 260bbcc..80fc722 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -106,6 +106,10 @@ postprocess itr updateRes itr $ deleteHeader "Content-Length" + cType <- readHeader itr "Content-Type" + when (cType == Nothing) + $ updateRes itr $ setHeader "Content-Type" "application/octet-stream" + if canHaveBody then do teM <- readHeader itr "Transfer-Encoding" if reqVer == HttpVersion 1 1 then @@ -130,10 +134,6 @@ postprocess itr $ Just ("Transfer-Encoding must be `identity' because " ++ "this is an HTTP/1.0 request: " ++ te) - - cType <- readHeader itr "Content-Type" - when (cType == Nothing) - $ updateRes itr $ setHeader "Content-Type" "application/octet-stream" else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す do updateRes itr $ deleteHeader "Transfer-Encoding" diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 00d3b03..9b54ca5 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -85,8 +85,8 @@ requestReader cnf tree h host tQueue Nothing -- Resource が無かった -> acceptRequestForNonexistentResource itr input - Just rsrcDef -- あった - -> acceptRequestForExistentResource itr input rsrcDef + Just (rsrcPath, rsrcDef) -- あった + -> acceptRequestForExistentResource itr input rsrcPath rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) @@ -111,9 +111,10 @@ requestReader cnf tree h host tQueue enqueue itr return $ acceptRequest input - acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ()) - acceptRequestForExistentResource itr input rsrcDef - = do requestHasBody <- readItr itr itrRequestHasBody id + acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ()) + acceptRequestForExistentResource oldItr input rsrcPath rsrcDef + = do let itr = oldItr { itrResourcePath = Just rsrcPath } + requestHasBody <- readItr itr itrRequestHasBody id enqueue itr return $ do runResource rsrcDef itr if requestHasBody then diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 28ce462..7b1b26a 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,10 +1,15 @@ module Network.HTTP.Lucu.Resource ( Resource - , getConfig -- Resource Config - , getMethod -- Resource Method - , getHeader -- String -> Resource (Maybe String) - , getAccept -- Resource [MIMEType] + , getConfig -- Resource Config + , getRequest -- Resource Request + , getMethod -- Resource Method + , getRequestURI -- Resource URI + , getResourcePath -- Resource [String] + , getPathInfo -- Resource [String] + + , getHeader -- String -> Resource (Maybe String) + , getAccept -- Resource [MIMEType] , getContentType -- Resource (Maybe MIMEType) , foundEntity -- ETag -> ClockTime -> Resource () @@ -67,9 +72,37 @@ getConfig = do itr <- ask return $ itrConfig itr +getRequest :: Resource Request +getRequest = do itr <- ask + return $ fromJust $ itrRequest itr + + getMethod :: Resource Method -getMethod = do itr <- ask - return $ reqMethod $ fromJust $ itrRequest itr +getMethod = do req <- getRequest + return $ reqMethod req + + +getRequestURI :: Resource URI +getRequestURI = do req <- getRequest + return $ reqURI req + + +getResourcePath :: Resource [String] +getResourcePath = do itr <- ask + return $ fromJust $ itrResourcePath itr + + +getPathInfo :: Resource [String] +getPathInfo = do rsrcPath <- getResourcePath + reqURI <- getRequestURI + let reqPathStr = uriPath reqURI + reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""] + -- rsrcPath と reqPath の共通する先頭部分を reqPath か + -- ら全部取り除くと、それは PATH_INFO のやうなものにな + -- る。rsrcPath は全部一致してゐるに決まってゐる（でな + -- ければこの Resource が撰ばれた筈が無い）ので、 + -- rsrcPath の長さの分だけ削除すれば良い。 + return $ drop (length rsrcPath) reqPath getHeader :: String -> Resource (Maybe String) @@ -414,18 +447,22 @@ outputChunk = outputChunkBS . B.pack outputChunkBS :: ByteString -> Resource () outputChunkBS str = do driftTo DecidingBody - unless (B.null str) - $ do itr <- ask + itr <- ask + + let limit = cnfMaxOutputChunkLength $ itrConfig itr + when (limit <= 0) + $ fail ("cnfMaxOutputChunkLength must be positive: " + ++ show limit) - let limit = cnfMaxOutputChunkLength $ itrConfig itr - when (limit <= 0) - $ fail ("cnfMaxOutputChunkLength must be positive: " - ++ show limit) + discardBody <- liftIO $ atomically $ + readItr itr itrWillDiscardBody id - sendChunks str limit + unless (discardBody) + $ sendChunks str limit - liftIO $ atomically $ - writeItr itr itrBodyIsNull False + unless (B.null str) + $ liftIO $ atomically $ + writeItr itr itrBodyIsNull False where sendChunks :: ByteString -> Int -> Resource () sendChunks str limit diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 28a94a4..6fc49d4 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -4,7 +4,7 @@ module Network.HTTP.Lucu.Resource.Tree , ResTree , mkResTree -- [ ([String], ResourceDef) ] -> ResTree - , findResource -- ResTree -> URI -> Maybe ResourceDef + , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef) , runResource -- ResourceDef -> Interaction -> IO ThreadId ) where @@ -20,6 +20,7 @@ import Data.Map (Map) import Data.Maybe import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Response @@ -86,30 +87,33 @@ mkResTree list = processRoot list subtree -findResource :: ResTree -> URI -> Maybe ResourceDef +findResource :: ResTree -> URI -> Maybe ([String], ResourceDef) findResource (ResNode rootDefM subtree) uri = let pathStr = uriPath uri path = [x | x <- splitBy (== '/') pathStr, x /= ""] in if null path then - rootDefM + do def <- rootDefM + return (path, def) else - walkTree subtree path + walkTree subtree path [] where - walkTree :: ResSubtree -> [String] -> Maybe ResourceDef + walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef) - walkTree subtree (name:[]) + walkTree subtree (name:[]) soFar = case M.lookup name subtree of Nothing -> Nothing - Just (ResNode defM _) -> defM + Just (ResNode defM _) -> do def <- defM + return (soFar ++ [name], def) - walkTree subtree (x:xs) + walkTree subtree (x:xs) soFar = case M.lookup x subtree of Nothing -> Nothing Just (ResNode defM children) -> case defM of Just (ResourceDef { resIsGreedy = True }) - -> defM - _ -> walkTree children xs + -> do def <- defM + return (soFar ++ [x], def) + _ -> walkTree children xs (soFar ++ [x]) runResource :: ResourceDef -> Interaction -> IO ThreadId @@ -177,7 +181,7 @@ runResource def itr -- FIXME: 同じ名前で複數の値があった時は、こ -- れではまずいと思ふ。 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo - setHeader "Content-Type" "application/xhtml+xml" + setContentType ("application" +/+ "xhtml+xml") output $ abortPage conf reqM resM abo else hPutStrLn stderr $ show abo diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 89b7832..e544340 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,6 +1,9 @@ module Network.HTTP.Lucu.StaticFile ( staticFile -- FilePath -> ResourceDef , handleStaticFile -- FilePath -> Resource () + + , staticDir -- FilePath -> ResourceDef + , handleStaticDir -- FilePath -> Resource () ) where @@ -15,6 +18,7 @@ import Network.HTTP.Lucu.MIMEType.Guess import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Utils import System.Directory import System.Posix.Files import Text.Printf @@ -35,8 +39,8 @@ staticFile path handleStaticFile :: FilePath -> Resource () handleStaticFile path - = do exist <- liftIO $ fileExist path - if exist then + = do isFile <- liftIO $ doesFileExist path + if isFile then -- 存在はした。讀めるかどうかは知らない。 do readable <- liftIO $ fileAccess path True False False unless readable @@ -57,7 +61,11 @@ handleStaticFile path -- 實際にファイルを讀んで送る (liftIO $ B.readFile path) >>= outputBS else - foundNoEntity Nothing + do isDir <- liftIO $ doesDirectoryExist path + if isDir then + abort Forbidden [] Nothing + else + foundNoEntity Nothing -- inode-size-lastmod @@ -68,3 +76,24 @@ generateETagFromFile path size = fromEnum $ fileSize stat lastmod = fromEnum $ modificationTime stat return $ strongETag $ printf "%x-%x-%x" inode size lastmod + + +staticDir :: FilePath -> ResourceDef +staticDir path + = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = True + , resGet = Just $ handleStaticDir path + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + + +handleStaticDir :: FilePath -> Resource () +handleStaticDir basePath + = do extraPath <- getPathInfo + let path = basePath ++ "/" ++ joinWith "/" extraPath + + handleStaticFile path diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 58da6f5..5dc1584 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -13,6 +13,7 @@ import Data.Char import Data.List import Foreign import Foreign.C +import Network.URI splitBy :: (a -> Bool) -> [a] -> [[a]] diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index a2c6d50..43e21d2 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -20,8 +20,15 @@ main :: IO () main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } resources = mkResTree [ ( [] , helloWorld ) - , ( ["compilers"] - , staticFile "/etc/compilers" ) + + , ( ["index.html"] + , staticFile "/Users/admin/Sites/index.html" ) + + , ( ["urandom"] + , staticFile "/dev/urandom" ) + + , ( ["inc"] + , staticDir "/usr/include" ) ] in do installHandler sigPIPE Ignore Nothing