From a44a96d95b5fcbaf24a21c0336046ce0c3bab614 Mon Sep 17 00:00:00 2001 From: pho Date: Tue, 10 Apr 2007 01:00:59 +0900 Subject: [PATCH] staticFile darcs-hash:20070409160059-62b54-cc0a0ad8cc1b98d2781bab459ca2065a1a0ab585.gz --- Lucu.cabal | 4 +- Network/HTTP/Lucu/Abortion.hs | 44 ++++++++++++----- Network/HTTP/Lucu/Config.hs | 31 ++++++------ Network/HTTP/Lucu/MIMEType/Guess.hs | 22 +++++++-- Network/HTTP/Lucu/Postprocess.hs | 16 +++--- Network/HTTP/Lucu/Resource.hs | 76 +++++++++++++++++++++-------- Network/HTTP/Lucu/Resource/Tree.hs | 19 +++++--- Network/HTTP/Lucu/ResponseWriter.hs | 1 + Network/HTTP/Lucu/StaticFile.hs | 63 ++++++++++++++++++++++-- examples/HelloWorld.hs | 7 ++- 10 files changed, 211 insertions(+), 72 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index 529e438..8c31520 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -6,7 +6,7 @@ Author: PHO Homepage: http://ccm.sherry.jp/ Category: Incomplete Build-Depends: - base, mtl, network, stm, parsec, hxt, haskell-src + base, mtl, network, stm, parsec, hxt, haskell-src, unix Exposed-Modules: Network.HTTP.Lucu.Abortion Network.HTTP.Lucu.Chunk @@ -18,6 +18,7 @@ Exposed-Modules: Network.HTTP.Lucu.Httpd Network.HTTP.Lucu.Interaction Network.HTTP.Lucu.MIMEType + Network.HTTP.Lucu.MIMEType.DefaultExtensionMap Network.HTTP.Lucu.MIMEType.Guess Network.HTTP.Lucu.Parser Network.HTTP.Lucu.Parser.Http @@ -30,6 +31,7 @@ Exposed-Modules: Network.HTTP.Lucu.Resource.Tree Network.HTTP.Lucu.Response Network.HTTP.Lucu.ResponseWriter + Network.HTTP.Lucu.StaticFile Network.HTTP.Lucu.Utils ghc-options: -threaded -fglasgow-exts diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index ff69157..6c03e8b 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,9 +1,9 @@ module Network.HTTP.Lucu.Abortion ( Abortion(..) - , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a - , abortSTM -- StatusCode -> [ (String, String) ] -> String -> STM a - , abortA -- ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c - , aboPage -- Config -> Abortion -> String + , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a + , abortSTM -- StatusCode -> [ (String, String) ] -> Maybe String -> STM a + , abortA -- ArrowIO a => StatusCode -> [ (String, String) ] -> Maybe String -> a b c + , abortPage -- Config -> Maybe Request -> Maybe Response -> Abortion -> String ) where @@ -17,6 +17,8 @@ import Data.Dynamic import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import System.IO.Unsafe import Text.XML.HXT.Arrow.WriteDocument @@ -28,11 +30,11 @@ import Text.XML.HXT.DOM.XmlKeywords data Abortion = Abortion { aboStatus :: StatusCode , aboHeaders :: Headers - , aboMessage :: String + , aboMessage :: Maybe String } deriving (Show, Typeable) -abort :: MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a +abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a abort status headers msg = let abo = Abortion status headers msg exc = DynException (toDyn abo) @@ -40,20 +42,38 @@ abort status headers msg liftIO $ throwIO exc -abortSTM :: StatusCode -> [ (String, String) ] -> String -> STM a +abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a abortSTM status headers msg = unsafeIOToSTM $ abort status headers msg -abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c +abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> Maybe String -> a b c abortA status headers msg = arrIO0 $ abort status headers msg -aboPage :: Config -> Abortion -> String -aboPage conf abo - = let [html] = unsafePerformIO - $ runX ( mkDefaultPage conf (aboStatus abo) (txt $ aboMessage abo) +-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 +-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な +-- ければならない。しかもその時は resM から Response を捏造までする必要 +-- がある。 +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)] ) diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 999672f..2f63353 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -9,26 +9,29 @@ import Data.Map (Map) import Network import Network.BSD import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap import System.IO.Unsafe data Config = Config { - cnfServerSoftware :: String - , cnfServerHost :: HostName - , cnfServerPort :: PortID - , cnfMaxPipelineDepth :: Int - , cnfMaxEntityLength :: Int - , cnfMaxURILength :: Int - , cnfExtToMIMEType :: Map String MIMEType + cnfServerSoftware :: String + , cnfServerHost :: HostName + , cnfServerPort :: PortID + , cnfMaxPipelineDepth :: Int + , cnfMaxEntityLength :: Int + , cnfMaxURILength :: Int + , cnfMaxOutputChunkLength :: Int + , cnfExtToMIMEType :: Map String MIMEType } defaultConfig = Config { - cnfServerSoftware = "Lucu/1.0" - , cnfServerHost = unsafePerformIO getHostName - , cnfServerPort = Service "http" - , cnfMaxPipelineDepth = 100 - , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB - , cnfMaxURILength = 4 * 1024 -- 4 KiB - , cnfExtToMIMEType = undefined -- FIXME + cnfServerSoftware = "Lucu/1.0" + , cnfServerHost = unsafePerformIO getHostName + , cnfServerPort = Service "http" + , cnfMaxPipelineDepth = 100 + , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB + , cnfMaxURILength = 4 * 1024 -- 4 KiB + , cnfMaxOutputChunkLength = 5 * 1024 * 1024 -- 5 MiB + , cnfExtToMIMEType = defaultExtensionMap } diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 309f7fe..7fe5820 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,6 +1,9 @@ module Network.HTTP.Lucu.MIMEType.Guess - ( parseExtMapFile -- FilePath -> IO (Map String MIMEType) - , outputExtMapAsHS -- Map String MIMEType -> FilePath -> IO () + ( ExtMap + , guessTypeByFileName -- ExtMap -> FilePath -> Maybe MIMEType + + , parseExtMapFile -- FilePath -> IO ExtMap + , outputExtMapAsHS -- ExtMap -> FilePath -> IO () ) where @@ -14,11 +17,20 @@ import Language.Haskell.Syntax import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils import System.IO -import Debug.Trace +type ExtMap = Map String MIMEType + + +guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType +guessTypeByFileName extMap fpath + = let ext = head $ reverse $ splitBy (== '.') fpath + in + M.lookup ext extMap >>= return + -parseExtMapFile :: FilePath -> IO (Map String MIMEType) +parseExtMapFile :: FilePath -> IO ExtMap parseExtMapFile fpath = do file <- B.readFile fpath case parse (allowEOF extMapP) file of @@ -56,7 +68,7 @@ compile = M.fromList . foldr (++) [] . map tr tr (mime, exts) = [ (ext, mime) | ext <- exts ] -outputExtMapAsHS :: Map String MIMEType -> FilePath -> IO () +outputExtMapAsHS :: ExtMap -> FilePath -> IO () outputExtMapAsHS extMap fpath = let hsModule = HsModule undefined modName (Just exports) imports decls modName = Module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 7d7e147..260bbcc 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -71,16 +71,16 @@ postprocess itr when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError]) $ abortSTM InternalServerError [] - ("The status code is not good for a final status: " - ++ show sc) + $ Just ("The status code is not good for a final status: " + ++ show sc) when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing) $ abortSTM InternalServerError [] - ("The status was " ++ show sc ++ " but no Allow header.") + $ Just ("The status was " ++ show sc ++ " but no Allow header.") when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing) $ abortSTM InternalServerError [] - ("The status code was " ++ show sc ++ " but no Location header.") + $ Just ("The status code was " ++ show sc ++ " but no Location header.") when (itrRequest itr /= Nothing) $ relyOnRequest itr @@ -117,9 +117,9 @@ postprocess itr in when (teList == [] || last teList /= "chunked") $ abortSTM InternalServerError [] - ("Transfer-Encoding must end with `chunked' " - ++ "because this is an HTTP/1.1 request: " - ++ te) + $ Just ("Transfer-Encoding must end with `chunked' " + ++ "because this is an HTTP/1.1 request: " + ++ te) writeItr itr itrWillChunkBody True else @@ -127,7 +127,7 @@ postprocess itr Nothing -> return () Just "identity" -> return () Just te -> abortSTM InternalServerError [] - ("Transfer-Encoding must be `identity' because " + $ Just ("Transfer-Encoding must be `identity' because " ++ "this is an HTTP/1.0 request: " ++ te) diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 3ac8fb9..28ce462 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,6 +1,7 @@ module Network.HTTP.Lucu.Resource ( Resource + , getConfig -- Resource Config , getMethod -- Resource Method , getHeader -- String -> Resource (Maybe String) , getAccept -- Resource [MIMEType] @@ -61,6 +62,11 @@ import System.Time type Resource a = ReaderT Interaction IO a +getConfig :: Resource Config +getConfig = do itr <- ask + return $ itrConfig itr + + getMethod :: Resource Method getMethod = do itr <- ask return $ reqMethod $ fromJust $ itrRequest itr @@ -124,8 +130,9 @@ foundETag tag -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 -> when (not $ any (== tag) tags) - $ abort PreconditionFailed [] ("The entity tag doesn't match: " ++ list) - _ -> abort BadRequest [] ("Unparsable If-Match: " ++ fromJust ifMatch) + $ abort PreconditionFailed [] + $ Just ("The entity tag doesn't match: " ++ list) + _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch) let statusForNoneMatch = if method == GET || method == HEAD then NotModified @@ -136,12 +143,12 @@ foundETag tag ifNoneMatch <- getHeader "If-None-Match" case ifNoneMatch of Nothing -> return () - Just "*" -> abort statusForNoneMatch [] ("The entity tag matches: *") + Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *") Just list -> case parseStr eTagListP list of (Success tags, _) -> when (any (== tag) tags) - $ abort statusForNoneMatch [] ("The entity tag matches: " ++ list) - _ -> abort BadRequest [] ("Unparsable If-None-Match: " ++ list) + $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list) + _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list) driftTo GettingBody @@ -165,7 +172,8 @@ foundTimeStamp timeStamp Just str -> case parseHTTPDateTime str of Just lastTime -> when (timeStamp <= lastTime) - $ abort statusForIfModSince [] ("The entity has not been modified since " ++ str) + $ abort statusForIfModSince [] + $ Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () @@ -176,7 +184,8 @@ foundTimeStamp timeStamp Just str -> case parseHTTPDateTime str of Just lastTime -> when (timeStamp > lastTime) - $ abort PreconditionFailed [] ("The entity has not been modified since " ++ str) + $ abort PreconditionFailed [] + $ Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () @@ -188,17 +197,15 @@ foundNoEntity :: Maybe String -> Resource () foundNoEntity msgM = do driftTo ExaminingRequest - let msg = fromMaybe "The requested entity was not found in this server." msgM - method <- getMethod when (method /= PUT) - $ abort NotFound [] msg + $ abort NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 ifMatch <- getHeader "If-Match" when (ifMatch /= Nothing) - $ abort PreconditionFailed [] msg + $ abort PreconditionFailed [] msgM driftTo GettingBody @@ -265,8 +272,8 @@ inputBS limit tooLarge :: Int -> STM () tooLarge lim = abortSTM RequestEntityTooLarge [] - ("Request body must be smaller than " - ++ show lim ++ " bytes.") + $ Just ("Request body must be smaller than " + ++ show lim ++ " bytes.") inputChunk :: Int -> Resource String @@ -363,7 +370,7 @@ redirect :: StatusCode -> URI -> Resource () redirect code uri = do when (code == NotModified || not (isRedirection code)) $ abort InternalServerError [] - $ "Attempted to redirect with status " ++ show code + $ Just ("Attempted to redirect with status " ++ show code) setStatus code setHeader "Location" (uriToString id uri $ "") @@ -398,14 +405,43 @@ outputChunk :: String -> Resource () outputChunk = outputChunkBS . B.pack +{- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を + B.readFile して作った ByteString をそのまま ResponseWriter に渡した + りすると大變な事が起こる。何故なら ResponseWriter は + Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを + 測るから、その時に起こるであらう事は言ふまでも無い。 -} + outputChunkBS :: ByteString -> Resource () -outputChunkBS str = do driftTo DecidingBody - itr <- ask - liftIO $ atomically $ - do updateItr itr itrBodyToSend (flip B.append str) - unless (B.null str) - $ writeItr itr itrBodyIsNull False +outputChunkBS str + = do driftTo DecidingBody + unless (B.null str) + $ do itr <- ask + let limit = cnfMaxOutputChunkLength $ itrConfig itr + when (limit <= 0) + $ fail ("cnfMaxOutputChunkLength must be positive: " + ++ show limit) + + sendChunks str limit + + liftIO $ atomically $ + writeItr itr itrBodyIsNull False + where + sendChunks :: ByteString -> Int -> Resource () + sendChunks str limit + | B.null str = return () + | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str + itr <- ask + liftIO $ atomically $ + do buf <- readItr itr itrBodyToSend id + if B.null buf then + -- バッファが消化された + writeItr itr itrBodyToSend chunk + else + -- 消化されるのを待つ + retry + -- 殘りのチャンクについて繰り返す + sendChunks remaining limit {- diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 062ffdc..28a94a4 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -119,7 +119,7 @@ runResource def itr driftTo Done ) itr ) - $ \ exc -> processException (itrConfig itr) exc + $ \ exc -> processException exc where fork :: IO () -> IO ThreadId fork = if (resUsesNativeThread def) @@ -153,21 +153,24 @@ runResource def itr Just _ -> xs Nothing -> [] - processException :: Config -> Exception -> IO () - processException conf exc + processException :: Exception -> IO () + processException exc = do let abo = case exc of - ErrorCall msg -> Abortion InternalServerError [] msg - IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE + ErrorCall msg -> Abortion InternalServerError [] $ Just msg + IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE DynException dynE -> case fromDynamic dynE of Just (abo :: Abortion) -> abo Nothing -> Abortion InternalServerError [] - $ show exc - _ -> Abortion InternalServerError [] $ show exc + $ Just $ show exc + _ -> Abortion InternalServerError [] $ Just $ show exc + conf = itrConfig itr + reqM = itrRequest itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 state <- atomically $ readItr itr itrState id + resM <- atomically $ readItr itr itrResponse id if state <= DecidingHeader then flip runReaderT itr $ do setStatus $ aboStatus abo @@ -175,7 +178,7 @@ runResource def itr -- れではまずいと思ふ。 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo setHeader "Content-Type" "application/xhtml+xml" - output $ aboPage conf abo + output $ abortPage conf reqM resM abo else hPutStrLn stderr $ show abo diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 7dca25b..1e2eacb 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -22,6 +22,7 @@ import Text.Printf import Control.Concurrent import Debug.Trace +import GHC.Conc (unsafeIOToSTM) responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO () diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index cbbed1e..89b7832 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,13 +1,70 @@ module Network.HTTP.Lucu.StaticFile - ( + ( staticFile -- FilePath -> ResourceDef + , handleStaticFile -- FilePath -> Resource () ) where +import Control.Monad +import Control.Monad.Trans +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.MIMEType.Guess +import Network.HTTP.Lucu.Resource +import Network.HTTP.Lucu.Resource.Tree +import Network.HTTP.Lucu.Response +import System.Directory +import System.Posix.Files +import Text.Printf + staticFile :: FilePath -> ResourceDef staticFile path = ResourceDef { resUsesNativeThread = False , resIsGreedy = False - , resGet - = Just $ do \ No newline at end of file + , resGet = Just $ handleStaticFile path + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + + +handleStaticFile :: FilePath -> Resource () +handleStaticFile path + = do exist <- liftIO $ fileExist path + if exist then + -- 存在はした。讀めるかどうかは知らない。 + do readable <- liftIO $ fileAccess path True False False + unless readable + -- 讀めない + $ abort Forbidden [] Nothing + + -- 讀める + tag <- liftIO $ generateETagFromFile path + lastMod <- liftIO $ getModificationTime path + foundEntity tag lastMod + + -- MIME Type を推定 + conf <- getConfig + case guessTypeByFileName (cnfExtToMIMEType conf) path of + Nothing -> return () + Just mime -> setContentType mime + + -- 實際にファイルを讀んで送る + (liftIO $ B.readFile path) >>= outputBS + else + foundNoEntity Nothing + + +-- inode-size-lastmod +generateETagFromFile :: FilePath -> IO ETag +generateETagFromFile path + = do stat <- getFileStatus path + let inode = fromEnum $ fileID stat + size = fromEnum $ fileSize stat + lastmod = fromEnum $ modificationTime stat + return $ strongETag $ printf "%x-%x-%x" inode size lastmod diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index f3a3621..a2c6d50 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -11,13 +11,18 @@ import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.StaticFile import Network.URI import System.Posix.Signals import System.Time main :: IO () main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } - resources = mkResTree [ ([], helloWorld) ] + resources = mkResTree [ ( [] + , helloWorld ) + , ( ["compilers"] + , staticFile "/etc/compilers" ) + ] in do installHandler sigPIPE Ignore Nothing runHttpd config resources -- 2.40.0