6 module Network.HTTP.Lucu.Interaction
17 import Blaze.ByteString.Builder (Builder)
18 import Control.Concurrent.STM
19 import qualified Data.ByteString as Strict
20 import Data.Monoid.Unicode
21 import Data.Sequence (Seq)
22 import qualified Data.Sequence as S
23 import Data.Text (Text)
25 import Network.HTTP.Lucu.Config
26 import Network.HTTP.Lucu.HttpVersion
27 import Network.HTTP.Lucu.Preprocess
28 import Network.HTTP.Lucu.Request
29 import Network.HTTP.Lucu.Response
32 data Interaction = Interaction {
34 , itrLocalPort ∷ !PortNumber
35 , itrRemoteAddr ∷ !SockAddr
36 , itrRemoteCert ∷ !(Maybe X509)
37 , itrResourcePath ∷ !(Maybe [Text])
38 , itrRequest ∷ !(Maybe Request)
40 , itrExpectedContinue ∷ !(Maybe Bool)
41 , itrReqBodyLength ∷ !(Maybe RequestBodyLength)
43 , itrGetBodyRequest ∷ !(TMVar GetBodyRequest)
44 , itrGotBody ∷ !(TMVar Strict.ByteString)
46 , itrResponse ∷ !(TVar Response)
47 , itrWillChunkBody ∷ !(TVar Bool)
48 , itrWillDiscardBody ∷ !(TVar Bool)
49 , itrWillClose ∷ !(TVar Bool)
50 , itrResponseHasCType ∷ !(TVar Bool)
51 , itrBodyToSend ∷ !(TMVar Builder)
53 , itrState ∷ !(TVar InteractionState)
56 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
64 deriving (Show, Eq, Ord, Enum)
66 type InteractionQueue = TVar (Seq Interaction)
69 = GetBody !Int -- ^ Maximum number of bytes.
73 newInteractionQueue ∷ IO InteractionQueue
74 newInteractionQueue = newTVarIO S.empty
76 newInteraction ∷ Config
80 → Either StatusCode Request
82 newInteraction conf@(Config {..}) port addr cert request
83 = do let ar = preprocess cnfServerHost port request
85 resVersion = HttpVersion 1 1
86 , resStatus = arInitialStatus ar
90 getBodyRequest ← newEmptyTMVarIO
91 gotBody ← newEmptyTMVarIO
93 response ← newTVarIO res
94 willChunkBody ← newTVarIO False
95 willDiscardBody ← newTVarIO (arWillDiscardBody ar)
96 willClose ← newTVarIO (arWillClose ar)
97 bodyToSend ← newEmptyTMVarIO
98 responseHasCType ← newTVarIO False
100 state ← newTVarIO ExaminingRequest
104 , itrLocalPort = port
105 , itrRemoteAddr = addr
106 , itrRemoteCert = cert
107 , itrResourcePath = Nothing
108 , itrRequest = arRequest ar
110 , itrExpectedContinue = arExpectedContinue ar
111 , itrReqBodyLength = arReqBodyLength ar
113 , itrGetBodyRequest = getBodyRequest
114 , itrGotBody = gotBody
116 , itrResponse = response
117 , itrWillChunkBody = willChunkBody
118 , itrWillDiscardBody = willDiscardBody
119 , itrWillClose = willClose
120 , itrResponseHasCType = responseHasCType
121 , itrBodyToSend = bodyToSend
126 setResponseStatus ∷ Interaction → StatusCode → STM ()
127 setResponseStatus (Interaction {..}) sc
128 = do res ← readTVar itrResponse
132 writeTVar itrResponse res'