{-# LANGUAGE
- DoAndIfThenElse
+ CPP
+ , DoAndIfThenElse
, GeneralizedNewtypeDeriving
, OverloadedStrings
, RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Resource.Internal
- ( Resource
- , ResourceDef(..)
+ ( Rsrc
+ , Resource(..)
, emptyResource
- , spawnResource
+ , spawnRsrc
, getConfig
, getRemoteAddr
+#if defined(HAVE_SSL)
, getRemoteCertificate
+#endif
, getRequest
, getResourcePath
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
+import Control.Monad hiding (mapM_)
import Control.Monad.IO.Class
-import Control.Monad.Reader
+import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import qualified Data.ByteString as Strict
-import Data.List
+import Data.Collections
+import Data.List (intersperse, nub)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.Socket
+#if defined(HAVE_SSL)
import OpenSSL.X509
-import Prelude hiding (catch)
+#endif
+import Prelude hiding (catch, concat, mapM_, tail)
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) $ H.fromHeaders $ aboHeaders abo
+ mapM_ (uncurry setHeader) (aboHeaders abo)
setHeader "Content-Type" defaultPageContentType
deleteHeader "Content-Encoding"
putBuilder $ abortPage niConfig (Just niRequest) res abo
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)
-- | Return the X.509 certificate of the client, or 'Nothing' if:
--
-- * This request didn't came through an SSL stream.
-- * 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 → Resource ()
+setStatus ∷ StatusCode sc ⇒ sc → Rsrc ()
setStatus sc
= do ni ← getInteraction
liftIO $ atomically
$ do state ← readTVar $ niState ni
when (state > DecidingHeader)
$ fail "Too late to declare the response status."
- setResponseStatus ni sc
+ res ← readTVar $ niResponse ni
+ writeTVar (niResponse ni) $ setStatusCode sc res
-- |@'setHeader' name value@ declares the value of the response header
-- @name@ as @value@. Note that this function is not intended to be
-- 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 ()
-- infinitely long stream of octets.
--
-- Note that you must first declare the response header
--- \"Content-Type\" before applying this function. See
--- 'setContentType'.
-putBuilder ∷ Builder → Resource ()
+-- \"Content-Type\" before applying this function. See:
+-- 'setContentType'
+putBuilder ∷ Builder → Rsrc ()
putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
where
+ -- FIXME: should see if resCanHaveBody.
go ∷ NormalInteraction → STM ()
go ni@(NI {..})
= do driftTo' ni SendingBody
"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 / blobdiff