, driftTo -- private
)
where
-import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.ByteString as BB
import Control.Applicative
import Control.Concurrent.STM
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
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
$ 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@.
-- | 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.
+--
+-- Note that you must first set the \"Content-Type\" response header
+-- before applying this function. See: 'setContentType'
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.
+--
+-- Note that you must first set the \"Content-Type\" response header
+-- before applying this function. See: 'setContentType'
outputChunk ∷ Lazy.ByteString → Resource ()
outputChunk str
= do driftTo DecidingBody
itr ← getInteraction
liftIO $ atomically
- $ do putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
- unless (Lazy.null str)
- $ writeTVar (itrSentNoBodySoFar itr) False
-
-{-
-
- [GettingBody からそれ以降の状態に遷移する時]
-
- body を讀み終へてゐなければ、殘りの body を讀み捨てる。
-
-
- [DecidingHeader からそれ以降の状態に遷移する時]
-
- postprocess する。
-
-
- [Done に遷移する時]
-
- bodyIsNull が False ならば何もしない。True だった場合は出力補完す
- る。
-
--}
+ $ do hasCType ← readTVar $ itrResponseHasCType itr
+ unless hasCType
+ $ abortSTM InternalServerError []
+ $ Just "outputChunk: Content-Type has not been set."
+ putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
driftTo ∷ InteractionState → Resource ()
driftTo 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)
= writeTVar itrReqBodyWasteAll True
drift itr DecidingHeader _
= postprocess itr
- drift itr@(Interaction {..}) _ Done
- = do bodyIsNull ← readTVar itrSentNoBodySoFar
- when bodyIsNull
- $ writeDefaultPage itr
drift _ _ _
= return ()