, emptyResource
, spawnResource
- , getInteraction
+ , getConfig
+ , getRemoteAddr
+ , getRemoteCertificate
, getRequest
+ , getResourcePath
+
+ , getChunk
, setStatus
, setHeader
- , setHeader'
, deleteHeader
, putBuilder
import Control.Monad.Reader
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
+import qualified Data.ByteString as Strict
import Data.List
import Data.Maybe
import Data.Monoid.Unicode
+import Data.Text (Text)
import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
+import Network.Socket
+import OpenSSL.X509
import Prelude hiding (catch)
import Prelude.Unicode
import System.IO
runResource ∷ Resource a → Interaction → IO a
runResource = runReaderT ∘ unResource
--- | 'ResourceDef' is basically a set of 'Resource' monads for each
+-- |'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
-- 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
+ -- |A 'Resource' 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.
--
-- this case 'output' and such like don't actually write a
-- response body.
, resGet ∷ !(Maybe (Resource ()))
- -- | A 'Resource' to be run when a HEAD request comes for the
+ -- |A 'Resource' 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
+ -- |A 'Resource' 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
+ -- |A 'Resource' 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
+ -- |A 'Resource' 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 ()))
processException ∷ SomeException → IO ()
processException exc
= do let abo = toAbortion exc
- -- まだ DecidingHeader 以前の状態だったら、この途中終了
- -- を應答に反映させる餘地がある。さうでなければ stderr
- -- にでも吐くしか無い。
state ← atomically $ readTVar itrState
res ← atomically $ readTVar itrResponse
if state ≤ DecidingHeader then
+ -- We still have a chance to reflect this abortion
+ -- in the response. Hooray!
flip runResource itr $
do setStatus $ aboStatus abo
setHeader "Content-Type" defaultPageContentType
dumpAbortion abo
= hPutStr stderr
$ concat [ "Lucu: an exception occured after "
- , "sending response header to the client:\n"
+ , "sending the response header to the client:\n"
, " ", show abo, "\n"
]
getInteraction ∷ Resource Interaction
getInteraction = Resource ask
--- |Get the 'Request' value which represents the request header. In
--- general you don't have to use this action.
+-- |Get the 'Config' value for this httpd.
+getConfig ∷ Resource Config
+getConfig = itrConfig <$> getInteraction
+
+-- |Get the 'SockAddr' of the remote host.
+getRemoteAddr ∷ Resource SockAddr
+getRemoteAddr = itrRemoteAddr <$> getInteraction
+
+-- | Return the X.509 certificate of the client, or 'Nothing' if:
+--
+-- * This request didn't came through an SSL stream.
+--
+-- * The client didn't send us its certificate.
+--
+-- * The 'OpenSSL.Session.VerificationMode' of
+-- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
+-- 'OpenSSL.Session.VerifyPeer'.
+getRemoteCertificate ∷ Resource (Maybe X509)
+getRemoteCertificate = itrRemoteCert <$> getInteraction
+
+-- |Return the 'Request' value representing the request header. You
+-- usually don't need to call this function directly.
getRequest ∷ Resource Request
getRequest = (fromJust ∘ itrRequest) <$> getInteraction
--- | Set the response status code. If you don't call this function,
+-- |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
+-- greedy.
+--
+-- Example:
+--
+-- > main = let tree = mkResTree [ (["foo"], resFoo) ]
+-- > in runHttpd defaultConfig tree []
+-- >
+-- > resFoo = ResourceDef {
+-- > resIsGreedy = True
+-- > , resGet = Just $ do requestURI <- getRequestURI
+-- > resourcePath <- getResourcePath
+-- > pathInfo <- getPathInfo
+-- > -- uriPath requestURI == "/foo/bar/baz"
+-- > -- resourcePath == ["foo"]
+-- > -- pathInfo == ["bar", "baz"]
+-- > ...
+-- > , ...
+-- > }
+getResourcePath ∷ Resource [Text]
+getResourcePath = (fromJust ∘ itrResourcePath) <$> 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
+-- the /Deciding Header/ state.
+getChunk ∷ Int → Resource Strict.ByteString
+getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
+
+getChunk' ∷ Int → Resource Strict.ByteString
+getChunk' n
+ | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
+ | n ≡ 0 = return (∅)
+ | otherwise = do req ← getRequest
+ if reqMustHaveBody req then
+ do itr ← getInteraction
+ askForInput itr
+ else
+ driftTo DecidingHeader *> return (∅)
+ where
+ askForInput ∷ Interaction → Resource Strict.ByteString
+ askForInput (Interaction {..})
+ = do -- Ask the RequestReader to get a chunk.
+ liftIO $ atomically
+ $ putTMVar itrReceiveBodyReq (ReceiveBody n)
+ -- Then wait for a reply.
+ chunk ← liftIO
+ $ atomically
+ $ takeTMVar itrReceivedBody
+ -- Have we got an EOF?
+ when (Strict.null chunk)
+ $ driftTo DecidingHeader
+ return chunk
+
+-- |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 sc
- = do driftTo DecidingHeader
- itr ← getInteraction
- liftIO
- $ atomically
- $ setResponseStatus itr sc
-
--- | @'setHeader' name value@ sets the value of the response header
--- @name@ to @value@. Note that this function is not intended to be
+ = do itr ← getInteraction
+ liftIO $ atomically
+ $ do state ← readTVar $ itrState itr
+ when (state > DecidingHeader)
+ $ fail "Too late to declare the response status."
+ setResponseStatus itr sc
+
+-- |@'setHeader' name value@ declares the value of the response header
+-- @name@ as @value@. Note that this function is not intended to be
-- used so frequently: there should be specialised functions like
-- 'setContentType' for every common headers.
--
-- 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
+ $ do state ← readTVar $ itrState itr
+ when (state > DecidingHeader)
+ $ fail "Too late to declare a response header field."
+ res ← readTVar $ itrResponse itr
let res' = H.setHeader name value res
writeTVar (itrResponse itr) res'
when (name ≡ "Content-Type")
$ writeTVar (itrResponseHasCType itr) True
--- | @'deleteHeader' name@ deletes a response header @name@ if
+-- |@'deleteHeader' name@ deletes a response header @name@ if
-- any. This function is not intended to be used so frequently.
deleteHeader ∷ CIAscii → Resource ()
deleteHeader name
- = driftTo DecidingHeader *> deleteHeader' name
-
-deleteHeader' ∷ CIAscii → Resource ()
-deleteHeader' name
= do itr ← getInteraction
liftIO $ atomically
- $ do res ← readTVar $ itrResponse itr
+ $ do state ← readTVar $ itrState itr
+ when (state > DecidingHeader)
+ $ fail "Too late to delete a response header field."
+ res ← readTVar $ itrResponse itr
let res' = H.deleteHeader name res
writeTVar (itrResponse itr) res'
when (name ≡ "Content-Type")
$ writeTVar (itrResponseHasCType itr) False
--- | Run a 'Builder' to construct a chunk, and write it to the
--- response body. It is safe to apply this function to a 'Builder'
--- producing an infinitely long stream of octets.
+-- |Run a 'Builder' to construct a chunk, and write it to the response
+-- body. It is safe to apply this function to a 'Builder' producing an
+-- infinitely long stream of octets.
--
--- Note that you must first set the response header \"Content-Type\"
--- before applying this function. See: 'setContentType'
+-- Note that you must first declare the response header
+-- \"Content-Type\" before applying this function. See
+-- 'setContentType'.
putBuilder ∷ Builder → Resource ()
putBuilder b
= do itr ← getInteraction
liftIO $ atomically
- $ do driftTo' itr DecidingBody
+ $ do driftTo' itr SendingBody
hasCType ← readTVar $ itrResponseHasCType itr
unless hasCType
$ abortSTM InternalServerError []
driftTo' ∷ Interaction → InteractionState → STM ()
driftTo' itr@(Interaction {..}) newState
= do oldState ← readTVar itrState
- if newState < oldState then
- throwStateError oldState newState
- else
- do let a = [oldState .. newState]
- b = tail a
- c = zip a b
- mapM_ (uncurry drift) c
- writeTVar itrState newState
+ driftFrom oldState
where
+ driftFrom ∷ InteractionState → STM ()
+ driftFrom oldState
+ | newState < oldState = throwStateError oldState newState
+ | newState ≡ oldState = return ()
+ | otherwise
+ = do let a = [oldState .. newState]
+ b = tail a
+ c = zip a b
+ mapM_ (uncurry driftFromTo) c
+ writeTVar itrState newState
+
throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
- throwStateError Done DecidingBody
+ throwStateError Done SendingBody
= fail "It makes no sense to output something after finishing outputs."
throwStateError old new
- = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
+ = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
- drift ∷ InteractionState → InteractionState → STM ()
- drift GettingBody _
- = putTMVar itrGetBodyRequest WasteAll
- drift DecidingHeader _
+ driftFromTo ∷ InteractionState → InteractionState → STM ()
+ driftFromTo ReceivingBody _
+ = putTMVar itrReceiveBodyReq WasteAll
+ driftFromTo DecidingHeader _
= postprocess itr
- drift _ _
+ driftFromTo _ _
= return ()
projects / Lucu.git / blobdiff