X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FInternal.hs;h=418a330f5c7bca2d6bb05a2cc9a9d2cbaa8645a7;hp=d68b334ed7f706d4c7234bfb9b6799d2505ae3a6;hb=7843dbf537dfefa583a8ee55b2a31a5e8a9c7c37;hpb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6 diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index d68b334..418a330 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -11,12 +11,16 @@ module Network.HTTP.Lucu.Resource.Internal , emptyResource , spawnResource - , getInteraction + , getConfig + , getRemoteAddr + , getRemoteCertificate , getRequest + , getResourcePath + + , getChunk , setStatus , setHeader - , setHeader' , deleteHeader , putBuilder @@ -33,9 +37,11 @@ import Control.Monad.IO.Class 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 @@ -46,6 +52,8 @@ 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 @@ -61,7 +69,7 @@ newtype Resource a 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 @@ -77,7 +85,7 @@ data ResourceDef = ResourceDef { -- 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. -- @@ -85,20 +93,20 @@ data ResourceDef = ResourceDef { -- 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 ())) @@ -186,12 +194,11 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..}) 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 @@ -207,30 +214,108 @@ 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 --- |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. -- @@ -246,45 +331,44 @@ setStatus sc -- 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 [] @@ -299,25 +383,29 @@ driftTo 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 + 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 ()