, UnicodeSyntax
#-}
-- |This is the Resource Monad; monadic actions to define a behavior
--- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
+-- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
-- implements 'MonadIO' class, and it is a state machine as well.
--
-- Request Processing Flow:
-- 1. A client issues an HTTP request.
--
-- 2. If the URI of it matches to any resource, the corresponding
--- 'Resource' Monad starts running on a newly spawned thread.
+-- 'Rsrc' Monad starts running on a newly spawned thread.
--
--- 3. The 'Resource' Monad looks at request headers, find (or not
--- find) an entity, receive the request body (if any), send
--- response headers, and then send a response body. This process
--- will be discussed later.
+-- 3. The 'Rsrc' Monad looks at request headers, find (or not find)
+-- an entity, receive the request body (if any), send response
+-- headers, and then send a response body. This process will be
+-- discussed later.
--
--- 4. The 'Resource' Monad and its thread stops running. The client
--- may or may not be sending us the next request at this point.
+-- 4. The 'Rsrc' Monad and its thread stops running. The client may
+-- or may not be sending us the next request at this point.
--
--- 'Resource' Monad takes the following states. The initial state is
+-- 'Rsrc' Monad takes the following states. The initial state is
-- /Examining Request/ and the final state is /Done/.
--
--- [/Examining Request/] In this state, a 'Resource' looks at the
+-- [/Examining Request/] In this state, a 'Rsrc' looks at the
-- request header fields and thinks about the corresponding entity
--- for it. If there is a suitable entity, the 'Resource' tells the
+-- for it. If there is a suitable entity, the 'Rsrc' tells the
-- system an entity tag and its last modification time
-- ('foundEntity'). If it found no entity, it tells the system so
-- ('foundNoEntity'). In case it is impossible to decide the
-- existence of entity, which is a typical case for POST requests,
--- 'Resource' does nothing in this state.
+-- 'Rsrc' does nothing in this state.
--
--- [/Receiving Body/] A 'Resource' asks the system to receive a
--- request body from the client. Before actually reading from the
--- socket, the system sends \"100 Continue\" to the client if need
--- be. When a 'Resource' transits to the next state without
--- receiving all or part of a request body, the system automatically
--- discards it.
+-- [/Receiving Body/] A 'Rsrc' asks the system to receive a request
+-- body from the client. Before actually reading from the socket,
+-- the system sends \"100 Continue\" to the client if need be. When
+-- a 'Rsrc' transits to the next state without receiving all or part
+-- of a request body, the system automatically discards it.
--
--- [/Deciding Header/] A 'Resource' makes a decision of response
--- status code and header fields. When it transits to the next
--- state, the system validates and completes the header fields and
--- then sends them to the client.
+-- [/Deciding Header/] A 'Rsrc' makes a decision of response status
+-- code and header fields. When it transits to the next state, the
+-- system validates and completes the header fields and then sends
+-- them to the client.
--
--- [/Sending Body/] In this state, a 'Resource' asks the system to
--- write some response body to the socket. When it transits to the
--- next state without writing any response body, the system
--- automatically completes it depending on the status code. (To be
--- exact, such completion only occurs when the 'Resource' transits
--- to this state without even declaring the \"Content-Type\" header
--- field. See: 'setContentType')
+-- [/Sending Body/] In this state, a 'Rsrc' asks the system to write
+-- some response body to the socket. When it transits to the next
+-- state without writing any response body, the system automatically
+-- completes it depending on the status code. (To be exact, such
+-- completion only occurs when the 'Rsrc' transits to this state
+-- without even declaring the \"Content-Type\" header field. See:
+-- 'setContentType')
--
--- [/Done/] Everything is over. A 'Resource' can do nothing for the
--- HTTP interaction anymore.
+-- [/Done/] Everything is over. A 'Rsrc' can do nothing for the HTTP
+-- interaction anymore.
--
-- Note that the state transition is one-way: for instance, it is an
-- error to try to read a request body after writing some
-- response. This limitation is for efficiency. We don't want to read
--- the entire request before starting 'Resource', nor we don't want to
--- postpone writing the entire response till the end of 'Resource'
+-- the entire request before starting 'Rsrc', nor we don't want to
+-- postpone writing the entire response till the end of 'Rsrc'
-- computation.
module Network.HTTP.Lucu.Resource
(
-- * Types
- Resource
- , ResourceDef(..)
+ Resource(..)
, emptyResource
+ , Rsrc
, FormData(..)
-- * Getting request header
-- |These functions can be called regardless of the current state,
- -- and they don't change the state of 'Resource'.
+ -- and they don't change the state of 'Rsrc'.
, getConfig
, getRemoteAddr
, getRemoteAddr'
-- * Finding an entity
-- |These functions can be called only in the /Examining Request/
- -- state. They make the 'Resource' transit to the /Receiving Body/
+ -- state. They make the 'Rsrc' transit to the /Receiving Body/
-- state.
, foundEntity
, foundETag
, foundNoEntity'
-- * Receiving a request body
- -- |These functions make the 'Resource' transit to the /Receiving
+ -- |These functions make the 'Rsrc' transit to the /Receiving
-- Body/ state.
, getChunk
, getChunks
-- * Sending a response body
- -- |These functions make the 'Resource' transit to the
- -- /Sending Body/ state.
+ -- |These functions make the 'Rsrc' transit to the /Sending Body/
+ -- state.
, putChunk
, putChunks
, putBuilder
-- |Get the string representation of the address of remote host. If
-- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
-getRemoteAddr' ∷ Resource HostName
+getRemoteAddr' ∷ Rsrc HostName
getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
where
toNM ∷ SockAddr → IO HostName
toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
-- |Resolve an address to the remote host.
-getRemoteHost ∷ Resource (Maybe HostName)
+getRemoteHost ∷ Rsrc (Maybe HostName)
getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
where
getHN ∷ SockAddr → IO (Maybe HostName)
getHN = (fst <$>) ∘ getNameInfo [] True False
-- |Get the 'Method' value of the request.
-getMethod ∷ Resource Method
+getMethod ∷ Rsrc Method
getMethod = reqMethod <$> getRequest
-- |Get the URI of the request.
-getRequestURI ∷ Resource URI
+getRequestURI ∷ Rsrc URI
getRequestURI = reqURI <$> getRequest
-- |Get the HTTP version of the request.
-getRequestVersion ∷ Resource HttpVersion
+getRequestVersion ∷ Rsrc HttpVersion
getRequestVersion = reqVersion <$> getRequest
-- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
-- @[]@ if the corresponding
--- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See:
+-- 'Network.HTTP.Lucu.Resource.Tree.Resource' is not greedy. See:
-- 'getResourcePath'
--
-- Note that the returned path components are URI-decoded.
-getPathInfo ∷ Resource [Strict.ByteString]
+getPathInfo ∷ Rsrc [Strict.ByteString]
getPathInfo = do rsrcPath ← getResourcePath
reqPath ← splitPathInfo <$> getRequestURI
return $ drop (length rsrcPath) reqPath
-- application\/x-www-form-urlencoded, and parse it into pairs of
-- @(name, formData)@. This function doesn't read the request
-- body.
-getQueryForm ∷ Resource [(Strict.ByteString, FormData)]
+getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)]
getQueryForm = parse' <$> getRequestURI
where
parse' = map toPairWithFormData ∘
-- @name@. Comparison of header name is case-insensitive. Note that
-- this function is not intended to be used so frequently: there
-- should be functions like 'getContentType' for every common headers.
-getHeader ∷ CIAscii → Resource (Maybe Ascii)
+getHeader ∷ CIAscii → Rsrc (Maybe Ascii)
getHeader name
= H.getHeader name <$> getRequest
-- |Return the list of 'MIMEType' enumerated on the value of request
-- header \"Accept\", or @[]@ if absent.
-getAccept ∷ Resource [MIMEType]
+getAccept ∷ Rsrc [MIMEType]
getAccept
= do acceptM ← getHeader "Accept"
case acceptM of
-- |Return the list of @(contentCoding, qvalue)@ enumerated on the
-- value of request header \"Accept-Encoding\". The list is sorted in
-- descending order by qvalue.
-getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
+getAcceptEncoding ∷ Rsrc [(CIAscii, Maybe Double)]
getAcceptEncoding
= do accEncM ← getHeader "Accept-Encoding"
case accEncM of
-- |Return 'True' iff a given content-coding is acceptable by the
-- client.
-isEncodingAcceptable ∷ CIAscii → Resource Bool
+isEncodingAcceptable ∷ CIAscii → Rsrc Bool
isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
where
doesMatch ∷ (CIAscii, Maybe Double) → Bool
doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
-- |Return the value of request header \"Content-Type\" as 'MIMEType'.
-getContentType ∷ Resource (Maybe MIMEType)
+getContentType ∷ Rsrc (Maybe MIMEType)
getContentType
= do cTypeM ← getHeader "Content-Type"
case cTypeM of
-- |Return the value of request header \"Authorization\" as
-- 'AuthCredential'.
-getAuthorization ∷ Resource (Maybe AuthCredential)
+getAuthorization ∷ Rsrc (Maybe AuthCredential)
getAuthorization
= do authM ← getHeader "Authorization"
case authM of
Right ac → return $ Just ac
Left _ → return Nothing
--- |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
--- a datum to be replied. If this is a PUT or DELETE request, it means
--- a datum which was stored for the URI until now. For POST requests
--- it raises an error.
+-- |Tell the system that the 'Rsrc' found an entity for the request
+-- URI. If this is a GET or HEAD request, a found entity means a datum
+-- to be replied. If this is a PUT or DELETE request, it means a datum
+-- which was stored for the URI until now. For POST requests it raises
+-- an error.
--
-- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
-- whenever possible, and if those tests fail, it immediately aborts
-- If the request method is either GET or HEAD, 'foundEntity'
-- automatically puts \"ETag\" and \"Last-Modified\" headers into the
-- response.
-foundEntity ∷ ETag → UTCTime → Resource ()
+foundEntity ∷ ETag → UTCTime → Rsrc ()
foundEntity tag timeStamp
= do driftTo ExaminingRequest
driftTo ReceivingBody
--- |Tell the system that the 'Resource' found an entity for the
--- request URI. The only difference from 'foundEntity' is that
--- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
--- the response.
+-- |Tell the system that the 'Rsrc' found an entity for the request
+-- URI. The only difference from 'foundEntity' is that 'foundETag'
+-- doesn't (nor can't) put \"Last-Modified\" header into the response.
--
-- Using this function is discouraged. You should use 'foundEntity'
-- whenever possible.
-foundETag ∷ ETag → Resource ()
+foundETag ∷ ETag → Rsrc ()
foundETag tag
= do driftTo ExaminingRequest
driftTo ReceivingBody
--- |Tell the system that the 'Resource' found an entity for the
+-- |Tell the system that the 'Rsrc' found an entity for the
-- request URI. The only difference from 'foundEntity' is that
-- 'foundTimeStamp' performs \"If-Modified-Since\" test or
-- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
--
-- Using this function is discouraged. You should use 'foundEntity'
-- whenever possible.
-foundTimeStamp ∷ UTCTime → Resource ()
+foundTimeStamp ∷ UTCTime → Rsrc ()
foundTimeStamp timeStamp
= do driftTo ExaminingRequest
driftTo ReceivingBody
--- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
--- no entity for the request URI. @mStr@ is an optional error message
--- to be replied to the client.
+-- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
+-- entity for the request URI. @mStr@ is an optional error message to
+-- be replied to the client.
--
-- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
-- test and when that fails it aborts with status \"412 Precondition
-- Failed\". If the request method is GET, HEAD, POST or DELETE,
-- 'foundNoEntity' always aborts with status \"404 Not Found\".
-foundNoEntity ∷ Maybe Text → Resource ()
+foundNoEntity ∷ Maybe Text → Rsrc ()
foundNoEntity msgM
= do driftTo ExaminingRequest
driftTo ReceivingBody
-- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
-foundNoEntity' ∷ Resource ()
+foundNoEntity' ∷ Rsrc ()
{-# INLINE foundNoEntity' #-}
foundNoEntity' = foundNoEntity Nothing
-- |@'getChunks' limit@ attemts to read the entire request body up to
--- @limit@ bytes, and then make the 'Resource' transit to the
--- /Deciding Header/ state. When the actual size of the body is larger
--- than @limit@ bytes, 'getChunks' immediately aborts with status
--- \"413 Request Entity Too Large\". When the request has no body, it
+-- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding
+-- Header/ state. When the actual size of the body is larger than
+-- @limit@ bytes, 'getChunks' immediately aborts with status \"413
+-- Request Entity Too Large\". When the request has no body, it
-- returns an empty string.
--
-- When the @limit@ is 'Nothing', 'getChunks' uses the default
-- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
-- lazy: reading from the socket just happens at the computation of
-- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
-getChunks ∷ Maybe Int → Resource Lazy.ByteString
+getChunks ∷ Maybe Int → Rsrc Lazy.ByteString
getChunks (Just n)
| n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
| n ≡ 0 = return (∅)
getChunks Nothing
= getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
-getChunks' ∷ Int → Resource Lazy.ByteString
+getChunks' ∷ Int → Rsrc Lazy.ByteString
getChunks' limit = go limit (∅)
where
- go ∷ Int → Builder → Resource Lazy.ByteString
+ go ∷ Int → Builder → Rsrc Lazy.ByteString
go 0 _ = do chunk ← getChunk 1
if Strict.null chunk then
return (∅)
--
-- Note that there are currently a few limitations on parsing
-- @multipart/form-data@. See: 'parseMultipartFormData'
-getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
+getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]
getForm limit
= do cTypeM ← getContentType
case cTypeM of
-- |@'redirect' code uri@ declares the response status as @code@ and
-- \"Location\" header field as @uri@. The @code@ must satisfy
-- 'isRedirection' or it raises an error.
-redirect ∷ StatusCode sc ⇒ sc → URI → Resource ()
+redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
redirect sc uri
= do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
$ abort
-- |@'setContentType' mType@ declares the response header
-- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
-- mandatory for sending a response body.
-setContentType ∷ MIMEType → Resource ()
+setContentType ∷ MIMEType → Rsrc ()
setContentType
= setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
-- |@'setLocation' uri@ declares the response header \"Location\" as
-- @uri@. You usually don't need to call this function directly.
-setLocation ∷ URI → Resource ()
+setLocation ∷ URI → Rsrc ()
setLocation uri
= case A.fromChars uriStr of
Just a → setHeader "Location" a
-- |@'setContentEncoding' codings@ declares the response header
-- \"Content-Encoding\" as @codings@.
-setContentEncoding ∷ [CIAscii] → Resource ()
+setContentEncoding ∷ [CIAscii] → Rsrc ()
setContentEncoding codings
= do ver ← getRequestVersion
tr ← case ver of
-- |@'setWWWAuthenticate' challenge@ declares the response header
-- \"WWW-Authenticate\" as @challenge@.
-setWWWAuthenticate ∷ AuthChallenge → Resource ()
+setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
-- |Write a chunk in 'Strict.ByteString' to the response body. You
-- must first declare the response header \"Content-Type\" before
-- applying this function. See: 'setContentType'
-putChunk ∷ Strict.ByteString → Resource ()
+putChunk ∷ Strict.ByteString → Rsrc ()
putChunk = putBuilder ∘ BB.fromByteString
-- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
-- Note that you must first declare the response header
-- \"Content-Type\" before applying this function. See:
-- 'setContentType'
-putChunks ∷ Lazy.ByteString → Resource ()
+putChunks ∷ Lazy.ByteString → Rsrc ()
putChunks = putBuilder ∘ BB.fromLazyByteString
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Resource.Internal
- ( Resource
- , ResourceDef(..)
+ ( Rsrc
+ , Resource(..)
, emptyResource
- , spawnResource
+ , spawnRsrc
, getConfig
, getRemoteAddr
import Prelude.Unicode
import System.IO
--- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
+-- |The resource monad. This monad implements 'MonadIO' so it can do
-- any 'IO' actions.
-newtype Resource a
- = Resource {
- unResource ∷ ReaderT NormalInteraction IO a
+newtype Rsrc a
+ = Rsrc {
+ unRsrc ∷ ReaderT NormalInteraction IO a
}
deriving (Applicative, Functor, Monad, MonadIO)
-runResource ∷ Resource a → NormalInteraction → IO a
-runResource = runReaderT ∘ unResource
-
--- |'ResourceDef' is basically a set of 'Resource' monads for each
--- HTTP methods.
-data ResourceDef = ResourceDef {
- -- |Whether to run a 'Resource' on a native thread (spawned by
- -- 'forkOS') or to run it on a user thread (spanwed by
- -- 'forkIO'). Generally you don't need to set this field to
- -- 'True'.
- resUsesNativeThread ∷ !Bool
+runRsrc ∷ Rsrc a → NormalInteraction → IO a
+runRsrc = runReaderT ∘ unRsrc
+
+-- |'Resource' is basically a set of 'Rsrc' monadic computations for
+-- each HTTP methods.
+data Resource = Resource {
-- | Whether to be greedy or not.
--
-- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
-- there is another resource at \/aaa\/bbb\/ccc. If the resource
-- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
-- resources are like CGI scripts.
- , resIsGreedy ∷ !Bool
- -- |A 'Resource' to be run when a GET request comes for the
+ resIsGreedy ∷ !Bool
+ -- |A 'Rsrc' to be run when a GET request comes for the
-- resource path. If 'resGet' is Nothing, the system responds
-- \"405 Method Not Allowed\" for GET requests.
--
-- It also runs for HEAD request if the 'resHead' is 'Nothing'. In
-- that case 'putChunk' and such don't actually write a response
-- body.
- , resGet ∷ !(Maybe (Resource ()))
- -- |A 'Resource' to be run when a HEAD request comes for the
+ , resGet ∷ !(Maybe (Rsrc ()))
+ -- |A 'Rsrc' to be run when a HEAD request comes for the
-- resource path. If 'resHead' is Nothing, the system runs
-- 'resGet' instead. If 'resGet' is also Nothing, the system
-- responds \"405 Method Not Allowed\" for HEAD requests.
- , resHead ∷ !(Maybe (Resource ()))
- -- |A 'Resource' to be run when a POST request comes for the
+ , resHead ∷ !(Maybe (Rsrc ()))
+ -- |A 'Rsrc' to be run when a POST request comes for the
-- resource path. If 'resPost' is Nothing, the system responds
-- \"405 Method Not Allowed\" for POST requests.
- , resPost ∷ !(Maybe (Resource ()))
- -- |A 'Resource' to be run when a PUT request comes for the
+ , resPost ∷ !(Maybe (Rsrc ()))
+ -- |A 'Rsrc' to be run when a PUT request comes for the
-- resource path. If 'resPut' is Nothing, the system responds
-- \"405 Method Not Allowed\" for PUT requests.
- , resPut ∷ !(Maybe (Resource ()))
- -- |A 'Resource' to be run when a DELETE request comes for the
+ , resPut ∷ !(Maybe (Rsrc ()))
+ -- |A 'Rsrc' to be run when a DELETE request comes for the
-- resource path. If 'resDelete' is Nothing, the system responds
-- \"405 Method Not Allowed\" for DELETE requests.
- , resDelete ∷ !(Maybe (Resource ()))
+ , resDelete ∷ !(Maybe (Rsrc ()))
}
-- |'emptyResource' is a resource definition with no actual
--- handlers. You can construct a 'ResourceDef' by selectively
--- overriding 'emptyResource'. It is defined as follows:
+-- handlers. You can construct a 'Resource' by selectively overriding
+-- 'emptyResource'. It is defined as follows:
--
-- @
--- emptyResource = ResourceDef {
+-- emptyResource = Resource {
-- resUsesNativeThread = False
-- , resIsGreedy = False
-- , resGet = Nothing
-- , resDelete = Nothing
-- }
-- @
-emptyResource ∷ ResourceDef
-emptyResource = ResourceDef {
- resUsesNativeThread = False
- , resIsGreedy = False
+emptyResource ∷ Resource
+emptyResource = Resource {
+ resIsGreedy = False
, resGet = Nothing
, resHead = Nothing
, resPost = Nothing
, resDelete = Nothing
}
-spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId
-spawnResource (ResourceDef {..}) ni@(NI {..})
- = fork $ run `catch` processException
+spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
+spawnRsrc (Resource {..}) ni@(NI {..})
+ = forkIO $ run `catch` processException
where
- fork ∷ IO () → IO ThreadId
- fork | resUsesNativeThread = forkOS
- | otherwise = forkIO
-
run ∷ IO ()
- run = flip runResource ni $
+ run = flip runRsrc ni $
do req ← getRequest
fromMaybe notAllowed $ rsrc req
driftTo Done
- rsrc ∷ Request → Maybe (Resource ())
+ rsrc ∷ Request → Maybe (Rsrc ())
rsrc req
= case reqMethod req of
GET → resGet
DELETE → resDelete
_ → error $ "Unknown request method: " ⧺ show (reqMethod req)
- notAllowed ∷ Resource ()
+ notAllowed ∷ Rsrc ()
notAllowed = do setStatus MethodNotAllowed
setHeader "Allow"
$ A.fromAsciiBuilder
if state ≤ DecidingHeader then
-- We still have a chance to reflect this abortion
-- in the response. Hooray!
- flip runResource ni $
+ flip runRsrc ni $
do setStatus $ aboStatus abo
mapM_ (uncurry setHeader) (aboHeaders abo)
setHeader "Content-Type" defaultPageContentType
else
when (cnfDumpTooLateAbortionToStderr niConfig)
$ dumpAbortion abo
- runResource (driftTo Done) ni
+ runRsrc (driftTo Done) ni
dumpAbortion ∷ Abortion → IO ()
dumpAbortion abo
, " ", show abo, "\n"
]
-getInteraction ∷ Resource NormalInteraction
-getInteraction = Resource ask
+getInteraction ∷ Rsrc NormalInteraction
+getInteraction = Rsrc ask
-- |Get the 'Config' value for this httpd.
-getConfig ∷ Resource Config
+getConfig ∷ Rsrc Config
getConfig = niConfig <$> getInteraction
-- |Get the 'SockAddr' of the remote host.
-getRemoteAddr ∷ Resource SockAddr
+getRemoteAddr ∷ Rsrc SockAddr
getRemoteAddr = niRemoteAddr <$> getInteraction
#if defined(HAVE_SSL)
-- * The 'OpenSSL.Session.VerificationMode' of
-- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
-- 'OpenSSL.Session.VerifyPeer'.
-getRemoteCertificate ∷ Resource (Maybe X509)
+getRemoteCertificate ∷ Rsrc (Maybe X509)
getRemoteCertificate = niRemoteCert <$> getInteraction
#endif
-- |Return the 'Request' value representing the request header. You
-- usually don't need to call this function directly.
-getRequest ∷ Resource Request
+getRequest ∷ Rsrc Request
getRequest = niRequest <$> getInteraction
--- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
--- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
--- action is the exact path in the tree even when the 'ResourceDef' is
+-- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
+-- action is the exact path in the tree even when the 'Resource' is
-- greedy.
--
-- Example:
-- > -- pathInfo == ["bar", "baz"]
-- > ...
-- > }
-getResourcePath ∷ Resource [Strict.ByteString]
+getResourcePath ∷ Rsrc [Strict.ByteString]
getResourcePath = niResourcePath <$> getInteraction
-- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
-- bytes. You can incrementally read the request body by repeatedly
-- calling this function. If there is nothing to be read anymore,
--- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to
+-- 'getChunk' returns 'Strict.empty' and makes 'Rsrc' transit to
-- the /Deciding Header/ state.
-getChunk ∷ Int → Resource Strict.ByteString
+getChunk ∷ Int → Rsrc Strict.ByteString
getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
-getChunk' ∷ Int → Resource Strict.ByteString
+getChunk' ∷ Int → Rsrc Strict.ByteString
getChunk' n
| n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
| n ≡ 0 = return (∅)
else
driftTo DecidingHeader *> return (∅)
where
- askForInput ∷ NormalInteraction → Resource Strict.ByteString
+ askForInput ∷ NormalInteraction → Rsrc Strict.ByteString
askForInput (NI {..})
= do -- Ask the RequestReader to get a chunk.
liftIO $ atomically
-- |Declare the response status code. If you don't call this function,
-- the status code will be defaulted to \"200 OK\".
-setStatus ∷ StatusCode sc ⇒ sc → Resource ()
+setStatus ∷ StatusCode sc ⇒ sc → Rsrc ()
setStatus sc
= do ni ← getInteraction
liftIO $ atomically
-- case the client shall only accept the first 10 bytes of response
-- body and thinks that the residual 10 bytes is a part of the header
-- of the next response.
-setHeader ∷ CIAscii → Ascii → Resource ()
+setHeader ∷ CIAscii → Ascii → Rsrc ()
setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
where
go ∷ NormalInteraction → STM ()
-- |@'deleteHeader' name@ deletes a response header @name@ if
-- any. This function is not intended to be used so frequently.
-deleteHeader ∷ CIAscii → Resource ()
+deleteHeader ∷ CIAscii → Rsrc ()
deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
where
go ∷ NormalInteraction → STM ()
-- Note that you must first declare the response header
-- \"Content-Type\" before applying this function. See:
-- 'setContentType'
-putBuilder ∷ Builder → Resource ()
+putBuilder ∷ Builder → Rsrc ()
putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
where
-- FIXME: should see if resCanHaveBody.
"putBuilder: Content-Type has not been set."
putTMVar niBodyToSend b
-driftTo ∷ InteractionState → Resource ()
+driftTo ∷ InteractionState → Rsrc ()
driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
driftTo' ∷ NormalInteraction → InteractionState → STM ()
projects / Lucu.git / commitdiff