X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FInternal.hs;h=d5a14117f267a781d75908619de76592a3ab74c7;hp=d68b334ed7f706d4c7234bfb9b6799d2505ae3a6;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6 diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index d68b334..d5a1411 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -1,22 +1,29 @@ {-# LANGUAGE - DoAndIfThenElse + CPP + , DoAndIfThenElse , GeneralizedNewtypeDeriving , OverloadedStrings , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Resource.Internal - ( Resource - , ResourceDef(..) + ( Rsrc + , Resource(..) , emptyResource - , spawnResource + , spawnRsrc - , getInteraction + , getConfig + , getRemoteAddr +#if defined(HAVE_SSL) + , getRemoteCertificate +#endif , getRequest + , getResourcePath + + , getChunk , setStatus , setHeader - , setHeader' , deleteHeader , putBuilder @@ -29,15 +36,21 @@ 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 Data.List +import qualified Data.ByteString as Strict +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 @@ -45,30 +58,28 @@ 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 Prelude hiding (catch) +import Network.Socket +#if defined(HAVE_SSL) +import OpenSSL.X509 +#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 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 +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 @@ -76,40 +87,40 @@ data ResourceDef = ResourceDef { -- 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 - -- 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: +-- 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 @@ -119,10 +130,9 @@ data ResourceDef = ResourceDef { -- , resDelete = Nothing -- } -- @ -emptyResource ∷ ResourceDef -emptyResource = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False +emptyResource ∷ Resource +emptyResource = Resource { + resIsGreedy = False , resGet = Nothing , resHead = Nothing , resPost = Nothing @@ -130,21 +140,17 @@ emptyResource = ResourceDef { , resDelete = Nothing } -spawnResource ∷ ResourceDef → Interaction → IO ThreadId -spawnResource (ResourceDef {..}) itr@(Interaction {..}) - = 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 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 @@ -156,13 +162,13 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..}) 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"] @@ -181,56 +187,134 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..}) 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 + +-- |Return the 'Request' value representing the request header. You +-- usually don't need to call this function directly. +getRequest ∷ Rsrc Request +getRequest = niRequest <$> getInteraction + +-- |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: +-- +-- > 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 ∷ 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 'Rsrc' transit to +-- the /Deciding Header/ state. +getChunk ∷ Int → Rsrc Strict.ByteString +getChunk = (driftTo ReceivingBody *>) ∘ getChunk' --- |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 +getChunk' ∷ Int → Rsrc 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 → Rsrc 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 --- | Set the response status code. If you don't call this function, +-- |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. -- @@ -244,80 +328,84 @@ 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 - = 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: +-- '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 ()