, 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
projects / Lucu.git / blobdiff