X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FInternal.hs;h=a1ad95674aefc46e360dd86d221c061439137f4a;hp=1d01a8258751af7a73a4a17ee26a0dd41fd17153;hb=f402841101b4b84f263eea1a43c848f81c48ff93;hpb=0aa4f6d758fc12fba468f7cd399bbcc48f693d1e diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index 1d01a82..a1ad956 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -35,6 +35,7 @@ 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 @@ -43,6 +44,7 @@ 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 @@ -61,11 +63,11 @@ import System.IO -- any 'IO' actions. newtype Resource a = Resource { - unResource ∷ ReaderT Interaction IO a + unResource ∷ ReaderT NormalInteraction IO a } deriving (Applicative, Functor, Monad, MonadIO) -runResource ∷ Resource a → Interaction → IO a +runResource ∷ Resource a → NormalInteraction → IO a runResource = runReaderT ∘ unResource -- |'ResourceDef' is basically a set of 'Resource' monads for each @@ -137,8 +139,8 @@ emptyResource = ResourceDef { , resDelete = Nothing } -spawnResource ∷ ResourceDef → Interaction → IO ThreadId -spawnResource (ResourceDef {..}) itr@(Interaction {..}) +spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId +spawnResource (ResourceDef {..}) ni@(NI {..}) = fork $ run `catch` processException where fork ∷ IO () → IO ThreadId @@ -146,7 +148,7 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..}) | otherwise = forkIO run ∷ IO () - run = flip runResource itr $ + run = flip runResource ni $ do req ← getRequest fromMaybe notAllowed $ rsrc req driftTo Done @@ -188,26 +190,26 @@ 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 - state ← atomically $ readTVar itrState - res ← atomically $ readTVar itrResponse + 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 itr $ + flip runResource ni $ do setStatus $ aboStatus abo + mapM_ (uncurry setHeader) $ H.fromHeaders $ 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 + runResource (driftTo Done) ni dumpAbortion ∷ Abortion → IO () dumpAbortion abo @@ -217,16 +219,16 @@ dumpAbortion abo , " ", show abo, "\n" ] -getInteraction ∷ Resource Interaction +getInteraction ∷ Resource NormalInteraction getInteraction = Resource ask -- |Get the 'Config' value for this httpd. getConfig ∷ Resource Config -getConfig = itrConfig <$> getInteraction +getConfig = niConfig <$> getInteraction -- |Get the 'SockAddr' of the remote host. getRemoteAddr ∷ Resource SockAddr -getRemoteAddr = itrRemoteAddr <$> getInteraction +getRemoteAddr = niRemoteAddr <$> getInteraction -- | Return the X.509 certificate of the client, or 'Nothing' if: -- @@ -238,12 +240,12 @@ getRemoteAddr = itrRemoteAddr <$> getInteraction -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to -- 'OpenSSL.Session.VerifyPeer'. getRemoteCertificate ∷ Resource (Maybe X509) -getRemoteCertificate = itrRemoteCert <$> getInteraction +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 = (fromJust ∘ itrRequest) <$> getInteraction +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 @@ -267,7 +269,7 @@ getRequest = (fromJust ∘ itrRequest) <$> getInteraction -- > , ... -- > } getResourcePath ∷ Resource [Strict.ByteString] -getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction +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 @@ -283,20 +285,19 @@ getChunk' n | n ≡ 0 = return (∅) | otherwise = do req ← getRequest if reqMustHaveBody req then - do itr ← getInteraction - askForInput itr + askForInput =≪ getInteraction else driftTo DecidingHeader *> return (∅) where - askForInput ∷ Interaction → Resource Strict.ByteString - askForInput (Interaction {..}) + askForInput ∷ NormalInteraction → Resource Strict.ByteString + askForInput (NI {..}) = do -- Ask the RequestReader to get a chunk. liftIO $ atomically - $ putTMVar itrReceiveBodyReq (ReceiveBody n) + $ putTMVar niReceiveBodyReq (ReceiveBody n) -- Then wait for a reply. chunk ← liftIO $ atomically - $ takeTMVar itrReceivedBody + $ takeTMVar niReceivedBody -- Have we got an EOF? when (Strict.null chunk) $ driftTo DecidingHeader @@ -306,12 +307,12 @@ getChunk' n -- the status code will be defaulted to \"200 OK\". setStatus ∷ StatusCode → Resource () setStatus sc - = do itr ← getInteraction + = do ni ← getInteraction liftIO $ atomically - $ do state ← readTVar $ itrState itr + $ do state ← readTVar $ niState ni when (state > DecidingHeader) $ fail "Too late to declare the response status." - setResponseStatus itr sc + 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 @@ -330,31 +331,35 @@ setStatus sc -- of the next response. setHeader ∷ CIAscii → Ascii → Resource () setHeader name value - = do itr ← getInteraction - liftIO $ atomically - $ 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 + = 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 itr ← getInteraction - liftIO $ atomically - $ 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 + = 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 is safe to apply this function to a 'Builder' producing an @@ -365,23 +370,27 @@ deleteHeader name -- 'setContentType'. putBuilder ∷ Builder → Resource () putBuilder b - = do itr ← getInteraction - liftIO $ atomically - $ do driftTo' itr SendingBody - hasCType ← readTVar $ itrResponseHasCType itr - unless hasCType - $ abortSTM InternalServerError [] - $ Just "putBuilder: Content-Type has not been set." - putTMVar (itrBodyToSend itr) 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 itr ← getInteraction - liftIO $ atomically $ driftTo' itr newState + = do ni ← getInteraction + liftIO $ atomically $ driftTo' ni newState -driftTo' ∷ Interaction → InteractionState → STM () -driftTo' itr@(Interaction {..}) newState - = do oldState ← readTVar itrState +driftTo' ∷ NormalInteraction → InteractionState → STM () +driftTo' ni@(NI {..}) newState + = do oldState ← readTVar niState driftFrom oldState where driftFrom ∷ InteractionState → STM () @@ -393,7 +402,7 @@ driftTo' itr@(Interaction {..}) newState b = tail a c = zip a b mapM_ (uncurry driftFromTo) c - writeTVar itrState newState + writeTVar niState newState throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a throwStateError Done SendingBody @@ -403,8 +412,8 @@ driftTo' itr@(Interaction {..}) newState driftFromTo ∷ InteractionState → InteractionState → STM () driftFromTo ReceivingBody _ - = putTMVar itrReceiveBodyReq WasteAll + = putTMVar niReceiveBodyReq WasteAll driftFromTo DecidingHeader _ - = postprocess itr + = postprocess ni driftFromTo _ _ = return ()