6 module Network.HTTP.Lucu.Interaction
12 , defaultPageContentType
17 import Blaze.ByteString.Builder (Builder)
18 import Control.Concurrent.STM
19 import Data.Ascii (Ascii)
20 import qualified Data.ByteString as BS
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.Headers
27 import Network.HTTP.Lucu.HttpVersion
28 import Network.HTTP.Lucu.Preprocess
29 import Network.HTTP.Lucu.Request
30 import Network.HTTP.Lucu.Response
33 data Interaction = Interaction {
35 , itrLocalPort ∷ !PortNumber
36 , itrRemoteAddr ∷ !SockAddr
37 , itrRemoteCert ∷ !(Maybe X509)
38 , itrResourcePath ∷ !(Maybe [Text])
39 , itrRequest ∷ !(Maybe Request)
41 , itrExpectedContinue ∷ !(Maybe Bool)
42 , itrReqBodyLength ∷ !(Maybe RequestBodyLength)
44 , itrReqBodyWanted ∷ !(TVar (Maybe Int))
45 , itrReqBodyWasteAll ∷ !(TVar Bool)
46 , itrReqChunkIsOver ∷ !(TVar Bool)
47 , itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
48 , itrReceivedBodyLen ∷ !(TVar Int)
50 , itrResponse ∷ !(TVar Response)
51 , itrWillChunkBody ∷ !(TVar Bool)
52 , itrWillDiscardBody ∷ !(TVar Bool)
53 , itrWillClose ∷ !(TVar Bool)
54 , itrBodyToSend ∷ !(TMVar Builder)
55 , itrSentNoBodySoFar ∷ !(TVar Bool)
57 , itrState ∷ !(TVar InteractionState)
60 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
62 data InteractionState = ExaminingRequest
67 deriving (Show, Eq, Ord, Enum)
69 type InteractionQueue = TVar (Seq Interaction)
71 newInteractionQueue ∷ IO InteractionQueue
72 newInteractionQueue = newTVarIO S.empty
74 defaultPageContentType ∷ Ascii
75 defaultPageContentType = "application/xhtml+xml"
77 newInteraction ∷ Config
81 → Either StatusCode Request
83 newInteraction conf@(Config {..}) port addr cert request
84 = do let ar = preprocess cnfServerHost port request
86 resVersion = HttpVersion 1 1
87 , resStatus = arInitialStatus ar
88 , resHeaders = singleton "Content-Type" defaultPageContentType
91 reqBodyWanted ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
92 reqBodyWasteAll ← newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
93 reqChunkIsOver ← newTVarIO False -- 最後のチャンクを讀み終へた
94 receivedBody ← newTVarIO S.empty
95 receivedBodyLen ← newTVarIO 0
97 response ← newTVarIO res
98 willChunkBody ← newTVarIO False
99 willDiscardBody ← newTVarIO False
100 willClose ← newTVarIO False
101 bodyToSend ← newEmptyTMVarIO
102 sentNoBodySoFar ← newTVarIO True
104 state ← newTVarIO ExaminingRequest
108 , itrLocalPort = port
109 , itrRemoteAddr = addr
110 , itrRemoteCert = cert
111 , itrResourcePath = Nothing
112 , itrRequest = arRequest ar
114 , itrExpectedContinue = arExpectedContinue ar
115 , itrReqBodyLength = arReqBodyLength ar
117 , itrReqBodyWanted = reqBodyWanted
118 , itrReqBodyWasteAll = reqBodyWasteAll
119 , itrReqChunkIsOver = reqChunkIsOver
120 , itrReceivedBody = receivedBody
121 , itrReceivedBodyLen = receivedBodyLen
123 , itrResponse = response
124 , itrWillChunkBody = willChunkBody
125 , itrWillDiscardBody = willDiscardBody
126 , itrWillClose = willClose
127 , itrBodyToSend = bodyToSend
128 , itrSentNoBodySoFar = sentNoBodySoFar
133 setResponseStatus ∷ Interaction → StatusCode → STM ()
134 setResponseStatus (Interaction {..}) sc
135 = do res ← readTVar itrResponse
139 writeTVar itrResponse res'