{-# LANGUAGE
- DoAndIfThenElse
+ CPP
+ , DoAndIfThenElse
+ , FlexibleInstances
, GeneralizedNewtypeDeriving
, OverloadedStrings
+ , MultiParamTypeClasses
, RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Resource.Internal
- ( Resource
- , ResourceDef(..)
- , emptyResource
- , spawnResource
+ ( Rsrc
+ , Resource(..)
+ , spawnRsrc
- , getInteraction
+ , getConfig
+ , getRemoteAddr
+#if defined(HAVE_SSL)
+ , getRemoteCertificate
+#endif
, getRequest
+ , getResourcePath
+
+ , getChunk
, setStatus
, setHeader
- , setHeader'
, deleteHeader
, putBuilder
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 Data.List
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.Collections
+import Data.List (intersperse, nub)
import Data.Maybe
+import Data.Monoid
import Data.Monoid.Unicode
import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Abortion.Internal
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import qualified Network.HTTP.Lucu.Headers as H
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
-import Prelude hiding (catch)
+import Network.Socket
+#if defined(HAVE_SSL)
+import OpenSSL.X509
+#endif
+import Prelude hiding (catch, concat, filter, 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 Interaction IO a
+newtype Rsrc a
+ = Rsrc {
+ unRsrc ∷ ReaderT NormalInteraction IO a
}
deriving (Applicative, Functor, Monad, MonadIO)
-runResource ∷ Resource a → Interaction → 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
- -- | Whether to be greedy or not.
- --
- -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
- -- greedy resource at \/aaa\/bbb, it is always chosen even if
- -- 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
+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 {
+ -- |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
- -- 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
+ -- 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 (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:
---
--- @
--- emptyResource = ResourceDef {
--- resUsesNativeThread = False
--- , resIsGreedy = False
--- , resGet = Nothing
--- , resHead = Nothing
--- , resPost = Nothing
--- , resPut = Nothing
--- , resDelete = Nothing
--- }
--- @
-emptyResource ∷ ResourceDef
-emptyResource = ResourceDef {
- resUsesNativeThread = False
- , resIsGreedy = False
- , resGet = Nothing
- , resHead = Nothing
- , resPost = Nothing
- , resPut = Nothing
- , resDelete = Nothing
- }
-
-spawnResource ∷ ResourceDef → Interaction → IO ThreadId
-spawnResource (ResourceDef {..}) itr@(Interaction {..})
- = fork $ run `catch` processException
- where
- fork ∷ IO () → IO ThreadId
- fork | resUsesNativeThread = forkOS
- | otherwise = forkIO
+instance Monoid Resource where
+ {-# INLINE mempty #-}
+ mempty
+ = Resource {
+ resGet = Nothing
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+ {-# INLINEABLE mappend #-}
+ mappend a b
+ = Resource {
+ resGet = resGet a <|> resGet b
+ , resHead = resHead a <|> resHead b
+ , resPost = resPost a <|> resPost b
+ , resPut = resPut a <|> resPut b
+ , resDelete = resDelete a <|> resDelete b
+ }
+
+instance Unfoldable Resource (Method, Rsrc ()) where
+ {-# INLINEABLE insert #-}
+ insert (GET , a) r = r { resGet = Just a }
+ insert (HEAD , a) r = r { resHead = Just a }
+ insert (POST , a) r = r { resPost = Just a }
+ insert (PUT , a) r = r { resPut = Just a }
+ insert (DELETE, a) r = r { resDelete = Just a }
+ insert _ r = r
+ {-# INLINE empty #-}
+ empty = (∅)
+
+instance Foldable Resource (Method, Rsrc ()) where
+ {-# INLINEABLE foldMap #-}
+ foldMap f (Resource {..})
+ = maybe (∅) (f ∘ ((,) GET )) resGet ⊕
+ maybe (∅) (f ∘ ((,) HEAD )) resHead ⊕
+ maybe (∅) (f ∘ ((,) POST )) resPost ⊕
+ maybe (∅) (f ∘ ((,) PUT )) resPut ⊕
+ maybe (∅) (f ∘ ((,) DELETE)) resDelete
+
+instance Collection Resource (Method, Rsrc ()) where
+ {-# INLINE filter #-}
+ filter = (fromList ∘) ∘ (∘ fromFoldable) ∘ filter
+spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
+spawnRsrc (Resource {..}) ni@(NI {..})
+ = forkIO $ run `catch` processException
+ where
run ∷ IO ()
- run = flip runResource itr $
+ 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
- = setStatus MethodNotAllowed
- *>
- (setHeader "Allow" $ A.fromAsciiBuilder
- $ joinWith ", "
- $ map A.toAsciiBuilder allowedMethods)
+ notAllowed ∷ Rsrc ()
+ notAllowed = do setStatus MethodNotAllowed
+ setHeader "Allow"
+ $ A.fromAsciiBuilder
+ $ mconcat
+ $ intersperse (A.toAsciiBuilder ", ")
+ $ map A.toAsciiBuilder allowedMethods
allowedMethods ∷ [Ascii]
allowedMethods = nub $ concat [ methods resGet ["GET"]
toAbortion e
= case fromException e of
Just abortion → abortion
- Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
+ Nothing → mkAbortion' InternalServerError $ T.pack $ show e
processException ∷ SomeException → IO ()
processException exc
= do let abo = toAbortion exc
- -- まだ DecidingHeader 以前の状態だったら、この途中終了
- -- を應答に反映させる餘地がある。さうでなければ stderr
- -- にでも吐くしか無い。
- state ← atomically $ readTVar itrState
- res ← atomically $ readTVar itrResponse
+ state ← atomically $ readTVar niState
+ res ← atomically $ readTVar niResponse
if state ≤ DecidingHeader then
- flip runResource itr $
+ -- We still have a chance to reflect this abortion
+ -- in the response. Hooray!
+ flip runRsrc ni $
do setStatus $ aboStatus abo
+ mapM_ (uncurry setHeader) (aboHeaders abo)
setHeader "Content-Type" defaultPageContentType
deleteHeader "Content-Encoding"
- mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
- putBuilder $ abortPage itrConfig itrRequest res abo
+ putBuilder $ abortPage niConfig (Just niRequest) res abo
else
- when (cnfDumpTooLateAbortionToStderr itrConfig)
+ when (cnfDumpTooLateAbortionToStderr niConfig)
$ dumpAbortion abo
- runResource (driftTo Done) itr
+ runRsrc (driftTo Done) ni
dumpAbortion ∷ Abortion → IO ()
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
+getInteraction ∷ Rsrc NormalInteraction
+getInteraction = Rsrc ask
+
+-- |Get the 'Config' value for this httpd.
+getConfig ∷ Rsrc Config
+getConfig = niConfig <$> getInteraction
+
+-- |Get the 'SockAddr' of the remote host.
+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 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 ∷ Rsrc (Maybe X509)
+getRemoteCertificate = niRemoteCert <$> getInteraction
+#endif
--- |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
+-- |Return the 'Request' value representing the request header. You
+-- usually don't need to call this function directly.
+getRequest ∷ Rsrc Request
+getRequest = niRequest <$> getInteraction
--- | Set the response status code. If you don't call this function,
+-- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the
+-- corresponding 'Network.HTTP.Lucu.ResourceTree'. The result of this
+-- action is the exact path in the tree even when the 'Resource' is
+-- 'Network.HTTP.Lucu.greedy'.
+--
+-- Example:
+--
+-- @
+-- main :: 'IO' ()
+-- main = let tree :: 'Network.HTTP.Lucu.ResourceTree'
+-- tree = 'fromList' [ (["foo"], 'Network.HTTP.Lucu.greedy' resFoo) ]
+-- in 'Network.withSocketsDo' '.' 'Network.HTTP.Lucu.runHttpd' 'defaultConfig' $ 'Network.HTTP.Lucu.resourceMap' tree
+--
+-- resFoo :: 'Resource'
+-- resFoo = 'singleton'
+-- ( 'GET'
+-- , do requestURI <- 'getRequestURI'
+-- resourcePath <- 'getResourcePath'
+-- pathInfo <- 'getPathInfo'
+-- -- 'Network.URI.uriPath' requestURI '==' \"/foo/bar/baz\"
+-- -- resourcePath == ["foo"]
+-- -- pathInfo == ["bar", "baz"]
+-- ...
+-- )
+-- @
+getResourcePath ∷ Rsrc Path
+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 'BS.empty' and makes 'Rsrc' transit to the
+-- /Deciding Header/ state.
+getChunk ∷ Int → Rsrc ByteString
+getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
+
+getChunk' ∷ Int → Rsrc 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
+ askForInput =≪ getInteraction
+ else
+ driftTo DecidingHeader *> return (∅)
+ where
+ askForInput ∷ NormalInteraction → Rsrc ByteString
+ askForInput (NI {..})
+ = do -- Ask the RequestReader to get a chunk.
+ liftIO $ atomically
+ $ putTMVar niReceiveBodyReq (ReceiveBody n)
+ -- Then wait for a reply.
+ chunk ← liftIO
+ $ atomically
+ $ takeTMVar niReceivedBody
+ -- Have we got an EOF?
+ when (BS.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 ∷ StatusCode sc ⇒ sc → Rsrc ()
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 ni ← getInteraction
+ liftIO $ atomically
+ $ do state ← readTVar $ niState ni
+ when (state > DecidingHeader)
+ $ fail "Too late to declare the response status."
+ 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
-- used so frequently: there should be specialised functions like
--- 'setContentType' for every common headers.
+-- 'Network.HTTP.Lucu.setContentType' for every common headers.
--
-- Some important headers (especially \"Content-Length\" and
-- \"Transfer-Encoding\") may be silently dropped or overwritten by
-- 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 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'
- when (name ≡ "Content-Type")
- $ writeTVar (itrResponseHasCType itr) True
+setHeader ∷ CIAscii → Ascii → Rsrc ()
+setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
+ where
+ go ∷ NormalInteraction → STM ()
+ go (NI {..})
+ = do state ← readTVar niState
+ when (state > DecidingHeader) $
+ fail "Too late to declare a response header field."
+ res ← readTVar niResponse
+ writeTVar niResponse $ H.setHeader name value res
+ when (name ≡ "Content-Type") $
+ writeTVar niResponseHasCType 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 → Rsrc ()
+deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
+ where
+ go ∷ NormalInteraction → STM ()
+ go (NI {..})
+ = do state ← readTVar niState
+ when (state > DecidingHeader) $
+ fail "Too late to delete a response header field."
+ res ← readTVar niResponse
+ writeTVar niResponse $ H.deleteHeader name res
+ when (name ≡ "Content-Type") $
+ writeTVar niResponseHasCType False
-deleteHeader' ∷ CIAscii → Resource ()
-deleteHeader' name
- = do itr ← getInteraction
- liftIO $ atomically
- $ do 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 can be safely applied 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'
-putBuilder ∷ Builder → Resource ()
-putBuilder b
- = do itr ← getInteraction
- liftIO $ atomically
- $ do driftTo' itr DecidingBody
- hasCType ← readTVar $ itrResponseHasCType itr
- unless hasCType
- $ abortSTM InternalServerError []
- $ Just "putBuilder: Content-Type has not been set."
- putTMVar (itrBodyToSend itr) b
-
-driftTo ∷ InteractionState → Resource ()
-driftTo newState
- = do itr ← getInteraction
- liftIO $ atomically $ driftTo' itr newState
-
-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
+-- Note that you must first declare the response header
+-- \"Content-Type\" before applying this function. See
+-- 'Network.HTTP.Lucu.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
+ hasCType ← readTVar niResponseHasCType
+ unless hasCType
+ $ throwSTM
+ $ mkAbortion' InternalServerError
+ "putBuilder: Content-Type has not been set."
+ putTMVar niBodyToSend b
+
+driftTo ∷ InteractionState → Rsrc ()
+driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
+
+driftTo' ∷ NormalInteraction → InteractionState → STM ()
+driftTo' ni@(NI {..}) newState
+ = do oldState ← readTVar niState
+ 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 niState 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)
-
- drift ∷ InteractionState → InteractionState → STM ()
- drift GettingBody _
- = putTMVar itrGetBodyRequest WasteAll
- drift DecidingHeader _
- = postprocess itr
- drift _ _
+ = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
+
+ driftFromTo ∷ InteractionState → InteractionState → STM ()
+ driftFromTo ReceivingBody _
+ = putTMVar niReceiveBodyReq WasteAll
+ driftFromTo DecidingHeader _
+ = postprocess ni
+ driftFromTo _ _
= return ()
projects / Lucu.git / blobdiff