X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=28ce4628901a8380a3e48e578657b143cf778a0d;hb=a44a96d95b5fcbaf24a21c0336046ce0c3bab614;hp=7405975d5f2a0752968ed899a1aeadb6a0250916;hpb=e624f0db8c4610b36da9e4463a656e0cb8a104dd;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 7405975..28ce462 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,217 +1,216 @@ module Network.HTTP.Lucu.Resource - ( ResourceDef(..) - , Resource - , ResTree - , mkResTree -- [ ([String], ResourceDef) ] -> ResTree - , findResource -- ResTree -> URI -> Maybe ResourceDef - , runResource -- ResourceDef -> Interaction -> IO ThreadId + ( Resource + + , getConfig -- Resource Config + , getMethod -- Resource Method + , getHeader -- String -> Resource (Maybe String) + , getAccept -- Resource [MIMEType] + , getContentType -- Resource (Maybe MIMEType) + + , foundEntity -- ETag -> ClockTime -> Resource () + , foundETag -- ETag -> Resource () + , foundTimeStamp -- ClockTime -> Resource () + , foundNoEntity -- Maybe String -> Resource () , input -- Int -> Resource String , inputChunk -- Int -> Resource String , inputBS -- Int -> Resource ByteString , inputChunkBS -- Int -> Resource ByteString + , defaultLimit -- Int , setStatus -- StatusCode -> Resource () , setHeader -- String -> String -> Resource () - , redirect -- StatusCode -> URI -> Resource () + , setETag -- ETag -> Resource () + , setLastModified -- ClockTime -> Resource () + , setContentType -- MIMEType -> Resource () , output -- String -> Resource () , outputChunk -- String -> Resource () , outputBS -- ByteString -> Resource () , outputChunkBS -- ByteString -> Resource () + + , driftTo -- InteractionState -> Resource () ) where -import Control.Concurrent import Control.Concurrent.STM -import Control.Exception import Control.Monad.Reader import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Dynamic import Data.List -import qualified Data.Map as M -import Data.Map (Map) import Data.Maybe import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils import Network.URI -import Prelude hiding (catch) -import System.IO -import System.IO.Error hiding (catch) +import System.Time type Resource a = ReaderT Interaction IO a -{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ - れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず - /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視 - される。 -} -data ResourceDef = ResourceDef { - resUsesNativeThread :: Bool - , resIsGreedy :: Bool - , resGet :: Maybe (Resource ()) - , resHead :: Maybe (Resource ()) - , resPost :: Maybe (Resource ()) - , resPut :: Maybe (Resource ()) - , resDelete :: Maybe (Resource ()) - } -type ResTree = ResNode -- root だから Map ではない -type ResSubtree = Map String ResNode -data ResNode = ResNode (Maybe ResourceDef) ResSubtree - - -mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree list = processRoot list - where - processRoot :: [ ([String], ResourceDef) ] -> ResTree - processRoot list - = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list - children = processNonRoot nonRoots - in - if null roots then - -- / にリソースが定義されない。/foo とかにはあるかも。 - ResNode Nothing children - else - -- / がある。 - let (_, def) = last roots - in - ResNode (Just def) children - - processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree - processNonRoot list - = let subtree = M.fromList [(name, node name) - | name <- childNames] - childNames = [name | (name:_, _) <- list] - node name = let defs = [def | (path, def) <- list, path == [name]] - in - if null defs then - -- この位置にリソースが定義されない。 - -- もっと下にはあるかも。 - ResNode Nothing children - else - -- この位置にリソースがある。 - ResNode (Just $ last defs) children - children = processNonRoot [(path, def) - | (_:path, def) <- list, not (null path)] - in - subtree - - -findResource :: ResTree -> URI -> Maybe ResourceDef -findResource (ResNode rootDefM subtree) uri - = let pathStr = uriPath uri - path = [x | x <- splitBy (== '/') pathStr, x /= ""] - in - if null path then - rootDefM - else - walkTree subtree path - where - walkTree :: ResSubtree -> [String] -> Maybe ResourceDef - - walkTree subtree (name:[]) - = case M.lookup name subtree of - Nothing -> Nothing - Just (ResNode defM _) -> defM - - walkTree subtree (x:xs) - = case M.lookup x subtree of - Nothing -> Nothing - Just (ResNode defM children) -> case defM of - Just (ResourceDef { resIsGreedy = True }) - -> defM - _ -> walkTree children xs - - -runResource :: ResourceDef -> Interaction -> IO ThreadId -runResource def itr - = fork - $ catch ( runReaderT ( do fromMaybe notAllowed rsrc - driftTo Done - ) itr - ) - $ \ exc -> processException (itrConfig itr) exc - where - fork :: IO () -> IO ThreadId - fork = if (resUsesNativeThread def) - then forkOS - else forkIO - - rsrc :: Maybe (Resource ()) - rsrc = case reqMethod $ fromJust $ itrRequest itr of - GET -> resGet def - HEAD -> case resHead def of - Just r -> Just r - Nothing -> resGet def - POST -> resPost def - PUT -> resPut def - DELETE -> resDelete def - - notAllowed :: Resource () - notAllowed = do setStatus MethodNotAllowed - setHeader "Allow" $ joinWith ", " allowedMethods - - allowedMethods :: [String] - allowedMethods = nub $ foldr (++) [] [ 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 - Just _ -> xs - Nothing -> [] - - processException :: Config -> Exception -> IO () - processException conf exc - = do let abo = case exc of - ErrorCall msg -> Abortion InternalServerError [] msg - IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE - DynException dynE -> case fromDynamic dynE of - Just (abo :: Abortion) -> abo - Nothing - -> Abortion InternalServerError [] - $ show exc - _ -> Abortion InternalServerError [] $ show exc - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 - state <- atomically $ readItr itr itrState id - if state <= DecidingHeader then - flip runReaderT itr - $ do setStatus $ aboStatus abo - -- FIXME: 同じ名前で複數の値があった時は、こ - -- れではまずいと思ふ。 - mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo - setHeader "Content-Type" "application/xhtml+xml" - output $ aboPage conf abo +getConfig :: Resource Config +getConfig = do itr <- ask + return $ itrConfig itr + + +getMethod :: Resource Method +getMethod = do itr <- ask + return $ reqMethod $ fromJust $ itrRequest itr + + +getHeader :: String -> Resource (Maybe String) +getHeader name = do itr <- ask + return $ H.getHeader name $ fromJust $ itrRequest itr + + +getAccept :: Resource [MIMEType] +getAccept = do accept <- getHeader "Accept" + if accept == Nothing then + return [] else - hPutStrLn stderr $ show abo + case parseStr mimeTypeListP $ fromJust accept of + (Success xs, _) -> return xs + _ -> return [] - flip runReaderT itr $ driftTo Done - formatIOE :: IOError -> String - formatIOE ioE = if isUserError ioE then - ioeGetErrorString ioE +getContentType :: Resource (Maybe MIMEType) +getContentType = do cType <- getHeader "Content-Type" + if cType == Nothing then + return Nothing else - show ioE + case parseStr mimeTypeP $ fromJust cType of + (Success t, _) -> return $ Just t + _ -> return Nothing + + +{- ExaminingRequest 時に使用するアクション群 -} -{- Resource モナド -} +foundEntity :: ETag -> ClockTime -> Resource () +foundEntity tag timeStamp + = do driftTo ExaminingRequest + + method <- getMethod + when (method == GET || method == HEAD) + $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp + foundETag tag + + driftTo GettingBody + + +foundETag :: ETag -> Resource () +foundETag tag + = do driftTo ExaminingRequest + + method <- getMethod + when (method == GET || method == HEAD) + $ setHeader' "ETag" $ show tag + + -- If-Match があればそれを見る。 + ifMatch <- getHeader "If-Match" + case ifMatch of + Nothing -> return () + Just "*" -> return () + Just list -> case parseStr eTagListP list of + (Success tags, _) + -- tags の中に一致するものが無ければ + -- PreconditionFailed で終了。 + -> when (not $ any (== tag) tags) + $ 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 + else + PreconditionFailed + + -- If-None-Match があればそれを見る。 + ifNoneMatch <- getHeader "If-None-Match" + case ifNoneMatch of + Nothing -> return () + Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *") + Just list -> case parseStr eTagListP list of + (Success tags, _) + -> when (any (== tag) tags) + $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list) + _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list) + + driftTo GettingBody + + +foundTimeStamp :: ClockTime -> Resource () +foundTimeStamp timeStamp + = do driftTo ExaminingRequest + + method <- getMethod + when (method == GET || method == HEAD) + $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp + + let statusForIfModSince = if method == GET || method == HEAD then + NotModified + else + PreconditionFailed + + -- If-Modified-Since があればそれを見る。 + ifModSince <- getHeader "If-Modified-Since" + case ifModSince of + Just str -> case parseHTTPDateTime str of + Just lastTime + -> when (timeStamp <= lastTime) + $ abort statusForIfModSince [] + $ Just ("The entity has not been modified since " ++ str) + Nothing + -> return () -- 不正な時刻は無視 + Nothing -> return () + + -- If-Unmodified-Since があればそれを見る。 + ifUnmodSince <- getHeader "If-Unmodified-Since" + case ifUnmodSince of + Just str -> case parseHTTPDateTime str of + Just lastTime + -> when (timeStamp > lastTime) + $ abort PreconditionFailed [] + $ Just ("The entity has not been modified since " ++ str) + Nothing + -> return () -- 不正な時刻は無視 + Nothing -> return () + + driftTo GettingBody + + +foundNoEntity :: Maybe String -> Resource () +foundNoEntity msgM + = do driftTo ExaminingRequest + + method <- getMethod + when (method /= PUT) + $ abort NotFound [] msgM + + -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな + -- If-Match: 條件も滿たさない。 + ifMatch <- getHeader "If-Match" + when (ifMatch /= Nothing) + $ abort PreconditionFailed [] msgM + + driftTo GettingBody + + +{- GettingBody 時に使用するアクション群 -} input :: Int -> Resource String input limit = inputBS limit >>= return . B.unpack @@ -222,48 +221,59 @@ input limit = inputBS limit >>= return . B.unpack inputBS :: Int -> Resource ByteString inputBS limit = do driftTo GettingBody - itr <- ask - let defaultLimit = cnfMaxEntityLength $ itrConfig itr - actualLimit = if limit <= 0 then - defaultLimit - else - limit - when (actualLimit <= 0) - $ fail ("inputBS: limit must be positive: " ++ show actualLimit) - -- Reader にリクエスト - liftIO $ atomically - $ do chunkLen <- readItr itr itrReqChunkLength id - writeItr itr itrWillReceiveBody True - if fmap (> actualLimit) chunkLen == Just True then - -- 受信前から多過ぎる事が分かってゐる - tooLarge actualLimit - else - writeItr itr itrReqBodyWanted $ Just actualLimit - -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $ atomically - $ do chunk <- readItr itr itrReceivedBody id - chunkIsOver <- readItr itr itrReqChunkIsOver id - if B.length chunk < fromIntegral actualLimit then - -- 要求された量に滿たなくて、まだ殘りがある - -- なら再試行。 - unless chunkIsOver - $ retry - else - -- 制限値一杯まで讀むやうに指示したのにまだ殘っ - -- てゐるなら、それは多過ぎる。 - unless chunkIsOver - $ tooLarge actualLimit - -- 成功。itr 内にチャンクを置いたままにするとメ - -- モリの無駄になるので除去。 - writeItr itr itrReceivedBody B.empty - return chunk - driftTo DecidingHeader + itr <- ask + hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id + chunk <- if hasBody then + askForInput itr + else + do driftTo DecidingHeader + return B.empty return chunk where + askForInput :: Interaction -> Resource ByteString + askForInput itr + = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr + actualLimit = if limit <= 0 then + defaultLimit + else + limit + when (actualLimit <= 0) + $ fail ("inputBS: limit must be positive: " ++ show actualLimit) + -- Reader にリクエスト + liftIO $ atomically + $ do chunkLen <- readItr itr itrReqChunkLength id + writeItr itr itrWillReceiveBody True + if fmap (> actualLimit) chunkLen == Just True then + -- 受信前から多過ぎる事が分かってゐる + tooLarge actualLimit + else + writeItr itr itrReqBodyWanted $ Just actualLimit + -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 + chunk <- liftIO $ atomically + $ do chunk <- readItr itr itrReceivedBody id + chunkIsOver <- readItr itr itrReqChunkIsOver id + if B.length chunk < fromIntegral actualLimit then + -- 要求された量に滿たなくて、まだ殘り + -- があるなら再試行。 + unless chunkIsOver + $ retry + else + -- 制限値一杯まで讀むやうに指示したの + -- にまだ殘ってゐるなら、それは多過ぎ + -- る。 + unless chunkIsOver + $ tooLarge actualLimit + -- 成功。itr 内にチャンクを置いたままにす + -- るとメモリの無駄になるので除去。 + writeItr itr itrReceivedBody B.empty + return chunk + driftTo DecidingHeader + return chunk + 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 @@ -277,33 +287,50 @@ inputChunkBS :: Int -> Resource ByteString inputChunkBS limit = do driftTo GettingBody itr <- ask - let defaultLimit = cnfMaxEntityLength $ itrConfig itr - actualLimit = if limit < 0 then - defaultLimit - else - limit - when (actualLimit <= 0) - $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit) - -- Reader にリクエスト - liftIO $ atomically - $ do writeItr itr itrReqBodyWanted $ Just actualLimit - writeItr itr itrWillReceiveBody True - -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $ atomically - $ do chunk <- readItr itr itrReceivedBody id - -- 要求された量に滿たなくて、まだ殘りがあるなら - -- 再試行。 - when (B.length chunk < fromIntegral actualLimit) - $ do chunkIsOver <- readItr itr itrReqChunkIsOver id - unless chunkIsOver - $ retry - -- 成功 - writeItr itr itrReceivedBody B.empty - return chunk - when (B.null chunk) - $ driftTo DecidingHeader + hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id + chunk <- if hasBody then + askForInput itr + else + do driftTo DecidingHeader + return B.empty return chunk - + where + askForInput :: Interaction -> Resource ByteString + askForInput itr + = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr + actualLimit = if limit < 0 then + defaultLimit + else + limit + when (actualLimit <= 0) + $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit) + -- Reader にリクエスト + liftIO $ atomically + $ do writeItr itr itrReqBodyWanted $ Just actualLimit + writeItr itr itrWillReceiveBody True + -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 + chunk <- liftIO $ atomically + $ do chunk <- readItr itr itrReceivedBody id + -- 要求された量に滿たなくて、まだ殘りがあ + -- るなら再試行。 + when (B.length chunk < fromIntegral actualLimit) + $ do chunkIsOver <- readItr itr itrReqChunkIsOver id + unless chunkIsOver + $ retry + -- 成功 + writeItr itr itrReceivedBody B.empty + return chunk + when (B.null chunk) + $ driftTo DecidingHeader + return chunk + + +defaultLimit :: Int +defaultLimit = (-1) + + + +{- DecidingHeader 時に使用するアクション群 -} setStatus :: StatusCode -> Resource () setStatus code @@ -323,8 +350,12 @@ setStatus code setHeader :: String -> String -> Resource () setHeader name value - = do driftTo DecidingHeader - itr <- ask + = driftTo DecidingHeader >> setHeader' name value + + +setHeader' :: String -> String -> Resource() +setHeader' name value + = do itr <- ask liftIO $ atomically $ updateItr itr itrResponse $ \ resM -> case resM of Nothing -> Just $ Response { @@ -339,11 +370,28 @@ 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 $ "") +setETag :: ETag -> Resource () +setETag tag + = setHeader "ETag" $ show tag + + +setLastModified :: ClockTime -> Resource () +setLastModified lastmod + = setHeader "Last-Modified" $ formatHTTPDateTime lastmod + + +setContentType :: MIMEType -> Resource () +setContentType mType + = setHeader "Content-Type" $ show mType + + +{- DecidingBody 時に使用するアクション群 -} + output :: String -> Resource () output = outputBS . B.pack @@ -357,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 {-