module Network.HTTP.Lucu.Resource ( 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.STM import Control.Monad.Reader import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import Data.List 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 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 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 case parseStr mimeTypeListP $ fromJust accept of (Success xs, _) -> return xs _ -> return [] getContentType :: Resource (Maybe MIMEType) getContentType = do cType <- getHeader "Content-Type" if cType == Nothing then return Nothing else case parseStr mimeTypeP $ fromJust cType of (Success t, _) -> return $ Just t _ -> return Nothing {- ExaminingRequest 時に使用するアクション群 -} 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 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。 inputBS :: Int -> Resource ByteString inputBS limit = do driftTo GettingBody 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 [] $ Just ("Request body must be smaller than " ++ show lim ++ " bytes.") inputChunk :: Int -> Resource String inputChunk limit = inputChunkBS limit >>= return . B.unpack -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され -- る。これ以上ボディが殘ってゐなければ空文字列を返す。 inputChunkBS :: Int -> Resource ByteString inputChunkBS limit = do driftTo GettingBody 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 ("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 = do driftTo DecidingHeader itr <- ask liftIO $ atomically $ updateItr itr itrResponse $ \ resM -> case resM of Nothing -> Just $ Response { resVersion = HttpVersion 1 1 , resStatus = code , resHeaders = [] } Just res -> Just $ res { resStatus = code } setHeader :: String -> String -> Resource () setHeader name value = 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 { resVersion = HttpVersion 1 1 , resStatus = Ok , resHeaders = [ (name, value) ] } Just res -> Just $ H.setHeader name value res redirect :: StatusCode -> URI -> Resource () redirect code uri = do when (code == NotModified || not (isRedirection code)) $ abort InternalServerError [] $ 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 outputBS :: ByteString -> Resource () outputBS str = do outputChunkBS str driftTo Done 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 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 {- [GettingBody からそれ以降の状態に遷移する時] body を讀み終へてゐなければ、殘りの body を讀み捨てる。 [DecidingHeader からそれ以降の状態に遷移する時] postprocess する。 [Done に遷移する時] bodyIsNull が False ならば何もしない。True だった場合は出力補完す る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK だった場合は、補完の代はりに 204 No Content に變へる。 -} driftTo :: InteractionState -> Resource () driftTo newState = do itr <- ask liftIO $ atomically $ do oldState <- readItr itr itrState id if newState < oldState then throwStateError oldState newState else do let a = [oldState .. newState] b = tail a c = zip a b mapM_ (uncurry $ drift itr) c writeItr itr itrState newState where throwStateError :: Monad m => InteractionState -> InteractionState -> m a throwStateError Done DecidingBody = fail "It makes no sense to output something after finishing to output." throwStateError old new = fail ("state error: " ++ show old ++ " ==> " ++ show new) drift :: Interaction -> InteractionState -> InteractionState -> STM () drift itr GettingBody _ = writeItr itr itrReqBodyWasteAll True drift itr DecidingHeader _ = postprocess itr drift itr _ Done = do bodyIsNull <- readItr itr itrBodyIsNull id when bodyIsNull $ do status <- readStatus itr if status == Ok then do updateItrF itr itrResponse $ \ res -> res { resStatus = NoContent } updateItrF itr itrResponse $ H.deleteHeader "Content-Type" updateItrF itr itrResponse $ H.deleteHeader "ETag" updateItrF itr itrResponse $ H.deleteHeader "Last-Modified" else writeDefaultPage itr drift _ _ _ = return () readStatus :: Interaction -> STM StatusCode readStatus itr = readItr itr itrResponse (resStatus . fromJust)