6 module Network.HTTP.Lucu.Interaction
16 import Blaze.ByteString.Builder (Builder)
17 import Control.Concurrent.STM
18 import qualified Data.ByteString as BS
19 import Data.Monoid.Unicode
20 import Data.Sequence (Seq)
21 import qualified Data.Sequence as S
22 import Data.Text (Text)
24 import Network.HTTP.Lucu.Config
25 import Network.HTTP.Lucu.HttpVersion
26 import Network.HTTP.Lucu.Preprocess
27 import Network.HTTP.Lucu.Request
28 import Network.HTTP.Lucu.Response
31 data Interaction = Interaction {
33 , itrLocalPort ∷ !PortNumber
34 , itrRemoteAddr ∷ !SockAddr
35 , itrRemoteCert ∷ !(Maybe X509)
36 , itrResourcePath ∷ !(Maybe [Text])
37 , itrRequest ∷ !(Maybe Request)
39 , itrExpectedContinue ∷ !(Maybe Bool)
40 , itrReqBodyLength ∷ !(Maybe RequestBodyLength)
42 , itrReqBodyWanted ∷ !(TVar Int)
43 , itrReqBodyWasteAll ∷ !(TVar Bool)
44 , itrReqChunkIsOver ∷ !(TVar Bool)
45 , itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
46 , itrReceivedBodyLen ∷ !(TVar Int)
48 , itrResponse ∷ !(TVar Response)
49 , itrWillChunkBody ∷ !(TVar Bool)
50 , itrWillDiscardBody ∷ !(TVar Bool)
51 , itrWillClose ∷ !(TVar Bool)
52 , itrResponseHasCType ∷ !(TVar Bool)
53 , itrBodyToSend ∷ !(TMVar Builder)
55 , itrState ∷ !(TVar InteractionState)
58 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
60 data InteractionState = ExaminingRequest
65 deriving (Show, Eq, Ord, Enum)
67 type InteractionQueue = TVar (Seq Interaction)
69 newInteractionQueue ∷ IO InteractionQueue
70 newInteractionQueue = newTVarIO S.empty
72 newInteraction ∷ Config
76 → Either StatusCode Request
78 newInteraction conf@(Config {..}) port addr cert request
79 = do let ar = preprocess cnfServerHost port request
81 resVersion = HttpVersion 1 1
82 , resStatus = arInitialStatus ar
86 reqBodyWanted ← newTVarIO 0
87 reqBodyWasteAll ← newTVarIO False
88 reqChunkIsOver ← newTVarIO False
89 receivedBody ← newTVarIO S.empty
90 receivedBodyLen ← newTVarIO 0
92 response ← newTVarIO res
93 willChunkBody ← newTVarIO False
94 willDiscardBody ← newTVarIO (arWillDiscardBody ar)
95 willClose ← newTVarIO (arWillClose ar)
96 bodyToSend ← newEmptyTMVarIO
97 responseHasCType ← newTVarIO False
99 state ← newTVarIO ExaminingRequest
103 , itrLocalPort = port
104 , itrRemoteAddr = addr
105 , itrRemoteCert = cert
106 , itrResourcePath = Nothing
107 , itrRequest = arRequest ar
109 , itrExpectedContinue = arExpectedContinue ar
110 , itrReqBodyLength = arReqBodyLength ar
112 , itrReqBodyWanted = reqBodyWanted
113 , itrReqBodyWasteAll = reqBodyWasteAll
114 , itrReqChunkIsOver = reqChunkIsOver
115 , itrReceivedBody = receivedBody
116 , itrReceivedBodyLen = receivedBodyLen
118 , itrResponse = response
119 , itrWillChunkBody = willChunkBody
120 , itrWillDiscardBody = willDiscardBody
121 , itrWillClose = willClose
122 , itrResponseHasCType = responseHasCType
123 , itrBodyToSend = bodyToSend
128 setResponseStatus ∷ Interaction → StatusCode → STM ()
129 setResponseStatus (Interaction {..}) sc
130 = do res ← readTVar itrResponse
134 writeTVar itrResponse res'