-- |Computation of these actions changes the state to /Deciding
-- Body/.
- , output
- , outputChunk
+ , putChunk
+ , putBuilder
, driftTo -- private
)
import Data.List
import qualified Data.Map as M
import Data.Maybe
-import Data.Monoid
import Data.Monoid.Unicode
import Data.Sequence (Seq)
import Data.Text (Text)
import Network.HTTP.Lucu.Authorization
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.ContentCoding
-import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.ETag
import qualified Network.HTTP.Lucu.Headers as H
import Network.HTTP.Lucu.HttpVersion
return ac
-{- ExaminingRequest 時に使用するアクション群 -}
+-- Finding an entity
-- |Tell the system that the 'Resource' found an entity for the
-- request URI. If this is a GET or HEAD request, a found entity means
driftTo GettingBody
-{- GettingBody 時に使用するアクション群 -}
+-- Getting a request body
-- | Computation of @'input' limit@ attempts to read the request body
-- up to @limit@ bytes, and then make the 'Resource' transit to
input limit
= do driftTo GettingBody
itr ← getInteraction
- chunk ← if reqHasBody $ fromJust $ itrRequest itr then
+ chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
askForInput itr
else
do driftTo DecidingHeader
inputChunk limit
= do driftTo GettingBody
itr ← getInteraction
- chunk ← if reqHasBody $ fromJust $ itrRequest itr then
+ chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
askForInput itr
else
do driftTo DecidingHeader
defaultLimit = (-1)
-{- DecidingHeader 時に使用するアクション群 -}
+-- Setting response headers
-- | Set the response status code. If you omit to compute this action,
-- the status code will be defaulted to \"200 OK\".
$ do res ← readTVar $ itrResponse itr
let res' = H.setHeader name value res
writeTVar (itrResponse itr) res'
+ when (name ≡ "Content-Type")
+ $ writeTVar (itrResponseHasCType itr) True
-- | Computation of @'redirect' code uri@ sets the response status to
-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
-- | Computation of @'setContentType' mType@ sets the response header
-- \"Content-Type\" to @mType@.
setContentType ∷ MIMEType → Resource ()
-setContentType
- = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+{-# INLINE setContentType #-}
+setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
-- | Computation of @'setLocation' uri@ sets the response header
-- \"Location\" to @uri@.
= setHeader "WWW-Authenticate" (printAuthChallenge challenge)
-{- DecidingBody 時に使用するアクション群 -}
+-- Writing a response body
--- | 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
-
--- | 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 str
- = do driftTo DecidingBody
- itr ← getInteraction
+-- | Write a chunk in 'Lazy.ByteString' to the response body. It is
+-- safe to apply this function to an infinitely long
+-- 'Lazy.ByteString'.
+--
+-- Note that you must first set the response header \"Content-Type\"
+-- before applying this function. See: 'setContentType'
+putChunk ∷ Lazy.ByteString → Resource ()
+{-# INLINE putChunk #-}
+putChunk = putBuilder ∘ BB.fromLazyByteString
+
+-- | Run a 'Builder' to construct a chunk, and write it to the
+-- response body. It is safe to apply this function to a 'Builder'
+-- producing an infinitely long stream of octets.
+--
+-- Note that you must first set the response header \"Content-Type\"
+-- before applying this function. See: 'setContentType'
+putBuilder ∷ Builder → Resource ()
+putBuilder b
+ = do itr ← getInteraction
liftIO $ atomically
- $ do putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
- unless (Lazy.null str)
- $ writeTVar (itrSentNoBodySoFar itr) False
-
-{-
-
- [GettingBody からそれ以降の状態に遷移する時]
-
- body を讀み終へてゐなければ、殘りの body を讀み捨てる。
+ $ do driftTo' itr DecidingBody
+ hasCType ← readTVar $ itrResponseHasCType itr
+ unless hasCType
+ $ abortSTM InternalServerError []
+ $ Just "putBuilder: Content-Type has not been set."
+ putTMVar (itrBodyToSend itr) b
- [DecidingHeader からそれ以降の状態に遷移する時]
-
- postprocess する。
-
-
- [Done に遷移する時]
-
- bodyIsNull が False ならば何もしない。True だった場合は出力補完す
- る。
-
--}
+-- Private
driftTo ∷ InteractionState → Resource ()
driftTo newState
= do itr ← getInteraction
- 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
+ liftIO $ atomically $ driftTo' itr newState
+
+driftTo' ∷ Interaction → InteractionState → STM ()
+driftTo' itr@(Interaction {..}) newState
+ = do oldState ← readTVar itrState
+ if newState < oldState then
+ throwStateError oldState newState
+ else
+ do let a = [oldState .. newState]
+ b = tail a
+ c = zip a b
+ mapM_ (uncurry drift) c
+ writeTVar 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."
+ = fail "It makes no sense to output something after finishing outputs."
throwStateError old new
= fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
- drift ∷ Interaction → InteractionState → InteractionState → STM ()
- drift (Interaction {..}) GettingBody _
+ drift ∷ InteractionState → InteractionState → STM ()
+ drift GettingBody _
= writeTVar itrReqBodyWasteAll True
- drift itr DecidingHeader _
+ drift DecidingHeader _
= postprocess itr
- drift itr@(Interaction {..}) _ Done
- = do bodyIsNull ← readTVar itrSentNoBodySoFar
- when bodyIsNull
- $ writeDefaultPage itr
- drift _ _ _
+ drift _ _
= return ()
projects / Lucu.git / blobdiff