X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FInternal.hs;h=a19339c1e6280e3830987bab5a9d200002ad6344;hp=9df36a601cf7dc460dd8b98f92ed084054719504;hb=950640dd241222203778f8167943d30fa52f356a;hpb=ece223c516e66223ef1d5d8e6bbe4054a235d983 diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index 9df36a6..a19339c 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -1,19 +1,23 @@ {-# LANGUAGE - DoAndIfThenElse + CPP + , DoAndIfThenElse + , FlexibleInstances , GeneralizedNewtypeDeriving , OverloadedStrings + , MultiParamTypeClasses , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Resource.Internal - ( Resource - , ResourceDef(..) - , emptyResource - , spawnResource + ( Rsrc + , Resource(..) + , spawnRsrc , getConfig , getRemoteAddr +#if defined(HAVE_SSL) , getRemoteCertificate +#endif , getRequest , getResourcePath @@ -33,13 +37,16 @@ import Control.Applicative 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.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 @@ -53,107 +60,111 @@ 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 +#if defined(HAVE_SSL) import OpenSSL.X509 -import Prelude hiding (catch) +#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 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 - -- | 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 -- 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: --- --- @ --- 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 +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 - 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 @@ -165,7 +176,7 @@ spawnResource (ResourceDef {..}) ni@(NI {..}) DELETE → resDelete _ → error $ "Unknown request method: " ⧺ show (reqMethod req) - notAllowed ∷ Resource () + notAllowed ∷ Rsrc () notAllowed = do setStatus MethodNotAllowed setHeader "Allow" $ A.fromAsciiBuilder @@ -200,16 +211,16 @@ spawnResource (ResourceDef {..}) ni@(NI {..}) 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 @@ -219,17 +230,18 @@ 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. @@ -239,46 +251,52 @@ getRemoteAddr = niRemoteAddr <$> getInteraction -- * 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 --- greedy. +-- |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 = 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] +-- @ +-- 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 'Strict.empty' and makes 'Resource' transit to --- the /Deciding Header/ state. -getChunk ∷ Int → Resource Strict.ByteString +-- 'getChunk' returns 'BS.empty' and makes 'Rsrc' transit to the +-- /Deciding Header/ state. +getChunk ∷ Int → Rsrc ByteString getChunk = (driftTo ReceivingBody *>) ∘ getChunk' -getChunk' ∷ Int → Resource Strict.ByteString +getChunk' ∷ Int → Rsrc ByteString getChunk' n | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n) | n ≡ 0 = return (∅) @@ -288,7 +306,7 @@ getChunk' n else driftTo DecidingHeader *> return (∅) where - askForInput ∷ NormalInteraction → Resource Strict.ByteString + askForInput ∷ NormalInteraction → Rsrc ByteString askForInput (NI {..}) = do -- Ask the RequestReader to get a chunk. liftIO $ atomically @@ -298,25 +316,26 @@ getChunk' n $ atomically $ takeTMVar niReceivedBody -- Have we got an EOF? - when (Strict.null chunk) + 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 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 -- 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 @@ -328,10 +347,8 @@ setStatus sc -- 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 +setHeader ∷ CIAscii → Ascii → Rsrc () +setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction where go ∷ NormalInteraction → STM () go (NI {..}) @@ -345,10 +362,8 @@ setHeader name value -- |@'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 +deleteHeader ∷ CIAscii → Rsrc () +deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction where go ∷ NormalInteraction → STM () go (NI {..}) @@ -366,12 +381,11 @@ deleteHeader name -- -- 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 +-- '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 @@ -382,10 +396,8 @@ putBuilder b "putBuilder: Content-Type has not been set." putTMVar niBodyToSend b -driftTo ∷ InteractionState → Resource () -driftTo newState - = do ni ← getInteraction - liftIO $ atomically $ driftTo' ni newState +driftTo ∷ InteractionState → Rsrc () +driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo' driftTo' ∷ NormalInteraction → InteractionState → STM () driftTo' ni@(NI {..}) newState