+{-# 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 ()
projects / Lucu.git / commitdiff