, 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'
-- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
-- * Types
Resource
, FormData(..)
- , runRes -- private
+ , runRes
-- * Actions
, 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
getRemoteAddr' ∷ Resource HostName
getRemoteAddr'
= do sa ← getRemoteAddr
- (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
+ (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
return a
-- |Resolve an address to the remote host.
-- |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 $ fromJust <$> readTVar (itrRequest itr)
+getRequest = (fromJust ∘ itrRequest) <$> getInteraction
-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
-- |Get the path of this 'Resource' (to be exact,
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
--- action is the exact path in the tree even if the
+-- action is the exact path in the tree even when the
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
--
-- Example:
-- >
-- > resFoo = ResourceDef {
-- > resIsGreedy = True
--- > , resGet = Just $ do requestURI ← getRequestURI
--- > resourcePath ← getResourcePath
--- > pathInfo ← getPathInfo
+-- > , resGet = Just $ do requestURI <- getRequestURI
+-- > resourcePath <- getResourcePath
+-- > pathInfo <- getPathInfo
-- > -- uriPath requestURI == "/foo/bar/baz"
-- > -- resourcePath == ["foo"]
-- > -- pathInfo == ["bar", "baz"]
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
- $ setHeader' "ETag" (printETag tag)
+ $ setHeader' "ETag"
+ $ A.fromAsciiBuilder
+ $ printETag tag
when (method ≡ POST)
$ abort InternalServerError []
(Just "Illegal computation of foundETag for POST request.")
input limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
- chunk ← if hasBody then
+ chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
askForInput itr
else
do driftTo DecidingHeader
$ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do chunkLen ← readTVar itrReqChunkLength
- writeTVar itrWillReceiveBody True
- if ((> actualLimit) <$> chunkLen) ≡ Just True then
- -- 受信前から多過ぎる事が分かってゐる
- tooLarge actualLimit
- else
- writeTVar itrReqBodyWanted (Just actualLimit)
+ $ writeTVar itrReqBodyWanted actualLimit
-- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
chunk ← liftIO $ atomically
$ do chunkLen ← readTVar itrReceivedBodyLen
inputChunk limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
- chunk ← if hasBody then
- askForInput itr
- else
- do driftTo DecidingHeader
- return (∅)
+ chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
+ askForInput itr
+ else
+ do driftTo DecidingHeader
+ return (∅)
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
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 writeTVar itrReqBodyWanted (Just actualLimit)
- writeTVar itrWillReceiveBody True
+ $ writeTVar itrReqBodyWanted actualLimit
-- 應答を待つ。トランザクションを分けなければ當然デッドロック。
chunk ← liftIO $ atomically
$ do chunkLen ← readTVar itrReceivedBodyLen
-- | 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
- $ do res ← readTVar $ itrResponse itr
- let res' = res {
- resStatus = code
- }
- writeTVar (itrResponse itr) res'
+ 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
$ 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 wholeChunk
+outputChunk str
= do driftTo DecidingBody
itr ← getInteraction
-
- let limit = cnfMaxOutputChunkLength $ itrConfig itr
- when (limit ≤ 0)
- $ abort InternalServerError []
- (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
-
- discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr
- unless (discardBody)
- $ sendChunks itr wholeChunk limit
-
- unless (Lazy.null wholeChunk)
- $ liftIO $ atomically $
- writeTVar (itrSentNoBody itr) False
- where
- 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
- liftIO $ atomically
- $ putTMVar itrBodyToSend (chunkToBuilder chunk)
- sendChunks itr remaining limit
-
- chunkToBuilder ∷ Lazy.ByteString → Builder
- chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
-
-{-
-
- [GettingBody からそれ以降の状態に遷移する時]
-
- body を讀み終へてゐなければ、殘りの body を讀み捨てる。
-
-
- [DecidingHeader からそれ以降の状態に遷移する時]
-
- postprocess する。
-
-
- [Done に遷移する時]
-
- bodyIsNull が False ならば何もしない。True だった場合は出力補完す
- る。
-
--}
+ liftIO $ atomically
+ $ 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 itrSentNoBody
- when bodyIsNull
- $ writeDefaultPage itr
drift _ _ _
= return ()
projects / Lucu.git / blobdiff