{-# LANGUAGE DoAndIfThenElse , GeneralizedNewtypeDeriving , OverloadedStrings , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Resource.Internal ( Resource , ResourceDef(..) , emptyResource , spawnResource , getConfig , getRemoteAddr , getRemoteCertificate , getRequest , getResourcePath , getChunk , setStatus , setHeader , deleteHeader , putBuilder , driftTo ) where import Blaze.ByteString.Builder (Builder) import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad.IO.Class import Control.Monad.Reader 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.Maybe 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.Interaction import Network.HTTP.Lucu.Postprocess 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 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do -- any 'IO' actions. newtype Resource a = Resource { unResource ∷ 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 -- | 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 -- 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 -- 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 -- 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 -- 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 -- resource path. If 'resDelete' is Nothing, the system responds -- \"405 Method Not Allowed\" for DELETE requests. , resDelete ∷ !(Maybe (Resource ())) } -- |'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 → NormalInteraction → IO ThreadId spawnResource (ResourceDef {..}) ni@(NI {..}) = fork $ run `catch` processException where fork ∷ IO () → IO ThreadId fork | resUsesNativeThread = forkOS | otherwise = forkIO run ∷ IO () run = flip runResource ni $ do req ← getRequest fromMaybe notAllowed $ rsrc req driftTo Done rsrc ∷ Request → Maybe (Resource ()) rsrc req = case reqMethod req of GET → resGet HEAD → case resHead of Just r → Just r Nothing → resGet POST → resPost PUT → resPut DELETE → resDelete _ → error $ "Unknown request method: " ⧺ show (reqMethod req) notAllowed ∷ Resource () notAllowed = setStatus MethodNotAllowed *> (setHeader "Allow" $ A.fromAsciiBuilder $ joinWith ", " $ map A.toAsciiBuilder allowedMethods) allowedMethods ∷ [Ascii] allowedMethods = nub $ concat [ methods resGet ["GET"] , methods resHead ["GET", "HEAD"] , methods resPost ["POST"] , methods resPut ["PUT"] , methods resDelete ["DELETE"] ] methods ∷ Maybe a → [Ascii] → [Ascii] methods m xs | isJust m = xs | otherwise = [] toAbortion ∷ SomeException → Abortion toAbortion e = case fromException e of Just abortion → abortion Nothing → mkAbortion' InternalServerError $ T.pack $ show e processException ∷ SomeException → IO () processException exc = do let abo = toAbortion exc state ← atomically $ readTVar niState res ← atomically $ readTVar niResponse if state ≤ DecidingHeader then -- We still have a chance to reflect this abortion -- in the response. Hooray! flip runResource ni $ do setStatus $ aboStatus abo mapM_ (uncurry setHeader) $ H.fromHeaders $ 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 dumpAbortion ∷ Abortion → IO () dumpAbortion abo = hPutStr stderr $ concat [ "Lucu: an exception occured after " , "sending the response header to the client:\n" , " ", show abo, "\n" ] getInteraction ∷ Resource NormalInteraction getInteraction = Resource ask -- |Get the 'Config' value for this httpd. getConfig ∷ Resource Config getConfig = niConfig <$> getInteraction -- |Get the 'SockAddr' of the remote host. getRemoteAddr ∷ Resource SockAddr getRemoteAddr = niRemoteAddr <$> 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 = niRemoteCert <$> getInteraction -- |Return the 'Request' value representing the request header. You -- usually don't need to call this function directly. getRequest ∷ Resource 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 -- greedy. -- -- Example: -- -- > main = let tree = mkResTree [ (["foo"], resFoo) ] -- > in runHttpd defaultConfig tree [] -- > -- > resFoo = emptyResource { -- > resIsGreedy = True -- > , resGet = Just $ do requestURI <- getRequestURI -- > resourcePath <- getResourcePath -- > pathInfo <- getPathInfo -- > -- uriPath requestURI == "/foo/bar/baz" -- > -- resourcePath == ["foo"] -- > -- pathInfo == ["bar", "baz"] -- > ... -- > } getResourcePath ∷ Resource [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 -- 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 askForInput =≪ getInteraction else driftTo DecidingHeader *> return (∅) where askForInput ∷ NormalInteraction → Resource Strict.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 (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 ni ← getInteraction liftIO $ atomically $ do state ← readTVar $ niState ni when (state > DecidingHeader) $ fail "Too late to declare the response status." setResponseStatus ni 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. -- -- Some important headers (especially \"Content-Length\" and -- \"Transfer-Encoding\") may be silently dropped or overwritten by -- the system not to corrupt the interaction with client at the -- viewpoint of HTTP protocol layer. For instance, if we are keeping -- the connection alive, without this manipulation it will be a -- catastrophe when we send a header \"Content-Length: 10\" and -- actually send a body of 20 bytes long to the remote peer. In this -- 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 = do ni ← getInteraction liftIO $ atomically $ go ni 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 -- any. This function is not intended to be used so frequently. deleteHeader ∷ CIAscii → Resource () deleteHeader name = do ni ← getInteraction liftIO $ atomically $ go ni 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 -- |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 declare the response header -- \"Content-Type\" before applying this function. See -- 'setContentType'. putBuilder ∷ Builder → Resource () putBuilder b = do ni ← getInteraction liftIO $ atomically $ go ni where 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 → Resource () driftTo newState = do ni ← getInteraction liftIO $ atomically $ driftTo' ni newState 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 SendingBody = fail "It makes no sense to output something after finishing outputs." throwStateError old new = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new) driftFromTo ∷ InteractionState → InteractionState → STM () driftFromTo ReceivingBody _ = putTMVar niReceiveBodyReq WasteAll driftFromTo DecidingHeader _ = postprocess ni driftFromTo _ _ = return ()