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 -- 状態は ExaminingHeader (リクエストボディが有る時) または
59 -- DecidingHeader (無い時)。終了状態は常に Done
60 data InteractionState = ExaminingHeader
65 deriving (Show, Eq, Ord, Enum)
67 type InteractionQueue = TVar (Seq Interaction)
70 newInteractionQueue :: IO InteractionQueue
71 newInteractionQueue = newTVarIO S.empty
74 newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
75 newInteraction conf host req
76 = do responce <- newTVarIO Nothing
78 requestHasBody <- newTVarIO False
79 requestIsChunked <- newTVarIO False
80 expectedContinue <- newTVarIO False
82 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
83 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
84 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
85 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
86 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
87 receivedBody <- newTVarIO B.empty
89 willReceiveBody <- newTVarIO False
90 willChunkBody <- newTVarIO False
91 willDiscardBody <- newTVarIO False
92 willClose <- newTVarIO False
94 bodyToSend <- newTVarIO B.empty
95 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
97 state <- newTVarIO undefined
99 wroteContinue <- newTVarIO False
100 wroteHeader <- newTVarIO False
102 return $ Interaction {
104 , itrRemoteHost = host
106 , itrResponse = responce
108 , itrRequestHasBody = requestHasBody
109 , itrRequestIsChunked = requestIsChunked
110 , itrExpectedContinue = expectedContinue
112 , itrReqChunkLength = reqChunkLength
113 , itrReqChunkRemaining = reqChunkRemaining
114 , itrReqChunkIsOver = reqChunkIsOver
115 , itrReqBodyWanted = reqBodyWanted
116 , itrReqBodyWasteAll = reqBodyWasteAll
117 , itrReceivedBody = receivedBody
119 , itrWillReceiveBody = willReceiveBody
120 , itrWillChunkBody = willChunkBody
121 , itrWillDiscardBody = willDiscardBody
122 , itrWillClose = willClose
124 , itrBodyToSend = bodyToSend
125 , itrBodyIsNull = bodyIsNull
129 , itrWroteContinue = wroteContinue
130 , itrWroteHeader = wroteHeader
134 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
135 writeItr itr accessor value
136 = writeTVar (accessor itr) value
139 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
140 readItr itr accessor reader
141 = readTVar (accessor itr) >>= return . reader
144 readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
145 readItrF itr accessor reader
146 = readItr itr accessor (fmap reader)
149 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
150 updateItr itr accessor updator
151 = do old <- readItr itr accessor id
152 writeItr itr accessor (updator old)
155 updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
156 updateItrF itr accessor updator
157 = updateItr itr accessor (fmap updator)