X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=01b61813971e9e1ce4ba80e18ed374e400a5ce5a;hb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;hp=0caf6ceb7dbf6479e8dfa4141609872f0381e945;hpb=0ff03469c29b791f2c609a659bbf59be97e306f2;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 0caf6ce..01b6181 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,12 +1,10 @@ {-# LANGUAGE - BangPatterns - , GeneralizedNewtypeDeriving + GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings , RecordWildCards , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- |This is the Resource Monad; monadic actions to define the behavior -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO' @@ -71,7 +69,7 @@ module Network.HTTP.Lucu.Resource -- * Types Resource , FormData(..) - , runRes -- private + , runRes -- * Actions @@ -237,9 +235,7 @@ getRemoteCertificate = itrRemoteCert <$> getInteraction -- |Get the 'Request' value which represents the request header. In -- general you don't have to use this action. getRequest ∷ Resource Request -getRequest - = do itr ← getInteraction - liftIO $ atomically $ readItr itrRequest fromJust itr +getRequest = (fromJust ∘ itrRequest) <$> getInteraction -- |Get the 'Method' value of the request. getMethod ∷ Resource Method @@ -434,7 +430,7 @@ getAuthorization -- If this is a GET or HEAD request, 'foundEntity' automatically puts -- \"ETag\" and \"Last-Modified\" headers into the response. foundEntity ∷ ETag → UTCTime → Resource () -foundEntity !tag !timeStamp +foundEntity tag timeStamp = do driftTo ExaminingRequest method ← getMethod @@ -455,7 +451,7 @@ foundEntity !tag !timeStamp -- This action is not preferred. You should use 'foundEntity' whenever -- possible. foundETag ∷ ETag → Resource () -foundETag !tag +foundETag tag = do driftTo ExaminingRequest method ← getMethod @@ -609,8 +605,7 @@ input ∷ Int → Resource Lazy.ByteString input limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr - chunk ← if hasBody then + chunk ← if reqHasBody $ fromJust $ itrRequest itr then askForInput itr else do driftTo DecidingHeader @@ -618,8 +613,8 @@ input limit return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString - askForInput itr - = do let confLimit = cnfMaxEntityLength $ itrConfig itr + askForInput (Interaction {..}) + = do let confLimit = cnfMaxEntityLength itrConfig actualLimit = if limit ≤ 0 then confLimit else @@ -628,17 +623,11 @@ input limit $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do chunkLen ← readItr itrReqChunkLength id itr - writeItr itrWillReceiveBody True itr - if ((> actualLimit) <$> chunkLen) ≡ Just True then - -- 受信前から多過ぎる事が分かってゐる - tooLarge actualLimit - else - writeItr itrReqBodyWanted (Just actualLimit) itr + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen id itr - chunkIsOver ← readItr itrReqChunkIsOver id itr + $ do chunkLen ← readTVar itrReceivedBodyLen + chunkIsOver ← readTVar itrReqChunkIsOver if chunkLen < actualLimit then -- 要求された量に滿たなくて、まだ殘りが -- あるなら再試行。 @@ -651,8 +640,9 @@ input limit $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにする -- とメモリの無駄になるので除去。 - chunk ← readItr itrReceivedBody seqToLBS itr - writeItr itrReceivedBody (∅) itr + chunk ← seqToLBS <$> readTVar itrReceivedBody + writeTVar itrReceivedBody (∅) + writeTVar itrReceivedBodyLen 0 return chunk driftTo DecidingHeader @@ -683,39 +673,38 @@ inputChunk ∷ Int → Resource Lazy.ByteString inputChunk limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr - chunk ← if hasBody then - askForInput itr - else - do driftTo DecidingHeader - return (∅) + chunk ← if reqHasBody $ fromJust $ itrRequest itr then + askForInput itr + else + do driftTo DecidingHeader + return (∅) return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString - askForInput itr - = do let confLimit = cnfMaxEntityLength $ itrConfig itr + askForInput (Interaction {..}) + = do let confLimit = cnfMaxEntityLength itrConfig actualLimit = if limit < 0 then - confLimit - else - limit - when (actualLimit <= 0) + confLimit + else + limit + when (actualLimit ≤ 0) $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do writeItr itrReqBodyWanted (Just actualLimit) itr - writeItr itrWillReceiveBody True itr + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen id itr + $ do chunkLen ← readTVar itrReceivedBodyLen -- 要求された量に滿たなくて、まだ殘りがある -- なら再試行。 when (chunkLen < actualLimit) - $ do chunkIsOver ← readItr itrReqChunkIsOver id itr + $ do chunkIsOver ← readTVar itrReqChunkIsOver unless chunkIsOver $ retry -- 成功 - chunk ← readItr itrReceivedBody seqToLBS itr - writeItr itrReceivedBody (∅) itr + chunk ← seqToLBS <$> readTVar itrReceivedBody + writeTVar itrReceivedBody (∅) + writeTVar itrReceivedBodyLen 0 return chunk when (Lazy.null chunk) $ driftTo DecidingHeader @@ -792,14 +781,12 @@ defaultLimit = (-1) -- | Set the response status code. If you omit to compute this action, -- the status code will be defaulted to \"200 OK\". setStatus ∷ StatusCode → Resource () -setStatus code +setStatus sc = do driftTo DecidingHeader itr ← getInteraction - liftIO $ atomically $ updateItr itrResponse f itr - where - f res = res { - resStatus = code - } + liftIO + $ atomically + $ setResponseStatus itr sc -- | Set a value of given resource header. Comparison of header name -- is case-insensitive. Note that this action is not intended to be @@ -823,7 +810,9 @@ setHeader' ∷ CIAscii → Ascii → Resource () setHeader' name value = do itr ← getInteraction liftIO $ atomically - $ updateItr itrResponse (H.setHeader name value) itr + $ do res ← readTVar $ itrResponse itr + let res' = H.setHeader name value res + writeTVar (itrResponse itr) res' -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy @@ -881,18 +870,16 @@ setWWWAuthenticate challenge {- DecidingBody 時に使用するアクション群 -} --- | Computation of @'output' str@ writes @str@ as a response body, --- and then make the 'Resource' transit to /Done/ state. It is safe to --- apply 'output' to an infinite string, such as a lazy stream of --- \/dev\/random. +-- | Write a 'Lazy.ByteString' to the response body, and then transit +-- to the /Done/ state. It is safe to apply 'output' to an infinite +-- string, such as the lazy stream of \/dev\/random. output ∷ Lazy.ByteString → Resource () {-# INLINE output #-} output str = outputChunk str *> driftTo Done --- | Computation of @'outputChunk' str@ writes @str@ as a part of --- response body. You can compute this action multiple times to write --- a body little at a time. It is safe to apply 'outputChunk' to an --- infinite string. +-- | Write a 'Lazy.ByteString' to the response body. This action can +-- be repeated as many times as you want. It is safe to apply +-- 'outputChunk' to an infinite string. outputChunk ∷ Lazy.ByteString → Resource () outputChunk wholeChunk = do driftTo DecidingBody @@ -903,24 +890,21 @@ outputChunk wholeChunk $ abort InternalServerError [] (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit)) - discardBody ← liftIO $ atomically $ - readItr itrWillDiscardBody id itr - + discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr unless (discardBody) - $ sendChunks wholeChunk limit + $ sendChunks itr wholeChunk limit unless (Lazy.null wholeChunk) $ liftIO $ atomically $ - writeItr itrBodyIsNull False itr + writeTVar (itrSentNoBodySoFar itr) False where - sendChunks ∷ Lazy.ByteString → Int → Resource () - sendChunks str limit + sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource () + sendChunks itr@(Interaction {..}) str limit | Lazy.null str = return () | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str - itr ← getInteraction liftIO $ atomically - $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk) - sendChunks remaining limit + $ putTMVar itrBodyToSend (chunkToBuilder chunk) + sendChunks itr remaining limit chunkToBuilder ∷ Lazy.ByteString → Builder chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks @@ -947,37 +931,31 @@ outputChunk wholeChunk driftTo ∷ InteractionState → Resource () driftTo newState = do itr ← getInteraction - liftIO $ atomically $ do oldState ← readItr itrState id itr - 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 itrState newState itr + liftIO $ atomically + $ do oldState ← readTVar $ itrState itr + 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 + writeTVar (itrState itr) newState where - throwStateError ∷ Monad m => InteractionState → InteractionState → m a - + 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 itrReqBodyWasteAll True itr - + drift (Interaction {..}) GettingBody _ + = writeTVar itrReqBodyWasteAll True drift itr DecidingHeader _ = postprocess itr - - drift itr _ Done - = do bodyIsNull ← readItr itrBodyIsNull id itr + drift itr@(Interaction {..}) _ Done + = do bodyIsNull ← readTVar itrSentNoBodySoFar when bodyIsNull - $ writeDefaultPage itr - + $ writeDefaultPage itr drift _ _ _ = return ()