1 module Network.HTTP.Lucu.Interaction
5 , newInteractionQueue -- IO InteractionQueue
6 , newInteraction -- Config -> HostName -> Maybe Request -> IO Interaction
8 , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
9 , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
10 , readItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
11 , updateItr -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
12 , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
16 import Control.Concurrent.STM
17 import qualified Data.ByteString.Lazy.Char8 as B
18 import Data.ByteString.Lazy.Char8 (ByteString)
19 import qualified Data.Sequence as S
20 import Data.Sequence (Seq)
22 import Network.HTTP.Lucu.Config
23 import Network.HTTP.Lucu.Request
24 import Network.HTTP.Lucu.Response
26 data Interaction = Interaction {
28 , itrRemoteHost :: HostName
29 , itrRequest :: Maybe Request
30 , itrResponse :: TVar (Maybe Response)
32 , itrRequestHasBody :: TVar Bool
33 , itrRequestIsChunked :: TVar Bool
34 , itrExpectedContinue :: TVar Bool
36 , itrReqChunkLength :: TVar (Maybe Int)
37 , itrReqChunkRemaining :: TVar (Maybe Int)
38 , itrReqChunkIsOver :: TVar Bool
39 , itrReqBodyWanted :: TVar (Maybe Int)
40 , itrReqBodyWasteAll :: TVar Bool
41 , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される
43 , itrWillReceiveBody :: TVar Bool
44 , itrWillChunkBody :: TVar Bool
45 , itrWillDiscardBody :: TVar Bool
46 , itrWillClose :: TVar Bool
48 , itrBodyToSend :: TVar ByteString
49 , itrBodyIsNull :: TVar Bool
51 , itrState :: TVar InteractionState
53 , itrWroteContinue :: TVar Bool
54 , itrWroteHeader :: TVar Bool
57 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
58 -- 状態は ExaminingRequest。
59 data InteractionState = ExaminingRequest
64 deriving (Show, Eq, Ord, Enum)
66 type InteractionQueue = TVar (Seq Interaction)
69 newInteractionQueue :: IO InteractionQueue
70 newInteractionQueue = newTVarIO S.empty
73 newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
74 newInteraction conf host req
75 = do responce <- newTVarIO Nothing
77 requestHasBody <- newTVarIO False
78 requestIsChunked <- newTVarIO False
79 expectedContinue <- newTVarIO False
81 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
82 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
83 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
84 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
85 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
86 receivedBody <- newTVarIO B.empty
88 willReceiveBody <- newTVarIO False
89 willChunkBody <- newTVarIO False
90 willDiscardBody <- newTVarIO False
91 willClose <- newTVarIO False
93 bodyToSend <- newTVarIO B.empty
94 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
96 state <- newTVarIO ExaminingRequest
98 wroteContinue <- newTVarIO False
99 wroteHeader <- newTVarIO False
101 return $ Interaction {
103 , itrRemoteHost = host
105 , itrResponse = responce
107 , itrRequestHasBody = requestHasBody
108 , itrRequestIsChunked = requestIsChunked
109 , itrExpectedContinue = expectedContinue
111 , itrReqChunkLength = reqChunkLength
112 , itrReqChunkRemaining = reqChunkRemaining
113 , itrReqChunkIsOver = reqChunkIsOver
114 , itrReqBodyWanted = reqBodyWanted
115 , itrReqBodyWasteAll = reqBodyWasteAll
116 , itrReceivedBody = receivedBody
118 , itrWillReceiveBody = willReceiveBody
119 , itrWillChunkBody = willChunkBody
120 , itrWillDiscardBody = willDiscardBody
121 , itrWillClose = willClose
123 , itrBodyToSend = bodyToSend
124 , itrBodyIsNull = bodyIsNull
128 , itrWroteContinue = wroteContinue
129 , itrWroteHeader = wroteHeader
133 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
134 writeItr itr accessor value
135 = writeTVar (accessor itr) value
138 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
139 readItr itr accessor reader
140 = readTVar (accessor itr) >>= return . reader
143 readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
144 readItrF itr accessor reader
145 = readItr itr accessor (fmap reader)
148 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
149 updateItr itr accessor updator
150 = do old <- readItr itr accessor id
151 writeItr itr accessor (updator old)
154 updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
155 updateItrF itr accessor updator
156 = updateItr itr accessor (fmap updator)