text-icu == 0.6.*,
time == 1.2.*,
time-http == 0.2.*,
- unix == 2.4.*,
- zlib == 0.5.*
+ transformers == 0.2.*,
+ unix == 2.4.*
Exposed-Modules:
Network.HTTP.Lucu
Network.HTTP.Lucu.Postprocess
Network.HTTP.Lucu.Preprocess
Network.HTTP.Lucu.RequestReader
+ Network.HTTP.Lucu.Resource.Internal
Network.HTTP.Lucu.ResponseWriter
Network.HTTP.Lucu.SocketLike
Main-Is: ImplantFile.hs
Build-Depends:
- SHA == 1.5.*
+ SHA == 1.5.*,
+ zlib == 0.5.*
ghc-options:
-Wall
, abortPage
)
where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import Control.Arrow.ArrowIO
import Control.Arrow.ListArrow
import Control.Arrow.Unicode
import Data.Ascii (Ascii, CIAscii)
import Data.Text (Text)
import qualified Data.Text as T
-import qualified Data.Text.Lazy as Lazy
import Data.Typeable
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
-- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
-- additional response headers, and optional message string.
--
--- What this really does is to throw a special
--- 'Control.Exception.Exception'. The exception will be caught by the
--- Lucu system.
+-- What this really does is to throw an instance of 'Exception'. The
+-- exception will be caught by the Lucu system.
--
-- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
-- Header/ or any precedent states, it is possible to use the
--
-- 2. Otherwise the HTTP response can't be modified anymore so the
-- only possible thing the system can do is to dump it to the
--- stderr. See
--- 'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
+-- stderr. See 'cnfDumpTooLateAbortionToStderr'.
--
--- Note that the status code doesn't have to be an error code so you
--- can use this action for redirection as well as error reporting e.g.
+-- Note that the status code doesn't necessarily have to be an error
+-- code so you can use this action for redirection as well as error
+-- reporting e.g.
--
-- > abort MovedPermanently
-- > [("Location", "http://example.net/")]
-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
-- ければならない。
-abortPage ∷ Config → Maybe Request → Response → Abortion → Lazy.Text
+abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
abortPage conf reqM res abo
= case aboMessage abo of
Just msg
writeDocumentToString [ withIndent True ]
) ()
in
- Lazy.pack html
+ BB.fromString html
Nothing
→ let res' = res { resStatus = aboStatus abo }
res'' = foldl (∘) id [setHeader name value
, cnfMaxPipelineDepth ∷ !Int
-- |The maximum length of request entity to accept in bytes. Note
- -- that this is nothing but the default value which is used when
- -- 'Network.HTTP.Lucu.Resource.input' and such like are applied to
- -- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no
+ -- that this is nothing but a default value which is used when
+ -- 'Network.HTTP.Lucu.Resource.getForm' and such like are applied
+ -- to 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no
-- guarantee that this value always constrains all the requests.
, cnfMaxEntityLength ∷ !Int
, mkDefaultPage
)
where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ListArrow
import qualified Data.Ascii as A
import Data.Maybe
import qualified Data.Text as T
-import qualified Data.Text.Lazy as Lazy
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Request
import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.DOM.TypeDefs
-getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text
+getDefaultPage ∷ Config → Maybe Request → Response → Builder
{-# INLINEABLE getDefaultPage #-}
getDefaultPage conf req res
= let msgA = getMsg req res
writeDocumentToString [ withIndent True ]
) ()
in
- Lazy.pack xmlStr
+ BB.fromString xmlStr
defaultPageContentType ∷ Ascii
{-# INLINE defaultPageContentType #-}
( Interaction(..)
, InteractionState(..)
, InteractionQueue
+ , GetBodyRequest(..)
, newInteractionQueue
, newInteraction
where
import Blaze.ByteString.Builder (Builder)
import Control.Concurrent.STM
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as Strict
import Data.Monoid.Unicode
import Data.Sequence (Seq)
import qualified Data.Sequence as S
, itrExpectedContinue ∷ !(Maybe Bool)
, itrReqBodyLength ∷ !(Maybe RequestBodyLength)
- , itrReqBodyWanted ∷ !(TVar Int)
- , itrReqBodyWasteAll ∷ !(TVar Bool)
- , itrReqChunkIsOver ∷ !(TVar Bool)
- , itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
- , itrReceivedBodyLen ∷ !(TVar Int)
+ , itrGetBodyRequest ∷ !(TMVar GetBodyRequest)
+ , itrGotBody ∷ !(TMVar Strict.ByteString)
, itrResponse ∷ !(TVar Response)
, itrWillChunkBody ∷ !(TVar Bool)
-- |The interaction state of Resource monad. 'ExaminingRequest' is the
-- initial state.
-data InteractionState = ExaminingRequest
- | GettingBody
- | DecidingHeader
- | DecidingBody
- | Done
- deriving (Show, Eq, Ord, Enum)
+data InteractionState
+ = ExaminingRequest
+ | GettingBody
+ | DecidingHeader
+ | DecidingBody
+ | Done
+ deriving (Show, Eq, Ord, Enum)
type InteractionQueue = TVar (Seq Interaction)
+data GetBodyRequest
+ = GetBody !Int -- ^ Maximum number of bytes.
+ | WasteAll
+ deriving (Show, Eq)
+
newInteractionQueue ∷ IO InteractionQueue
newInteractionQueue = newTVarIO S.empty
, resHeaders = (∅)
}
- reqBodyWanted ← newTVarIO 0
- reqBodyWasteAll ← newTVarIO False
- reqChunkIsOver ← newTVarIO False
- receivedBody ← newTVarIO S.empty
- receivedBodyLen ← newTVarIO 0
+ getBodyRequest ← newEmptyTMVarIO
+ gotBody ← newEmptyTMVarIO
response ← newTVarIO res
willChunkBody ← newTVarIO False
state ← newTVarIO ExaminingRequest
return Interaction {
- itrConfig = conf
- , itrLocalPort = port
- , itrRemoteAddr = addr
- , itrRemoteCert = cert
- , itrResourcePath = Nothing
- , itrRequest = arRequest ar
+ itrConfig = conf
+ , itrLocalPort = port
+ , itrRemoteAddr = addr
+ , itrRemoteCert = cert
+ , itrResourcePath = Nothing
+ , itrRequest = arRequest ar
, itrExpectedContinue = arExpectedContinue ar
, itrReqBodyLength = arReqBodyLength ar
- , itrReqBodyWanted = reqBodyWanted
- , itrReqBodyWasteAll = reqBodyWasteAll
- , itrReqChunkIsOver = reqChunkIsOver
- , itrReceivedBody = receivedBody
- , itrReceivedBodyLen = receivedBodyLen
+ , itrGetBodyRequest = getBodyRequest
+ , itrGotBody = gotBody
, itrResponse = response
, itrWillChunkBody = willChunkBody
, completeUnconditionalHeaders
)
where
-import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
postprocess ∷ Interaction → STM ()
postprocess itr@(Interaction {..})
= do abortOnCertainConditions itr
- writeDefaultPageIfNeeded itr
case itrRequest of
Just req → postprocessWithRequest itr req
= do resHasCType ← readTVar itrResponseHasCType
unless resHasCType
$ do writeHeader itr "Content-Type" (Just defaultPageContentType)
+ writeHeader itr "Content-Encoding" Nothing
res ← readTVar itrResponse
let page = getDefaultPage itrConfig itrRequest res
- putTMVar itrBodyToSend (BB.fromLazyText page)
+ putTMVar itrBodyToSend page
writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM ()
{-# INLINE writeHeader #-}
, RecordWildCards
, UnicodeSyntax
#-}
-{-# OPTIONS_HADDOCK prune #-}
-- |This is the Resource Monad; monadic actions to define the behavior
-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
-- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
-- the entire request before starting 'Resource', nor we don't want to
-- postpone writing the entire response till the end of 'Resource'
-- computation.
-
module Network.HTTP.Lucu.Resource
(
-- * Types
Resource
, FormData(..)
- , runRes
-
- -- * Actions
-
- -- ** Getting request header
+ -- * Getting request header
-- |These actions can be computed regardless of the current state,
-- and they don't change the state.
, getConfig
, getContentType
, getAuthorization
- -- ** Finding an entity
-
+ -- * Finding an entity
-- |These actions can be computed only in the /Examining Request/
-- state. After the computation, the 'Resource' transits to
-- /Getting Body/ state.
, foundTimeStamp
, foundNoEntity
- -- ** Getting a request body
-
+ -- * Getting a request body
-- |Computation of these actions changes the state to /Getting
-- Body/.
- , input
- , inputChunk
- , inputForm
+ , getChunk
+ , getChunks
+ , getForm
, defaultLimit
- -- ** Setting response headers
-
+ -- * Setting response headers
-- |Computation of these actions changes the state to /Deciding
-- Header/.
, setStatus
- , setHeader
, redirect
, setContentType
- , setLocation
, setContentEncoding
, setWWWAuthenticate
- -- ** Writing a response body
+ -- ** Less frequently used functions
+ , setLocation
+ , setHeader
+ , deleteHeader
+ -- * Writing a response body
-- |Computation of these actions changes the state to /Deciding
-- Body/.
, putChunk
+ , putChunks
, putBuilder
-
- , driftTo -- private
)
where
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.ByteString as BB
import Control.Applicative
import Control.Concurrent.STM
-import Control.Monad.Reader
+import Control.Monad
+import Control.Monad.IO.Class
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import Network.HTTP.Lucu.MultipartForm
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Utils
import OpenSSL.X509
import Prelude.Unicode
--- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
--- any 'IO' actions.
-newtype Resource a
- = Resource {
- unRes ∷ ReaderT Interaction IO a
- }
- deriving (Applicative, Functor, Monad, MonadIO)
-
-runRes ∷ Resource a → Interaction → IO a
-runRes r itr
- = runReaderT (unRes r) itr
-
-getInteraction ∷ Resource Interaction
-getInteraction = Resource ask
-
-- |Get the 'Config' value which is used for the httpd.
getConfig ∷ Resource Config
getConfig = itrConfig <$> getInteraction
getRemoteCertificate ∷ Resource (Maybe X509)
getRemoteCertificate = itrRemoteCert <$> getInteraction
--- |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
-
-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
getMethod = reqMethod <$> getRequest
-- Setting response headers
--- | Set the response status code. If you omit to compute this action,
--- the status code will be defaulted to \"200 OK\".
-setStatus ∷ StatusCode → Resource ()
-setStatus sc
- = do driftTo DecidingHeader
- itr ← getInteraction
- liftIO
- $ atomically
- $ setResponseStatus itr sc
-
--- | Set a value of given resource header. Comparison of header name
--- is case-insensitive. Note that this action is not intended to be
--- used so frequently: there should be actions 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 process it causes a catastrophe
--- to send a header \"Content-Length: 10\" and actually send a body of
--- 20 bytes long. 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 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
-
-- | Computation of @'redirect' code uri@ sets the response status to
-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
-- 'isRedirection' or it causes an error.
-- | Computation of @'setContentType' mType@ sets the response header
-- \"Content-Type\" to @mType@.
setContentType ∷ MIMEType → Resource ()
-{-# INLINE setContentType #-}
-setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+setContentType
+ = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
-- | Computation of @'setLocation' uri@ sets the response header
--- \"Location\" to @uri@.
+-- \"Location\" to @uri@. You usually don't need to call this function
+-- directly.
setLocation ∷ URI → Resource ()
setLocation uri
= case A.fromChars uriStr of
-- Note that you must first set the response header \"Content-Type\"
-- before applying this function. See: 'setContentType'
putChunk ∷ Lazy.ByteString → Resource ()
-{-# INLINE putChunk #-}
putChunk = putBuilder ∘ BB.fromLazyByteString
-
--- | 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
-
-
--- Private
-
-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 _
- = writeTVar itrReqBodyWasteAll True
- drift DecidingHeader _
- = postprocess itr
- drift _ _
- = return ()
--- /dev/null
+{-# 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 ()
-- | Repository of the resources in httpd.
module Network.HTTP.Lucu.Resource.Tree
- ( ResourceDef(..)
- , emptyResource
-
- , ResTree
+ ( ResTree
, FallbackHandler
, mkResTree
-
, findResource
- , runResource
)
where
import Control.Arrow
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
-import qualified Data.Text.Lazy.Encoding as LT
import Data.List
import qualified Data.Map as M
import Data.Map (Map)
import Prelude hiding (catch)
import Prelude.Unicode
-
-- |'FallbackHandler' is an extra resource handler for resources which
-- can't be statically located anywhere in the resource tree. The Lucu
-- httpd first searches for a resource in the tree, and then calls
-- handlers returned 'Nothing', the httpd responds with 404 Not Found.
type FallbackHandler = [Text] → IO (Maybe ResourceDef)
-
--- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
--- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
--- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
--- 無視される。
-
--- | '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
- }
-
-- |'ResTree' is an opaque structure which is a map from resource path
-- to 'ResourceDef'.
newtype ResTree = ResTree ResNode -- root だから Map ではない
case m of
Just def → return $ Just ([], def)
Nothing → fallback path xs
-
-
-runResource ∷ ResourceDef → Interaction → IO ThreadId
-runResource (ResourceDef {..}) itr@(Interaction {..})
- = fork $ run `catch` processException
- where
- fork ∷ IO () → IO ThreadId
- fork | resUsesNativeThread = forkOS
- | otherwise = forkIO
-
- run ∷ IO ()
- run = flip runRes 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 runRes itr $
- do setStatus $ aboStatus abo
- setHeader "Content-Type" defaultPageContentType
- mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
- putChunk $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
- else
- when (cnfDumpTooLateAbortionToStderr itrConfig)
- $ dumpAbortion abo
- runRes (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"
- ]
→ STM (IO ())
writeContinueIfNeeded ctx itr@(Interaction {..}) phase
| phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
- = do reqBodyWanted ← readTVar itrReqBodyWanted
- if reqBodyWanted > 0 then
+ = do isRequested ← isEmptyTMVar itrGetBodyRequest
+ if isRequested then
return $ writeContinue ctx itr
else
retry
projects / Lucu.git / commitdiff