{-# LANGUAGE DoAndIfThenElse , GeneralizedNewtypeDeriving , OverloadedStrings , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Resource.Internal ( Resource , ResourceDef(..) , emptyResource , spawnResource , getInteraction , getRequest , setStatus , setHeader , 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 Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A 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.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 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 Interaction 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 -- | 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 -- 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 -- 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 → Interaction → IO ThreadId spawnResource (ResourceDef {..}) itr@(Interaction {..}) = fork $ run `catch` processException where fork ∷ IO () → IO ThreadId fork | resUsesNativeThread = forkOS | otherwise = forkIO run ∷ IO () run = flip runResource itr $ 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 → Abortion InternalServerError (∅) (Just $ T.pack $ show e) processException ∷ SomeException → IO () processException exc = do let abo = toAbortion exc -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 state ← atomically $ readTVar itrState res ← atomically $ readTVar itrResponse if state ≤ DecidingHeader then flip runResource itr $ do setStatus $ aboStatus abo setHeader "Content-Type" defaultPageContentType deleteHeader "Content-Encoding" mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo putBuilder $ abortPage itrConfig itrRequest res abo else when (cnfDumpTooLateAbortionToStderr itrConfig) $ dumpAbortion abo runResource (driftTo Done) itr dumpAbortion ∷ Abortion → IO () dumpAbortion abo = hPutStr stderr $ concat [ "Lucu: an exception occured after " , "sending 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. getRequest ∷ Resource Request getRequest = (fromJust ∘ itrRequest) <$> getInteraction -- | Set 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 -- 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 = 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 -- | @'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 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. -- -- 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 where throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a throwStateError Done DecidingBody = 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 _ _ = return ()