Name: Lucu
-Synopsis: HTTP Daemonic Library
+Synopsis: Embedded HTTP Server
Description:
- Lucu is an HTTP daemonic library. It can be embedded in any
- Haskell program and runs in an independent thread.
+ Lucu is an embedded HTTP server library.
- Lucu is not a replacement for Apache nor lighttpd. It is
- intended to be used to build an efficient web-based RESTful
- application. It is also intended to be run behind a
- reverse-proxy so it doesn't have some facilities like logging,
- client filtering or such like.
+ It's not a replacement for Apache nor lighttpd. It is intended
+ to be used to build an efficient web-based RESTful application
+ which runs behind a reverse-proxy so it doesn't have some
+ functionalities like logging, client filtering or such like.
Version: 1.0
License: PublicDomain
mtl == 2.0.*,
network == 2.3.*,
stm == 2.2.*,
+ strict == 0.3.*,
text == 0.11.*,
text-icu == 0.6.*,
time == 1.2.*,
Network.HTTP.Lucu.Utils
Other-Modules:
+ Network.HTTP.Lucu.Abortion.Internal
Network.HTTP.Lucu.Chunk
Network.HTTP.Lucu.ContentCoding
Network.HTTP.Lucu.DefaultPage
--- | Lucu is an HTTP daemonic library. It can be embedded in any
--- Haskell program and runs in an independent thread.
+-- | Lucu is an embedded HTTP server library.
--
-- Features:
--
--- [/Full support of HTTP\/1.1/] Lucu supports request pipelining,
--- chunked I\/O, ETag comparison and \"100 Continue\".
---
--- [/Performance/] Lucu is carefully designed to gain a good
--- performance.
---
-- [/Affinity for RESTafarians/] Lucu is specifically designed to be
-- suitable for RESTful applications.
--
--- [/SSL connections/] Lucu can handle HTTP connections over SSL
--- layer.
+-- [/Full support of HTTP\/1.1/] Lucu supports request pipelining,
+-- chunked I\/O, ETag comparison and \"100 Continue\".
+--
+-- [/SSL connections/] Lucu can handle HTTP connections over Secure
+-- Socket Layer.
--
-- Lucu is not a replacement for Apache or lighttpd. It is intended to
-- be used to build an efficient web-based RESTful application. It is
-- also intended to be run behind a reverse-proxy so it doesn't have
--- the following (otherwise essential) facilities:
+-- the following (otherwise essential) functionalities:
--
-- [/Logging/] Lucu doesn't write logs of any requests from any
-- clients.
, StatusCode(..)
-- *** Abortion
+ , Abortion
+ , mkAbortion
+ , mkAbortion'
, abort
- , abortPurely
- , abortA
-- *** ETag
, ETag(..)
{-# LANGUAGE
- Arrows
- , DeriveDataTypeable
- , TypeOperators
- , UnicodeSyntax
+ UnicodeSyntax
#-}
-- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
-- in any 'Prelude.IO' monads or arrows.
module Network.HTTP.Lucu.Abortion
- ( Abortion(..)
+ ( Abortion
+ , mkAbortion
+ , mkAbortion'
, abort
- , abortPurely
- , abortSTM
- , abortA
- , 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 Control.Concurrent.STM
import Control.Exception
import Control.Monad.Trans
import Data.Ascii (Ascii, CIAscii)
+import Data.Monoid.Unicode
import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Typeable
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Abortion.Internal
import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Prelude.Unicode
-import Text.XML.HXT.Arrow.WriteDocument
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlState
-data Abortion = Abortion {
- aboStatus ∷ !StatusCode
- , aboHeaders ∷ !Headers
- , aboMessage ∷ !(Maybe Text)
- } deriving (Eq, Show, Typeable)
-
-instance Exception Abortion
-
--- |Computation of @'abort' status headers msg@ aborts the
--- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
--- additional response headers, and optional message string.
---
--- 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
--- @status@ and such like as a HTTP response to be sent to the
--- client.
---
--- 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 'cnfDumpTooLateAbortionToStderr'.
---
--- 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/")]
--- > (Just "It has been moved to example.net")
-abort ∷ MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a
+-- |Construct an 'Abortion' with additional headers and an optional
+-- message text.
+mkAbortion ∷ StatusCode → [(CIAscii, Ascii)] → Maybe Text → Abortion
+{-# INLINE mkAbortion #-}
+mkAbortion sc hdr msg
+ = Abortion {
+ aboStatus = sc
+ , aboHeaders = toHeaders hdr
+ , aboMessage = msg
+ }
+
+-- |Construct an 'Abortion' without any additional headers but with a
+-- message text.
+mkAbortion' ∷ StatusCode → Text → Abortion
+{-# INLINE mkAbortion' #-}
+mkAbortion' sc msg
+ = Abortion {
+ aboStatus = sc
+ , aboHeaders = (∅)
+ , aboMessage = Just msg
+ }
+
+-- |Throw an 'Abortion' in a 'MonadIO', including the very
+-- 'Network.HTTP.Lucu.Resource.Resource' monad.
+abort ∷ MonadIO m ⇒ Abortion → m a
{-# INLINE abort #-}
-abort status headers
- = liftIO ∘ throwIO ∘ Abortion status (toHeaders headers)
-
--- |This is similar to 'abort' but computes it with
--- 'System.IO.Unsafe.unsafePerformIO'.
-abortPurely ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a
-{-# INLINE abortPurely #-}
-abortPurely status headers
- = throw ∘ Abortion status (toHeaders headers)
-
--- |Computation of @'abortSTM' status headers msg@ just computes
--- 'abort' in a 'Control.Monad.STM.STM' monad.
-abortSTM ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a
-{-# INLINE abortSTM #-}
-abortSTM status headers
- = throwSTM ∘ Abortion status (toHeaders headers)
-
--- | Computation of @'abortA' -< (status, (headers, msg))@ just
--- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
-abortA ∷ ArrowIO (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
-{-# INLINE abortA #-}
-abortA = proc (status, (headers, msg)) →
- arrIO throwIO ⤙ Abortion status (toHeaders headers) msg
-
--- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
--- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
--- ければならない。
-abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
-abortPage conf reqM res abo
- = case aboMessage abo of
- Just msg
- → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
- ⋙
- writeDocumentToString [ withIndent True ]
- ) ()
- in
- BB.fromString html
- Nothing
- → let res' = res { resStatus = aboStatus abo }
- res'' = foldl (∘) id [setHeader name value
- | (name, value) ← fromHeaders $ aboHeaders abo] res'
- in
- getDefaultPage conf reqM res''
+abort = liftIO ∘ throwIO
--- /dev/null
+{-# LANGUAGE
+ DeriveDataTypeable
+ , UnicodeSyntax
+ #-}
+module Network.HTTP.Lucu.Abortion.Internal
+ ( Abortion(..)
+ , abortPage
+ )
+ where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
+import Control.Arrow.ListArrow
+import Control.Arrow.Unicode
+import Control.Exception
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Typeable
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Prelude.Unicode
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlState
+
+-- |'Abortion' is an 'Exception' that aborts the execution of
+-- 'Network.HTTP.Lucu.Resource.Resource' monad with a 'StatusCode',
+-- additional response headers, and an optional message text.
+--
+-- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
+-- Header/ or any precedent states, throwing an 'Abortion' affects
+-- the HTTP response to be sent to the client.
+--
+-- 2. Otherwise it's too late to overwrite the HTTP response so the
+-- only possible thing the system can do is to dump the exception
+-- to the stderr. See 'cnfDumpTooLateAbortionToStderr'.
+--
+-- Note that the status code doesn't necessarily have to satisfy
+-- 'isError' so you can abuse this exception for redirections as well
+-- as error reporting e.g.
+--
+-- > abort $ mkAbortion MovedPermanently
+-- > [("Location", "http://example.net/")]
+-- > "It has been moved to example.net"
+data Abortion = Abortion {
+ aboStatus ∷ !StatusCode
+ , aboHeaders ∷ !Headers
+ , aboMessage ∷ !(Maybe Text)
+ } deriving (Eq, Show, Typeable)
+
+instance Exception Abortion
+
+instance HasHeaders Abortion where
+ getHeaders = aboHeaders
+ setHeaders abo hdr = abo { aboHeaders = hdr }
+
+abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
+abortPage conf reqM res abo
+ = case aboMessage abo of
+ Just msg
+ → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
+ ⋙
+ writeDocumentToString [ withIndent True ]
+ ) ()
+ in
+ BB.fromString html
+ Nothing
+ → let res' = res { resStatus = aboStatus abo }
+ res'' = foldl (∘) id [setHeader name value
+ | (name, value) ← fromHeaders $ aboHeaders abo] res'
+ in
+ getDefaultPage conf reqM res''
-- > helloWorld :: ResourceDef
-- > helloWorld = emptyResource {
-- > resGet
--- > = Just $ do setContentType $ mkMIMEType "text" "plain"
+-- > = Just $ do setContentType $ parseMIMEType "text/plain"
-- > putChunk "Hello, world!"
-- > }
runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()
httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
httpLoop port so
= do (h, addr) ← SL.accept so
- tQueue ← newInteractionQueue
+ tQueue ← mkInteractionQueue
readerTID ← forkIO $ requestReader cnf tree fbs h port addr tQueue
_writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
httpLoop port so
{-# LANGUAGE
- OverloadedStrings
+ DeriveDataTypeable
+ , ExistentialQuantification
+ , OverloadedStrings
, RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Interaction
( Interaction(..)
+ , SomeInteraction(..)
+
+ , SyntacticallyInvalidInteraction(..)
+ , mkSyntacticallyInvalidInteraction
+
+ , SemanticallyInvalidInteraction(..)
+ , mkSemanticallyInvalidInteraction
+
+ , NormalInteraction(..)
, InteractionState(..)
- , InteractionQueue
, ReceiveBodyRequest(..)
- , newInteractionQueue
- , newInteraction
+ , mkNormalInteraction
+
+ , InteractionQueue
+ , mkInteractionQueue
, setResponseStatus
+ , getCurrentDate
)
where
import Blaze.ByteString.Builder (Builder)
+import Control.Applicative
import Control.Concurrent.STM
+import Data.Ascii (Ascii)
import qualified Data.ByteString as Strict
import Data.Monoid.Unicode
import Data.Sequence (Seq)
-import qualified Data.Sequence as S
+import qualified Data.Strict.Maybe as S
+import Data.Time
+import qualified Data.Time.HTTP as HTTP
+import Data.Typeable
import Network.Socket
import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import OpenSSL.X509
-data Interaction = Interaction {
- itrConfig ∷ !Config
- , itrLocalPort ∷ !PortNumber
- , itrRemoteAddr ∷ !SockAddr
- , itrRemoteCert ∷ !(Maybe X509)
- , itrResourcePath ∷ !(Maybe [Strict.ByteString])
- , itrRequest ∷ !(Maybe Request)
+class Typeable i ⇒ Interaction i where
+ toInteraction ∷ i → SomeInteraction
+ toInteraction = SomeInteraction
+
+ fromInteraction ∷ SomeInteraction → Maybe i
+ fromInteraction (SomeInteraction i) = cast i
+
+data SomeInteraction
+ = ∀i. Interaction i ⇒ SomeInteraction !i
+ deriving Typeable
+
+instance Interaction SomeInteraction where
+ toInteraction = id
+ fromInteraction = Just
+
+-- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
+-- a syntactically valid 'Request'. The response code will always be
+-- 'BadRequest'.
+data SyntacticallyInvalidInteraction
+ = SYI {
+ syiResponse ∷ !Response
+ , syiBodyToSend ∷ !Builder
+ }
+ deriving Typeable
+instance Interaction SyntacticallyInvalidInteraction
+
+mkSyntacticallyInvalidInteraction ∷ Config
+ → IO SyntacticallyInvalidInteraction
+mkSyntacticallyInvalidInteraction config@(Config {..})
+ = do date ← getCurrentDate
+ let res = setHeader "Server" cnfServerSoftware $
+ setHeader "Date" date $
+ setHeader "Content-Type" defaultPageContentType $
+ emptyResponse BadRequest
+ body = getDefaultPage config Nothing res
+ return SYI {
+ syiResponse = res
+ , syiBodyToSend = body
+ }
+
+-- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
+-- semantically valid 'Request'. The response code will always satisfy
+-- 'isError'.
+data SemanticallyInvalidInteraction
+ = SEI {
+ seiRequest ∷ !Request
+ , seiExpectedContinue ∷ !Bool
+ , seiReqBodyLength ∷ !(S.Maybe RequestBodyLength)
+
+ , seiResponse ∷ !Response
+ , seiWillChunkBody ∷ !Bool
+ , seiWillDiscardBody ∷ !Bool
+ , seiWillClose ∷ !Bool
+ , seiBodyToSend ∷ !Builder
+ }
+ deriving Typeable
+instance Interaction SemanticallyInvalidInteraction
+
+mkSemanticallyInvalidInteraction ∷ Config
+ → AugmentedRequest
+ → IO SemanticallyInvalidInteraction
+mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
+ = do date ← getCurrentDate
+ let res = setHeader "Server" cnfServerSoftware $
+ setHeader "Date" date $
+ setHeader "Content-Type" defaultPageContentType $
+ emptyResponse arInitialStatus
+ body = getDefaultPage config (Just arRequest) res
+ return SEI {
+ seiRequest = arRequest
+ , seiExpectedContinue = arExpectedContinue
+ , seiReqBodyLength = arReqBodyLength
+
+ , seiResponse = res
+ , seiWillChunkBody = arWillChunkBody
+ , seiWillDiscardBody = arWillDiscardBody
+ , seiWillClose = arWillClose
+ , seiBodyToSend = body
+ }
+
+-- |'NormalInteraction' is an 'Interaction' with a semantically
+-- correct 'Request'.
+data NormalInteraction
+ = NI {
+ niConfig ∷ !Config
+ , niRemoteAddr ∷ !SockAddr
+ , niRemoteCert ∷ !(Maybe X509)
+ , niRequest ∷ !Request
+ , niResourcePath ∷ ![Strict.ByteString]
+ , niExpectedContinue ∷ !Bool
+ , niReqBodyLength ∷ !(S.Maybe RequestBodyLength)
+
+ , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
+ , niReceivedBody ∷ !(TMVar Strict.ByteString)
+
+ , niResponse ∷ !(TVar Response)
+ , niSendContinue ∷ !(TMVar Bool)
+ , niWillChunkBody ∷ !Bool
+ , niWillDiscardBody ∷ !(TVar Bool)
+ , niWillClose ∷ !(TVar Bool)
+ , niResponseHasCType ∷ !(TVar Bool)
+ , niBodyToSend ∷ !(TMVar Builder)
+
+ , niState ∷ !(TVar InteractionState)
+ }
+ deriving Typeable
+instance Interaction NormalInteraction
- , itrExpectedContinue ∷ !(Maybe Bool)
- , itrReqBodyLength ∷ !(Maybe RequestBodyLength)
-
- , itrReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
- , itrReceivedBody ∷ !(TMVar Strict.ByteString)
-
- , itrSendContinue ∷ !(TMVar Bool)
- , itrResponse ∷ !(TVar Response)
- , itrWillChunkBody ∷ !(TVar Bool)
- , itrWillDiscardBody ∷ !(TVar Bool)
- , itrWillClose ∷ !(TVar Bool)
- , itrResponseHasCType ∷ !(TVar Bool)
- , itrBodyToSend ∷ !(TMVar Builder)
-
- , itrState ∷ !(TVar InteractionState)
- }
+data ReceiveBodyRequest
+ = ReceiveBody !Int -- ^ Maximum number of octets to receive.
+ | WasteAll
+ deriving (Show, Eq)
-- |The interaction state of Resource monad. 'ExaminingRequest' is the
-- initial state.
| Done
deriving (Show, Eq, Ord, Enum)
-type InteractionQueue = TVar (Seq Interaction)
-
-data ReceiveBodyRequest
- = ReceiveBody !Int -- ^ Maximum number of octets to receive.
- | WasteAll
- deriving (Show, Eq)
-
-newInteractionQueue ∷ IO InteractionQueue
-newInteractionQueue = newTVarIO S.empty
-
-newInteraction ∷ Config
- → PortNumber
- → SockAddr
- → Maybe X509
- → Either StatusCode Request
- → IO Interaction
-newInteraction conf@(Config {..}) port addr cert request
- = do let ar = preprocess cnfServerHost port request
- res = Response {
- resVersion = HttpVersion 1 1
- , resStatus = arInitialStatus ar
- , resHeaders = (∅)
- }
-
- receiveBodyReq ← newEmptyTMVarIO
+mkNormalInteraction ∷ Config
+ → SockAddr
+ → Maybe X509
+ → AugmentedRequest
+ → [Strict.ByteString]
+ → IO NormalInteraction
+mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
+ = do receiveBodyReq ← newEmptyTMVarIO
receivedBody ← newEmptyTMVarIO
+ response ← newTVarIO $ emptyResponse arInitialStatus
sendContinue ← newEmptyTMVarIO
- response ← newTVarIO res
- willChunkBody ← newTVarIO False
- willDiscardBody ← newTVarIO (arWillDiscardBody ar)
- willClose ← newTVarIO (arWillClose ar)
- bodyToSend ← newEmptyTMVarIO
+ willDiscardBody ← newTVarIO arWillDiscardBody
+ willClose ← newTVarIO arWillClose
responseHasCType ← newTVarIO False
+ bodyToSend ← newEmptyTMVarIO
state ← newTVarIO ExaminingRequest
- return Interaction {
- itrConfig = conf
- , itrLocalPort = port
- , itrRemoteAddr = addr
- , itrRemoteCert = cert
- , itrResourcePath = Nothing
- , itrRequest = arRequest ar
-
- , itrExpectedContinue = arExpectedContinue ar
- , itrReqBodyLength = arReqBodyLength ar
-
- , itrReceiveBodyReq = receiveBodyReq
- , itrReceivedBody = receivedBody
-
- , itrSendContinue = sendContinue
- , itrResponse = response
- , itrWillChunkBody = willChunkBody
- , itrWillDiscardBody = willDiscardBody
- , itrWillClose = willClose
- , itrResponseHasCType = responseHasCType
- , itrBodyToSend = bodyToSend
-
- , itrState = state
- }
-
-setResponseStatus ∷ Interaction → StatusCode → STM ()
-setResponseStatus (Interaction {..}) sc
- = do res ← readTVar itrResponse
+ return NI {
+ niConfig = config
+ , niRemoteAddr = remoteAddr
+ , niRemoteCert = remoteCert
+ , niRequest = arRequest
+ , niResourcePath = rsrcPath
+ , niExpectedContinue = arExpectedContinue
+ , niReqBodyLength = arReqBodyLength
+
+ , niReceiveBodyReq = receiveBodyReq
+ , niReceivedBody = receivedBody
+
+ , niResponse = response
+ , niSendContinue = sendContinue
+ , niWillChunkBody = arWillChunkBody
+ , niWillDiscardBody = willDiscardBody
+ , niWillClose = willClose
+ , niResponseHasCType = responseHasCType
+ , niBodyToSend = bodyToSend
+
+ , niState = state
+ }
+
+type InteractionQueue = TVar (Seq SomeInteraction)
+
+mkInteractionQueue ∷ IO InteractionQueue
+mkInteractionQueue = newTVarIO (∅)
+
+setResponseStatus ∷ NormalInteraction → StatusCode → STM ()
+setResponseStatus (NI {..}) sc
+ = do res ← readTVar niResponse
let res' = res {
resStatus = sc
}
- writeTVar itrResponse res'
+ writeTVar niResponse res'
+
+getCurrentDate ∷ IO Ascii
+getCurrentDate = HTTP.toAscii <$> getCurrentTime
#-}
module Network.HTTP.Lucu.Postprocess
( postprocess
- , completeUnconditionalHeaders
)
where
import Control.Applicative
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import qualified Data.Ascii as A
+import Data.Maybe
import Data.Monoid.Unicode
-import Data.Time
-import qualified Data.Time.HTTP as HTTP
import GHC.Conc (unsafeIOToSTM)
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Prelude.Unicode
-postprocess ∷ Interaction → STM ()
-postprocess itr@(Interaction {..})
- = do abortOnCertainConditions itr
+postprocess ∷ NormalInteraction → STM ()
+postprocess ni@(NI {..})
+ = do void $ tryPutTMVar niSendContinue False
+ abortOnCertainConditions ni
+ postprocessWithRequest ni
+ completeUnconditionalHeaders ni
- case itrRequest of
- Just req → postprocessWithRequest itr req
- Nothing → return ()
-
- updateResIO itr $ completeUnconditionalHeaders itrConfig
-
-abortOnCertainConditions ∷ Interaction → STM ()
-abortOnCertainConditions (Interaction {..})
- = readTVar itrResponse ≫= go
+abortOnCertainConditions ∷ NormalInteraction → STM ()
+abortOnCertainConditions (NI {..})
+ = readTVar niResponse ≫= go
where
go ∷ Response → STM ()
go res@(Response {..})
⊕ A.toAsciiBuilder " but no Location header."
abort' ∷ AsciiBuilder → STM ()
- abort' = abortSTM InternalServerError []
- ∘ Just
+ abort' = throwSTM
+ ∘ mkAbortion' InternalServerError
∘ A.toText
∘ A.fromAsciiBuilder
-postprocessWithRequest ∷ Interaction → Request → STM ()
-postprocessWithRequest itr@(Interaction {..}) (Request {..})
- = do willDiscardBody ← readTVar itrWillDiscardBody
+postprocessWithRequest ∷ NormalInteraction → STM ()
+postprocessWithRequest ni@(NI {..})
+ = do willDiscardBody ← readTVar niWillDiscardBody
canHaveBody ← if willDiscardBody then
return False
else
- resCanHaveBody <$> readTVar itrResponse
+ resCanHaveBody <$> readTVar niResponse
- updateRes itr
+ updateRes ni
$ deleteHeader "Content-Length"
∘ deleteHeader "Transfer-Encoding"
if canHaveBody then
- do when (reqVersion ≡ HttpVersion 1 1)
- $ do writeHeader itr "Transfer-Encoding" (Just "chunked")
- writeTVar itrWillChunkBody True
- writeDefaultPageIfNeeded itr
+ do when niWillChunkBody $
+ writeHeader ni "Transfer-Encoding" (Just "chunked")
+ writeDefaultPageIfNeeded ni
else
- do writeTVar itrWillDiscardBody True
+ do writeTVar niWillDiscardBody True
-- These headers make sense for HEAD requests even
-- when there won't be a response entity body.
- when (reqMethod ≢ HEAD)
- $ updateRes itr
+ when (reqMethod niRequest ≢ HEAD)
+ $ updateRes ni
$ deleteHeader "Content-Type"
∘ deleteHeader "Etag"
∘ deleteHeader "Last-Modified"
- hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection"
- willClose ← readTVar itrWillClose
+ hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
+ willClose ← readTVar niWillClose
when (hasConnClose ∧ (¬) willClose)
- $ writeTVar itrWillClose True
+ $ writeTVar niWillClose True
when ((¬) hasConnClose ∧ willClose)
- $ writeHeader itr "Connection" (Just "close")
+ $ writeHeader ni "Connection" (Just "close")
-writeDefaultPageIfNeeded ∷ Interaction → STM ()
-writeDefaultPageIfNeeded itr@(Interaction {..})
- = do resHasCType ← readTVar itrResponseHasCType
+writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
+writeDefaultPageIfNeeded ni@(NI {..})
+ = do resHasCType ← readTVar niResponseHasCType
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 page
-
-writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM ()
+ $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
+ writeHeader ni "Content-Encoding" Nothing
+ res ← readTVar niResponse
+ let body = getDefaultPage niConfig (Just niRequest) res
+ putTMVar niBodyToSend body
+
+completeUnconditionalHeaders ∷ NormalInteraction → STM ()
+completeUnconditionalHeaders ni@(NI {..})
+ = do srv ← readHeader ni "Server"
+ when (isNothing srv) $
+ writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
+
+ date ← readHeader ni "Date"
+ when (isNothing date) $
+ do date' ← unsafeIOToSTM getCurrentDate
+ writeHeader ni "Date" $ Just date'
+
+writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()
{-# INLINE writeHeader #-}
-writeHeader itr k v
+writeHeader ni k v
= case v of
- Just v' → updateRes itr $ setHeader k v'
- Nothing → updateRes itr $ deleteHeader k
+ Just v' → updateRes ni $ setHeader k v'
+ Nothing → updateRes ni $ deleteHeader k
+
+readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
+{-# INLINE readHeader #-}
+readHeader (NI {..}) k
+ = getHeader k <$> readTVar niResponse
-readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii)
+readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
{-# INLINE readCIHeader #-}
-readCIHeader (Interaction {..}) k
- = getCIHeader k <$> readTVar itrResponse
+readCIHeader (NI {..}) k
+ = getCIHeader k <$> readTVar niResponse
-updateRes ∷ Interaction → (Response → Response) → STM ()
+updateRes ∷ NormalInteraction → (Response → Response) → STM ()
{-# INLINE updateRes #-}
-updateRes (Interaction {..}) f
- = do old ← readTVar itrResponse
- writeTVar itrResponse (f old)
-
-updateResIO ∷ Interaction → (Response → IO Response) → STM ()
-{-# INLINE updateResIO #-}
-updateResIO (Interaction {..}) f
- = do old ← readTVar itrResponse
- new ← unsafeIOToSTM $ f old
- writeTVar itrResponse new
-
--- FIXME: Narrow the use of IO monad!
-completeUnconditionalHeaders ∷ Config → Response → IO Response
-completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
- where
- compServer res'
- = case getHeader "Server" res' of
- Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
- Just _ → return res'
-
- compDate res'
- = case getHeader "Date" res' of
- Nothing → do date ← getCurrentDate
- return $ setHeader "Date" date res'
- Just _ → return res'
-
-getCurrentDate ∷ IO Ascii
-getCurrentDate = HTTP.toAscii <$> getCurrentTime
+updateRes (NI {..}) f
+ = do old ← readTVar niResponse
+ writeTVar niResponse $ f old
where
import Control.Applicative
import Control.Monad
-import Control.Monad.State
+import Control.Monad.State.Strict
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import qualified Data.ByteString.Char8 as C8
import Data.Maybe
+import qualified Data.Strict.Maybe as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
data AugmentedRequest
= AugmentedRequest {
- arRequest ∷ !(Maybe Request)
+ arRequest ∷ !Request
, arInitialStatus ∷ !StatusCode
- , arWillClose ∷ !Bool
+ , arWillChunkBody ∷ !Bool
, arWillDiscardBody ∷ !Bool
- , arExpectedContinue ∷ !(Maybe Bool)
- , arReqBodyLength ∷ !(Maybe RequestBodyLength)
+ , arWillClose ∷ !Bool
+ , arExpectedContinue ∷ !Bool
+ , arReqBodyLength ∷ !(S.Maybe RequestBodyLength)
}
data RequestBodyLength
| Chunked
deriving (Eq, Show)
-preprocess ∷ Text
- → PortNumber
- → Either StatusCode Request
- → AugmentedRequest
-preprocess localHost localPort request
- = case request of
- Right req
- → preprocess' localHost localPort req
- Left sc
- → unparsable sc
-
-unparsable ∷ StatusCode → AugmentedRequest
-unparsable sc
- = AugmentedRequest {
- arRequest = Nothing
- , arInitialStatus = sc
- , arWillClose = True
- , arWillDiscardBody = False
- , arExpectedContinue = Nothing
- , arReqBodyLength = Nothing
- }
-
-preprocess' ∷ Text → PortNumber → Request → AugmentedRequest
-preprocess' localHost localPort req@(Request {..})
+preprocess ∷ Text → PortNumber → Request → AugmentedRequest
+preprocess localHost localPort req@(Request {..})
= execState go initialAR
where
initialAR ∷ AugmentedRequest
initialAR = AugmentedRequest {
- arRequest = Just req
+ arRequest = req
, arInitialStatus = Ok
- , arWillClose = False
+ , arWillChunkBody = False
, arWillDiscardBody = False
- , arExpectedContinue = Just False
- , arReqBodyLength = Nothing
+ , arWillClose = False
+ , arExpectedContinue = False
+ , arReqBodyLength = S.Nothing
}
-
go ∷ State AugmentedRequest ()
go = do examineHttpVersion
examineMethod
setRequest ∷ Request → State AugmentedRequest ()
setRequest req
- = modify $ \ar → ar { arRequest = Just req }
+ = modify $ \ar → ar { arRequest = req }
setStatus ∷ StatusCode → State AugmentedRequest ()
setStatus sc
setWillClose b
= modify $ \ar → ar { arWillClose = b }
-setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
+setBodyLength ∷ S.Maybe RequestBodyLength → State AugmentedRequest ()
setBodyLength len
= modify $ \ar → ar { arReqBodyLength = len }
examineHttpVersion ∷ State AugmentedRequest ()
examineHttpVersion
- = do req ← gets (fromJust ∘ arRequest)
+ = do req ← gets arRequest
case reqVersion req of
-- HTTP/1.0 requests can't Keep-Alive.
HttpVersion 1 0
→ setWillClose True
HttpVersion 1 1
- → return ()
+ → modify $ \ar → ar { arWillChunkBody = True }
_ → do setStatus HttpVersionNotSupported
setWillClose True
examineMethod ∷ State AugmentedRequest ()
examineMethod
- = do req ← gets (fromJust ∘ arRequest)
+ = do req ← gets arRequest
case reqMethod req of
GET → return ()
HEAD → modify $ \ar → ar { arWillDiscardBody = True }
examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
examineAuthority localHost localPort
- = do req ← gets (fromJust ∘ arRequest)
+ = do req ← gets arRequest
when (isNothing $ uriAuthority $ reqURI req) $
case reqVersion req of
-- HTTP/1.0 requests have no Host header so complete it
examineHeaders ∷ State AugmentedRequest ()
examineHeaders
- = do req ← gets (fromJust ∘ arRequest)
+ = do req ← gets arRequest
case getCIHeader "Expect" req of
Nothing → return ()
Just v
| v ≡ "100-continue"
- → modify $ \ar → ar { arExpectedContinue = Just True }
+ → modify $ \ar → ar { arExpectedContinue = True }
| otherwise
→ setStatus ExpectationFailed
| v ≡ "identity"
→ return ()
| v ≡ "chunked"
- → setBodyLength $ Just Chunked
+ → setBodyLength $ S.Just Chunked
| otherwise
→ setStatus NotImplemented
Just value → case C8.readInt value of
Just (len, garbage)
| C8.null garbage ∧ len ≥ 0
- → setBodyLength $ Just $ Fixed len
+ → setBodyLength $ S.Just $ Fixed len
_ → setStatus BadRequest
case getCIHeader "Connection" req of
examineBodyLength ∷ State AugmentedRequest ()
examineBodyLength
- = do req ← gets (fromJust ∘ arRequest)
+ = do req ← gets arRequest
len ← gets arReqBodyLength
if reqMustHaveBody req then
-- POST and PUT requests must have an entity body.
- when (isNothing len)
+ when (S.isNothing len)
$ setStatus LengthRequired
else
-- Other requests must NOT have an entity body.
- when (isJust len)
+ when (S.isJust len)
$ setStatus BadRequest
, ScopedTypeVariables
, UnicodeSyntax
#-}
--- |Provide facilities to encode/decode MIME parameter values in
+-- |Provide functionalities to encode/decode MIME parameter values in
-- character sets other than US-ASCII. See:
-- http://www.faqs.org/rfcs/rfc2231.html
module Network.HTTP.Lucu.RFC2231
{-# LANGUAGE
DoAndIfThenElse
+ , OverloadedStrings
, RecordWildCards
, ScopedTypeVariables
, UnicodeSyntax
( requestReader
)
where
-import Control.Applicative
+import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception hiding (block)
import Control.Monad
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
-import Data.Maybe
+import qualified Data.Strict.Maybe as S
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence.Unicode hiding ((∅))
+import qualified Data.Text as T
+import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Resource.Tree
import Network.Socket
-import Network.URI
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
-- ResponseWriter に通知する。
case LP.parse requestP input of
LP.Done input' req → acceptParsableRequest ctx req input'
- LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest
+ LP.Fail _ _ _ → acceptNonparsableRequest ctx
-acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
-acceptNonparsableRequest ctx@(Context {..}) sc
- = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
- atomically $
- do writeTVar (itrState itr) Done
- postprocess itr
- enqueue ctx itr
+acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
+acceptNonparsableRequest ctx@(Context {..})
+ = do syi ← mkSyntacticallyInvalidInteraction cConfig
+ enqueue ctx syi
acceptParsableRequest ∷ HandleLike h
⇒ Context h
→ Lazy.ByteString
→ IO ()
acceptParsableRequest ctx@(Context {..}) req input
- = do cert ← hGetPeerCert cHandle
- itr ← newInteraction cConfig cPort cAddr cert (Right req)
- join $ atomically
- $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
- if isErr then
- acceptSemanticallyInvalidRequest ctx itr input
- else
- return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
+ = do let ar = preprocess (cnfServerHost cConfig) cPort req
+ if isError $ arInitialStatus ar then
+ acceptSemanticallyInvalidRequest ctx ar input
+ else
+ do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
+ case rsrc of
+ Nothing
+ → do let ar' = ar { arInitialStatus = NotFound }
+ acceptSemanticallyInvalidRequest ctx ar' input
+ Just (path, def)
+ → acceptRequestForResource ctx ar input path def
acceptSemanticallyInvalidRequest ∷ HandleLike h
⇒ Context h
- → Interaction
+ → AugmentedRequest
→ Lazy.ByteString
- → STM (IO ())
-acceptSemanticallyInvalidRequest ctx itr input
- = do writeTVar (itrState itr) Done
- postprocess itr
- enqueue ctx itr
- return $ acceptRequest ctx input
-
-acceptSemanticallyValidRequest ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → URI
- → Lazy.ByteString
- → IO ()
-acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
- = do rsrcM ← findResource cResTree cFallbacks uri
- case rsrcM of
- Nothing
- → acceptRequestForNonexistentResource ctx itr input
- Just (rsrcPath, rsrcDef)
- → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
-
-acceptRequestForNonexistentResource ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Lazy.ByteString
- → IO ()
-acceptRequestForNonexistentResource ctx itr input
- = do atomically $
- do setResponseStatus itr NotFound
- writeTVar (itrState itr) Done
- postprocess itr
- enqueue ctx itr
+ → IO ()
+acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
+ = do sei ← mkSemanticallyInvalidInteraction cConfig ar
+ enqueue ctx sei
acceptRequest ctx input
-acceptRequestForExistentResource ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Lazy.ByteString
- → [Strict.ByteString]
- → ResourceDef
- → IO ()
-acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
- = do let itr = oldItr { itrResourcePath = Just rsrcPath }
- atomically $ enqueue ctx itr
- do _ ← spawnResource rsrcDef itr
- if reqMustHaveBody $ fromJust $ itrRequest itr then
- waitForReceiveBodyReq ctx itr input
- else
- acceptRequest ctx input
+acceptRequestForResource ∷ HandleLike h
+ ⇒ Context h
+ → AugmentedRequest
+ → Lazy.ByteString
+ → [Strict.ByteString]
+ → ResourceDef
+ → IO ()
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+ = do cert ← hGetPeerCert cHandle
+ ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
+ tid ← spawnResource rsrcDef ni
+ if reqMustHaveBody arRequest then
+ waitForReceiveBodyReq ctx ni tid input
+ else
+ acceptRequest ctx input
waitForReceiveBodyReq ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
+ → ThreadId
→ Lazy.ByteString
→ IO ()
-waitForReceiveBodyReq ctx itr input
- = case fromJust $ itrReqBodyLength itr of
+waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
+ = case S.fromJust niReqBodyLength of
Chunked
- → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input
+ → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
Fixed len
- → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len
+ → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
-- Toooooo long name for a function...
waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
+ → ThreadId
→ Lazy.ByteString
→ IO ()
-waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input
+waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
= join $
atomically $
- do req ← takeTMVar itrReceiveBodyReq
+ do req ← takeTMVar niReceiveBodyReq
case req of
ReceiveBody wanted
- → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
- return $ readCurrentChunk ctx itr input Initial wanted
+ → do putTMVar niSendContinue niExpectedContinue
+ return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
WasteAll
- → do putTMVar itrSendContinue False
- return $ wasteAllChunks ctx itr input Initial
+ → do putTMVar niSendContinue False
+ return $ wasteAllChunks ctx rsrcTid input Initial
waitForReceiveChunkedBodyReq ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
+ → ThreadId
→ Lazy.ByteString
→ ChunkReceivingState
→ IO ()
-waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st
- = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
+ = do req ← atomically $ takeTMVar niReceiveBodyReq
case req of
ReceiveBody wanted
- → readCurrentChunk ctx itr input st wanted
+ → readCurrentChunk ctx ni rsrcTid wanted input st
WasteAll
- → wasteAllChunks ctx itr input st
+ → wasteAllChunks ctx rsrcTid input st
wasteAllChunks ∷ HandleLike h
⇒ Context h
- → Interaction
+ → ThreadId
→ Lazy.ByteString
→ ChunkReceivingState
→ IO ()
-wasteAllChunks ctx itr = go
+wasteAllChunks ctx rsrcTid = go
where
go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
go input Initial
LP.Done input' chunkLen
| chunkLen ≡ 0 → gotFinalChunk input'
| otherwise → gotChunk input' chunkLen
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ LP.Fail _ _ msg
+ → chunkWasMalformed rsrcTid
+ $ "wasteAllChunks: chunkHeaderP: " ⧺ msg
go input (InChunk chunkLen)
= gotChunk input chunkLen
case LP.parse chunkFooterP input' of
LP.Done input'' _
→ go input'' Initial
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ LP.Fail _ _ msg
+ → chunkWasMalformed rsrcTid
+ $ "wasteAllChunks: chunkFooterP: " ⧺ msg
gotFinalChunk ∷ Lazy.ByteString → IO ()
gotFinalChunk input
- = case LP.parse chunkFooterP input of
+ = case LP.parse chunkTrailerP input of
LP.Done input' _
- → case LP.parse chunkTrailerP input' of
- LP.Done input'' _
- → acceptRequest ctx input''
- LP.Fail _ _ _
- → chunkWasMalformed itr
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ → acceptRequest ctx input'
+ LP.Fail _ _ msg
+ → chunkWasMalformed rsrcTid
+ $ "wasteAllChunks: chunkTrailerP: " ⧺ msg
readCurrentChunk ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
+ → ThreadId
+ → Int
→ Lazy.ByteString
→ ChunkReceivingState
- → Int
→ IO ()
-readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
- = go input0 st0
+readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
where
go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
go input Initial
→ gotFinalChunk input'
| otherwise
→ gotChunk input' chunkLen
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ LP.Fail _ _ msg
+ → chunkWasMalformed rsrcTid
+ $ "readCurrentChunk: chunkHeaderP: " ⧺ msg
go input (InChunk chunkLen)
= gotChunk input chunkLen
block' = Strict.concat $ Lazy.toChunks block
actualReadBytes = Strict.length block'
chunkLen' = chunkLen - actualReadBytes
- atomically $ putTMVar itrReceivedBody block'
+ atomically $ putTMVar niReceivedBody block'
if chunkLen' ≡ 0 then
case LP.parse chunkFooterP input' of
LP.Done input'' _
- → waitForReceiveChunkedBodyReq ctx itr input'' Initial
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
+ LP.Fail _ _ msg
+ → chunkWasMalformed rsrcTid
+ $ "readCurrentChunk: chunkFooterP: " ⧺ msg
else
- waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen'
+ waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
gotFinalChunk ∷ Lazy.ByteString → IO ()
gotFinalChunk input
- = do atomically $ putTMVar itrReceivedBody (∅)
- case LP.parse chunkFooterP input of
+ = do atomically $ putTMVar niReceivedBody (∅)
+ case LP.parse chunkTrailerP input of
LP.Done input' _
- → case LP.parse chunkTrailerP input' of
- LP.Done input'' _
- → acceptRequest ctx input''
- LP.Fail _ _ _
- → chunkWasMalformed itr
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ → acceptRequest ctx input'
+ LP.Fail _ _ msg
+ → chunkWasMalformed rsrcTid
+ $ "readCurrentChunk: chunkTrailerP: " ⧺ msg
-chunkWasMalformed ∷ Interaction → IO ()
-chunkWasMalformed itr
- -- FIXME: This is a totally wrong way to abort!
- = atomically $
- do setResponseStatus itr BadRequest
- writeTVar (itrWillClose itr) True
- writeTVar (itrState itr) Done
- postprocess itr
+chunkWasMalformed ∷ ThreadId → String → IO ()
+chunkWasMalformed tid msg
+ = let abo = mkAbortion BadRequest [("Connection", "close")]
+ $ Just
+ $ "chunkWasMalformed: " ⊕ T.pack msg
+ in
+ throwTo tid abo
waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ Lazy.ByteString
→ Int
→ IO ()
-waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen
+waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
= join $
atomically $
- do req ← takeTMVar itrReceiveBodyReq
+ do req ← takeTMVar niReceiveBodyReq
case req of
ReceiveBody wanted
- → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
- return $ readNonChunkedRequestBody ctx itr input bodyLen wanted
+ → do putTMVar niSendContinue niExpectedContinue
+ return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
WasteAll
- → do putTMVar itrSendContinue False
+ → do putTMVar niSendContinue False
return $ wasteNonChunkedRequestBody ctx input bodyLen
waitForReceiveNonChunkedBodyReq ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ Lazy.ByteString
→ Int
→ IO ()
-waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen
- = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
+ = do req ← atomically $ takeTMVar niReceiveBodyReq
case req of
ReceiveBody wanted
- → readNonChunkedRequestBody ctx itr input bodyLen wanted
+ → readNonChunkedRequestBody ctx ni input bodyLen wanted
WasteAll
→ wasteNonChunkedRequestBody ctx input bodyLen
readNonChunkedRequestBody ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ Lazy.ByteString
→ Int
→ Int
→ IO ()
-readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
+readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
| bodyLen ≡ 0 = gotEndOfRequest
| otherwise = gotBody
where
block' = Strict.concat $ Lazy.toChunks block
actualReadBytes = Strict.length block'
bodyLen' = bodyLen - actualReadBytes
- atomically $ putTMVar itrReceivedBody block'
- waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen'
+ atomically $ putTMVar niReceivedBody block'
+ waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
gotEndOfRequest ∷ IO ()
gotEndOfRequest
- = do atomically $ putTMVar itrReceivedBody (∅)
+ = do atomically $ putTMVar niReceivedBody (∅)
acceptRequest ctx input
-enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
+enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
+{-# INLINEABLE enqueue #-}
enqueue (Context {..}) itr
- = do queue ← readTVar cQueue
- writeTVar cQueue (itr ⊲ queue)
+ = atomically $
+ do queue ← readTVar cQueue
+ writeTVar cQueue (toInteraction itr ⊲ queue)
Just accept
→ case P.parseOnly p (A.toByteString accept) of
Right xs → return xs
- Left _ → abort BadRequest []
- (Just $ "Unparsable Accept: " ⊕ A.toText accept)
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Accept: " ⊕ A.toText accept
where
p = do xs ← mimeTypeListP
P.endOfInput
case ver of
HttpVersion 1 0 → return [("identity", Nothing)]
HttpVersion 1 1 → return [("*" , Nothing)]
- _ → abort InternalServerError []
- (Just "getAcceptEncoding: unknown HTTP version")
+ _ → abort $ mkAbortion' InternalServerError
+ "getAcceptEncoding: unknown HTTP version"
Just ae
→ if ae ≡ "" then
-- identity のみが許される。
else
case P.parseOnly p (A.toByteString ae) of
Right xs → return $ map toTuple $ reverse $ sort xs
- Left _ → abort BadRequest []
- (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
where
p = do xs ← acceptEncodingListP
P.endOfInput
Just cType
→ case P.parseOnly p (A.toByteString cType) of
Right t → return $ Just t
- Left _ → abort BadRequest []
- (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Content-Type: " ⊕ A.toText cType
where
p = do t ← mimeTypeP
P.endOfInput
when (method ≡ GET ∨ method ≡ HEAD)
$ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
when (method ≡ POST)
- $ abort InternalServerError []
- (Just "foundEntity: this is a POST request.")
+ $ abort
+ $ mkAbortion' InternalServerError
+ "foundEntity: this is a POST request."
foundETag tag
driftTo ReceivingBody
$ A.fromAsciiBuilder
$ printETag tag
when (method ≡ POST)
- $ abort InternalServerError []
- $ Just "Illegal computation of foundETag for POST request."
+ $ abort
+ $ mkAbortion' InternalServerError
+ "Illegal computation of foundETag for POST request."
-- If-Match があればそれを見る。
ifMatch ← getHeader "If-Match"
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
→ when ((¬) (any (≡ tag) tags))
- $ abort PreconditionFailed []
- $ Just
+ $ abort
+ $ mkAbortion' PreconditionFailed
$ "The entity tag doesn't match: " ⊕ A.toText value
Left _
- → abort BadRequest []
- $ Just
- $ "Unparsable If-Match: " ⊕ A.toText value
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-Match: " ⊕ A.toText value
let statusForNoneMatch
= if method ≡ GET ∨ method ≡ HEAD then
case ifNoneMatch of
Nothing → return ()
Just value → if value ≡ "*" then
- abort statusForNoneMatch [] (Just "The entity tag matches: *")
+ abort $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: *"
else
case P.parseOnly p (A.toByteString value) of
Right tags
→ when (any (≡ tag) tags)
- $ abort statusForNoneMatch []
- $ Just
+ $ abort
+ $ mkAbortion' statusForNoneMatch
$ "The entity tag matches: " ⊕ A.toText value
Left _
- → abort BadRequest []
- $ Just
- $ "Unparsable If-None-Match: " ⊕ A.toText value
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-None-Match: " ⊕ A.toText value
driftTo ReceivingBody
where
when (method ≡ GET ∨ method ≡ HEAD)
$ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
when (method ≡ POST)
- $ abort InternalServerError []
- (Just "Illegal computation of foundTimeStamp for POST request.")
+ $ abort
+ $ mkAbortion' InternalServerError
+ "Illegal computation of foundTimeStamp for POST request."
let statusForIfModSince
= if method ≡ GET ∨ method ≡ HEAD then
Just str → case HTTP.fromAscii str of
Right lastTime
→ when (timeStamp ≤ lastTime)
- $ abort statusForIfModSince []
- (Just $ "The entity has not been modified since " ⊕ A.toText str)
+ $ abort
+ $ mkAbortion' statusForIfModSince
+ $ "The entity has not been modified since " ⊕ A.toText str
Left _
→ return () -- 不正な時刻は無視
Nothing → return ()
Just str → case HTTP.fromAscii str of
Right lastTime
→ when (timeStamp > lastTime)
- $ abort PreconditionFailed []
- (Just $ "The entity has not been modified since " ⊕ A.toText str)
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity has not been modified since " ⊕ A.toText str
Left _
→ return () -- 不正な時刻は無視
Nothing → return ()
method ← getMethod
when (method ≢ PUT)
- $ abort NotFound [] msgM
+ $ abort
+ $ mkAbortion NotFound [] msgM
-- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
-- If-Match: 條件も滿たさない。
ifMatch ← getHeader "If-Match"
when (ifMatch ≢ Nothing)
- $ abort PreconditionFailed [] msgM
+ $ abort
+ $ mkAbortion PreconditionFailed [] msgM
driftTo ReceivingBody
getChunks' limit = go limit (∅)
where
go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
- go 0 _ = abort RequestEntityTooLarge []
- (Just $ "Request body must be smaller than "
- ⊕ T.pack (show limit) ⊕ " bytes.")
- go n xs = do let n' = min n Lazy.defaultChunkSize
+ go 0 _ = do chunk ← getChunk 1
+ if Strict.null chunk then
+ return (∅)
+ else
+ abort $ mkAbortion' RequestEntityTooLarge
+ $ "Request body must be smaller than "
+ ⊕ T.pack (show limit)
+ ⊕ " bytes."
+ go n xs = do let n' = min n Lazy.defaultChunkSize
chunk ← getChunk n'
if Strict.null chunk then
-- Got EOF
= do cTypeM ← getContentType
case cTypeM of
Nothing
- → abort BadRequest [] (Just "Missing Content-Type")
+ → abort $ mkAbortion' BadRequest "Missing Content-Type"
Just (MIMEType "application" "x-www-form-urlencoded" _)
→ readWWWFormURLEncoded
Just (MIMEType "multipart" "form-data" params)
→ readMultipartFormData params
Just cType
- → abort UnsupportedMediaType []
- $ Just
- $ A.toText
- $ A.fromAsciiBuilder
- $ A.toAsciiBuilder "Unsupported media type: "
- ⊕ printMIMEType cType
+ → abort $ mkAbortion' UnsupportedMediaType
+ $ A.toText
+ $ A.fromAsciiBuilder
+ $ A.toAsciiBuilder "Unsupported media type: "
+ ⊕ printMIMEType cType
where
readWWWFormURLEncoded
= (map toPairWithFormData ∘ parseWWWFormURLEncoded)
bsToAscii bs
= case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
Just a → return a
- Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
+ Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
readMultipartFormData params
- = do case M.lookup "boundary" params of
- Nothing
- → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
- Just boundary
- → do src ← getChunks limit
- b ← case A.fromText boundary of
- Just b → return b
- Nothing → abort BadRequest []
- (Just $ "Malformed boundary: " ⊕ boundary)
- case LP.parse (p b) src of
- LP.Done _ formList
- → return formList
- _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
+ = case M.lookup "boundary" params of
+ Nothing
+ → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
+ Just boundary
+ → do src ← getChunks limit
+ b ← case A.fromText boundary of
+ Just b → return b
+ Nothing → abort $ mkAbortion' BadRequest
+ $ "Malformed boundary: " ⊕ boundary
+ case LP.parse (p b) src of
+ LP.Done _ formList
+ → return formList
+ _ → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data"
where
p b = do xs ← multipartFormP b
P.endOfInput
redirect ∷ StatusCode → URI → Resource ()
redirect code uri
= do when (code ≡ NotModified ∨ not (isRedirection code))
- $ abort InternalServerError []
- $ Just
+ $ abort
+ $ mkAbortion' InternalServerError
$ A.toText
$ A.fromAsciiBuilder
$ A.toAsciiBuilder "Attempted to redirect with status "
setLocation uri
= case A.fromChars uriStr of
Just a → setHeader "Location" a
- Nothing → abort InternalServerError []
- (Just $ "Malformed URI: " ⊕ T.pack uriStr)
+ Nothing → abort $ mkAbortion' InternalServerError
+ $ "Malformed URI: " ⊕ T.pack uriStr
where
uriStr = uriToString id uri ""
tr ← case ver of
HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
HttpVersion 1 1 → return toAB
- _ → abort InternalServerError []
- (Just "setContentEncoding: Unknown HTTP version")
+ _ → abort $ mkAbortion' InternalServerError
+ "setContentEncoding: Unknown HTTP version"
setHeader "Content-Encoding"
(A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
where
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
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
-- 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
, 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
| otherwise = forkIO
run ∷ IO ()
- run = flip runResource itr $
+ run = flip runResource ni $
do req ← getRequest
fromMaybe notAllowed $ rsrc req
driftTo Done
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
, " ", 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:
--
-- '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
-- > , ...
-- > }
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
| 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
-- 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
-- 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
-- '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 ()
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
driftFromTo ∷ InteractionState → InteractionState → STM ()
driftFromTo ReceivingBody _
- = putTMVar itrReceiveBodyReq WasteAll
+ = putTMVar niReceiveBodyReq WasteAll
driftFromTo DecidingHeader _
- = postprocess itr
+ = postprocess ni
driftFromTo _ _
= return ()
, printStatusCode
, Response(..)
+ , emptyResponse
, resCanHaveBody
, printResponse
} deriving (Show, Eq)
instance HasHeaders Response where
- {-# INLINE getHeaders #-}
- getHeaders = resHeaders
- {-# INLINE setHeaders #-}
+ getHeaders = resHeaders
setHeaders res hdr = res { resHeaders = hdr }
+-- |Returns an HTTP\/1.1 'Response' with no header fields.
+emptyResponse ∷ StatusCode → Response
+emptyResponse sc
+ = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = sc
+ , resHeaders = (∅)
+ }
+
-- |Returns 'True' iff a given 'Response' allows the existence of
-- response entity body.
resCanHaveBody ∷ Response → Bool
)
where
import qualified Blaze.ByteString.Builder.HTTP as BB
+import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
case S.viewr queue of
EmptyR → retry
queue' :> itr → do writeTVar cQueue queue'
- return $ writeContinueIfNeeded ctx itr
+ return $ writeSomething ctx itr
+
+writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
+writeSomething ctx itr
+ = let writer = writeResponseForNI ctx <$> fromInteraction itr <|>
+ writeResponseForSEI ctx <$> fromInteraction itr <|>
+ writeResponseForSYI ctx <$> fromInteraction itr
+ in
+ case writer of
+ Just f → f
+ Nothing → fail "Internal error: unknown interaction type"
+
+writeResponseForNI ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → IO ()
+writeResponseForNI = writeContinueIfNeeded
writeContinueIfNeeded ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..})
- = do isNeeded ← atomically $ readTMVar itrSendContinue
+writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
+ = do isNeeded ← atomically $ readTMVar niSendContinue
when isNeeded
$ do let cont = Response {
resVersion = HttpVersion 1 1
, resStatus = Continue
, resHeaders = (∅)
}
- cont' ← completeUnconditionalHeaders cConfig cont
- hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
+ hPutBuilder cHandle $ A.toBuilder $ printResponse cont
hFlush cHandle
- writeHeader ctx itr
+ writeHeader ctx ni
writeHeader ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeHeader ctx@(Context {..}) itr@(Interaction {..})
+writeHeader ctx@(Context {..}) ni@(NI {..})
= do res ← atomically $
- do state ← readTVar itrState
+ do state ← readTVar niState
if state ≥ SendingBody then
- readTVar itrResponse
+ readTVar niResponse
else
retry -- Too early to write header fields.
hPutBuilder cHandle $ A.toBuilder $ printResponse res
hFlush cHandle
- writeBodyIfNeeded ctx itr
+ writeBodyIfNeeded ctx ni
writeBodyIfNeeded ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeBodyIfNeeded ctx itr@(Interaction {..})
+writeBodyIfNeeded ctx ni@(NI {..})
= join $
atomically $
- do willDiscardBody ← readTVar itrWillDiscardBody
+ do willDiscardBody ← readTVar niWillDiscardBody
if willDiscardBody then
- return $ discardBody ctx itr
+ return $ discardBody ctx ni
else
- do willChunkBody ← readTVar itrWillChunkBody
- if willChunkBody then
- return $ writeChunkedBody ctx itr
- else
- return $ writeNonChunkedBody ctx itr
+ if niWillChunkBody then
+ return $ writeChunkedBody ctx ni
+ else
+ return $ writeNonChunkedBody ctx ni
discardBody ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-discardBody ctx itr@(Interaction {..})
+discardBody ctx ni@(NI {..})
= join $
atomically $
- do chunk ← tryTakeTMVar itrBodyToSend
+ do chunk ← tryTakeTMVar niBodyToSend
case chunk of
- Just _ → return $ discardBody ctx itr
- Nothing → do state ← readTVar itrState
+ Just _ → return $ discardBody ctx ni
+ Nothing → do state ← readTVar niState
if state ≡ Done then
- return $ finalize ctx itr
+ return $ finalize ctx ni
else
retry
writeChunkedBody ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+writeChunkedBody ctx@(Context {..}) ni@(NI {..})
= join $
atomically $
- do chunk ← tryTakeTMVar itrBodyToSend
+ do chunk ← tryTakeTMVar niBodyToSend
case chunk of
Just b → return $
do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
hFlush cHandle
- writeChunkedBody ctx itr
- Nothing → do state ← readTVar itrState
+ writeChunkedBody ctx ni
+ Nothing → do state ← readTVar niState
if state ≡ Done then
- return $ finalize ctx itr
+ return $
+ do hPutBuilder cHandle BB.chunkedTransferTerminator
+ hFlush cHandle
+ finalize ctx ni
else
retry
writeNonChunkedBody ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
= join $
atomically $
- do chunk ← tryTakeTMVar itrBodyToSend
+ do chunk ← tryTakeTMVar niBodyToSend
case chunk of
Just b → return $
do hPutBuilder cHandle b
hFlush cHandle
- writeNonChunkedBody ctx itr
- Nothing → do state ← readTVar itrState
+ writeNonChunkedBody ctx ni
+ Nothing → do state ← readTVar niState
if state ≡ Done then
- return $ finalize ctx itr
+ return $ finalize ctx ni
else
retry
-finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finalize ctx@(Context {..}) (Interaction {..})
+finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
+finalize ctx@(Context {..}) (NI {..})
= join $
atomically $
- do sentContinue ← takeTMVar itrSendContinue
- willDiscardBody ← readTVar itrWillDiscardBody
- willChunkBody ← readTVar itrWillChunkBody
- willClose ← readTVar itrWillClose
- queue ← readTVar cQueue
- case S.viewr queue of
- queue' :> _
- → writeTVar cQueue queue'
- EmptyR
- → fail "finalize: cQueue is empty, which should never happen."
+ do willClose ← readTVar niWillClose
+ sentContinue ← takeTMVar niSendContinue
return $
- do when (((¬) willDiscardBody) ∧ willChunkBody)
- $ do hPutBuilder cHandle BB.chunkedTransferTerminator
- hFlush cHandle
- if willClose ∨ needToClose sentContinue then
- -- The RequestReader is probably blocking on
- -- hWaitForInput so we have to kill it before
- -- closing the socket.
- -- THINKME: Couldn't that somehow be avoided?
- do killThread cReader
- hClose cHandle
- else
- awaitSomethingToWrite ctx
+ if needToClose willClose sentContinue then
+ -- The RequestReader is probably blocking on
+ -- hWaitForInput so we have to kill it before closing
+ -- the socket. THINKME: Couldn't that somehow be
+ -- avoided?
+ do killThread cReader
+ hClose cHandle
+ else
+ awaitSomethingToWrite ctx
where
- needToClose ∷ Bool → Bool
- needToClose sentContinue
+ needToClose ∷ Bool → Bool → Bool
+ needToClose willClose sentContinue
+ -- Explicitly instructed to close the connection.
+ | willClose = True
-- We've sent both "HTTP/1.1 100 Continue" and a final
-- response, so nothing prevents our connection from keeping
-- alive.
-- (rejected) request body OR start a completely new request
-- in this situation. So the only possible thing to do is to
-- brutally shutdown the connection.
- | itrExpectedContinue ≡ Just True = True
+ | niExpectedContinue = True
-- The client didn't expect 100-continue so we haven't sent
-- one. No need to do anything special.
| otherwise = False
+
+writeResponseForSEI ∷ HandleLike h
+ ⇒ Context h
+ → SemanticallyInvalidInteraction
+ → IO ()
+writeResponseForSEI ctx@(Context {..}) (SEI {..})
+ = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
+ unless seiWillDiscardBody $
+ if seiWillChunkBody then
+ do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
+ hPutBuilder cHandle BB.chunkedTransferTerminator
+ else
+ hPutBuilder cHandle seiBodyToSend
+ hFlush cHandle
+ if seiWillClose ∨ seiExpectedContinue then
+ do killThread cReader
+ hClose cHandle
+ else
+ awaitSomethingToWrite ctx
+
+writeResponseForSYI ∷ HandleLike h
+ ⇒ Context h
+ → SyntacticallyInvalidInteraction
+ → IO ()
+writeResponseForSYI (Context {..}) (SYI {..})
+ = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
+ hPutBuilder cHandle syiBodyToSend
+ hFlush cHandle
+ killThread cReader
+ hClose cHandle
readable ← liftIO $ fileAccess path True False False
unless readable
- $ abort Forbidden [] Nothing
+ $ abort
+ $ mkAbortion Forbidden [] Nothing
stat ← liftIO $ getFileStatus path
when (isDirectory stat)
- $ abort Forbidden [] Nothing
+ $ abort
+ $ mkAbortion Forbidden [] Nothing
tag ← liftIO $ generateETagFromFile path
let lastMod = posixSecondsToUTCTime
import Control.Applicative
import Control.Monad.Unicode
import qualified Data.ByteString.Lazy.Char8 as Lazy
-import Data.Monoid.Unicode
import Network.HTTP.Lucu
main ∷ IO ()
do putStrLn "Access http://localhost:9999/ with your browser."
runHttpd config resources fallbacks
-
helloWorld ∷ ResourceDef
helloWorld
= emptyResource {
resGet
= Just $ do setContentType $ parseMIMEType "text/hello"
- outputChunk "Hello, "
- outputChunk "World!\n"
- outputChunk =≪ Lazy.pack <$> getRemoteAddr'
+ putChunk "Hello, "
+ putChunk "World!\n"
+ putChunks =≪ Lazy.pack <$> getRemoteAddr'
, resPost
- = Just $ do str1 ← inputChunk 3
- str2 ← inputChunk 3
- str3 ← inputChunk 3
+ = Just $ do str1 ← getChunk 3
+ str2 ← getChunk 3
+ str3 ← getChunk 3
setContentType $ parseMIMEType "text/hello"
- output ("[" ⊕ str1 ⊕ " - " ⊕ str2 ⊕ "#" ⊕ str3 ⊕ "]")
+ putChunks $ Lazy.fromChunks ["[", str1, " - ", str2, "#", str3, "]"]
}
projects / Lucu.git / commitdiff