, 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'
-- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
-- the entire request before starting 'Resource', nor we don't want to
-- postpone writing the entire response till the end of 'Resource'
-- computation.
-
module Network.HTTP.Lucu.Resource
(
-- * Types
Resource
, FormData(..)
- , runRes
-
- -- * Actions
-
- -- ** Getting request header
+ -- * Getting request header
-- |These actions can be computed regardless of the current state,
-- and they don't change the state.
, getConfig
, getContentType
, getAuthorization
- -- ** Finding an entity
-
+ -- * Finding an entity
-- |These actions can be computed only in the /Examining Request/
-- state. After the computation, the 'Resource' transits to
-- /Getting Body/ state.
, foundTimeStamp
, foundNoEntity
- -- ** Getting a request body
-
+ -- * Getting a request body
-- |Computation of these actions changes the state to /Getting
-- Body/.
- , input
- , inputChunk
- , inputForm
+ , getChunk
+ , getChunks
+ , getForm
, defaultLimit
- -- ** Setting response headers
-
+ -- * Setting response headers
-- |Computation of these actions changes the state to /Deciding
-- Header/.
, setStatus
- , setHeader
, redirect
, setContentType
- , setLocation
, setContentEncoding
, setWWWAuthenticate
- -- ** Writing a response body
+ -- ** Less frequently used functions
+ , setLocation
+ , setHeader
+ , deleteHeader
+ -- * Writing a response body
-- |Computation of these actions changes the state to /Deciding
-- Body/.
- , output
- , outputChunk
-
- , driftTo -- private
+ , putChunk
+ , putChunks
+ , putBuilder
)
where
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.ByteString as BB
import Control.Applicative
import Control.Concurrent.STM
-import Control.Monad.Reader
+import Control.Monad
+import Control.Monad.IO.Class
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
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
import Network.HTTP.Lucu.MultipartForm
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Utils
import OpenSSL.X509
import Prelude.Unicode
--- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
--- any 'IO' actions.
-newtype Resource a
- = Resource {
- unRes ∷ ReaderT Interaction IO a
- }
- deriving (Applicative, Functor, Monad, MonadIO)
-
-runRes ∷ Resource a → Interaction → IO a
-runRes r itr
- = runReaderT (unRes r) itr
-
-getInteraction ∷ Resource Interaction
-getInteraction = Resource ask
-
-- |Get the 'Config' value which is used for the httpd.
getConfig ∷ Resource Config
getConfig = itrConfig <$> getInteraction
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.
getRemoteCertificate ∷ Resource (Maybe X509)
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 = (fromJust ∘ itrRequest) <$> getInteraction
-
-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
getMethod = reqMethod <$> getRequest
-- |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:
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 時に使用するアクション群 -}
-
--- | 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 sc
- = do driftTo DecidingHeader
- itr ← getInteraction
- 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
--- used so frequently: there should be actions like 'setContentType'
--- for every common headers.
---
--- Some important headers (especially \"Content-Length\" and
--- \"Transfer-Encoding\") may be silently dropped or overwritten by
--- the system not to corrupt the interaction with client at the
--- viewpoint of HTTP protocol layer. For instance, if we are keeping
--- the connection alive, without this process it causes a catastrophe
--- to send a header \"Content-Length: 10\" and actually send a body of
--- 20 bytes long. In this case the client shall only accept the first
--- 10 bytes of response body and thinks that the residual 10 bytes is
--- a part of header of the next response.
-setHeader ∷ CIAscii → Ascii → Resource ()
-setHeader name value
- = driftTo DecidingHeader ≫ setHeader' name value
-
-setHeader' ∷ CIAscii → Ascii → Resource ()
-setHeader' name value
- = do itr ← getInteraction
- liftIO $ atomically
- $ do res ← readTVar $ itrResponse itr
- let res' = H.setHeader name value res
- writeTVar (itrResponse itr) res'
+-- Setting response headers
-- | Computation of @'redirect' code uri@ sets the response status to
-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
= setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
-- | Computation of @'setLocation' uri@ sets the response header
--- \"Location\" to @uri@.
+-- \"Location\" to @uri@. You usually don't need to call this function
+-- directly.
setLocation ∷ URI → Resource ()
setLocation uri
= case A.fromChars uriStr of
= setHeader "WWW-Authenticate" (printAuthChallenge challenge)
-{- DecidingBody 時に使用するアクション群 -}
-
--- | 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
+-- Writing a response body
--- | 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
- 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 (itrSentNoBodySoFar 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 だった場合は出力補完す
- る。
-
--}
-
-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
- 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 (Interaction {..}) GettingBody _
- = writeTVar itrReqBodyWasteAll True
- drift itr DecidingHeader _
- = postprocess itr
- drift itr@(Interaction {..}) _ Done
- = do bodyIsNull ← readTVar itrSentNoBodySoFar
- when bodyIsNull
- $ writeDefaultPage itr
- drift _ _ _
- = return ()
+-- | 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 ()
+putChunk = putBuilder ∘ BB.fromLazyByteString
projects / Lucu.git / blobdiff