2 module Network.HTTP.Lucu.Interaction
6 , newInteractionQueue -- IO InteractionQueue
7 , newInteraction -- Config -> HostName -> Maybe Request -> IO Interaction
9 , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
10 , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
11 , readItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
12 , updateItr -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
13 , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
17 import Control.Concurrent.STM
18 import qualified Data.ByteString.Lazy.Char8 as B
19 import Data.ByteString.Lazy.Char8 (ByteString)
20 import qualified Data.Sequence as S
21 import Data.Sequence (Seq)
23 import Network.HTTP.Lucu.Config
24 import Network.HTTP.Lucu.Request
25 import Network.HTTP.Lucu.Response
27 data Interaction = Interaction {
29 , itrRemoteHost :: HostName
30 , itrResourcePath :: Maybe [String]
31 , itrRequest :: Maybe Request
32 , itrResponse :: TVar (Maybe Response)
34 -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
35 -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
36 -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
38 , itrRequestHasBody :: TVar Bool
39 , itrRequestIsChunked :: TVar Bool
40 , itrExpectedContinue :: TVar Bool
42 , itrReqChunkLength :: TVar (Maybe Int)
43 , itrReqChunkRemaining :: TVar (Maybe Int)
44 , itrReqChunkIsOver :: TVar Bool
45 , itrReqBodyWanted :: TVar (Maybe Int)
46 , itrReqBodyWasteAll :: TVar Bool
47 , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される
49 , itrWillReceiveBody :: TVar Bool
50 , itrWillChunkBody :: TVar Bool
51 , itrWillDiscardBody :: TVar Bool
52 , itrWillClose :: TVar Bool
54 , itrBodyToSend :: TVar ByteString
55 , itrBodyIsNull :: TVar Bool
57 , itrState :: TVar InteractionState
59 , itrWroteContinue :: TVar Bool
60 , itrWroteHeader :: TVar Bool
63 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
64 -- 状態は ExaminingRequest。
65 data InteractionState = ExaminingRequest
70 deriving (Show, Eq, Ord, Enum)
72 type InteractionQueue = TVar (Seq Interaction)
75 newInteractionQueue :: IO InteractionQueue
76 newInteractionQueue = newTVarIO S.empty
79 newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
80 newInteraction conf host req
81 = do responce <- newTVarIO Nothing
83 requestHasBody <- newTVarIO False
84 requestIsChunked <- newTVarIO False
85 expectedContinue <- newTVarIO False
87 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
88 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
89 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
90 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
91 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
92 receivedBody <- newTVarIO B.empty
94 willReceiveBody <- newTVarIO False
95 willChunkBody <- newTVarIO False
96 willDiscardBody <- newTVarIO False
97 willClose <- newTVarIO False
99 bodyToSend <- newTVarIO B.empty
100 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
102 state <- newTVarIO ExaminingRequest
104 wroteContinue <- newTVarIO False
105 wroteHeader <- newTVarIO False
107 return $ Interaction {
109 , itrRemoteHost = host
110 , itrResourcePath = Nothing
112 , itrResponse = responce
114 , itrRequestHasBody = requestHasBody
115 , itrRequestIsChunked = requestIsChunked
116 , itrExpectedContinue = expectedContinue
118 , itrReqChunkLength = reqChunkLength
119 , itrReqChunkRemaining = reqChunkRemaining
120 , itrReqChunkIsOver = reqChunkIsOver
121 , itrReqBodyWanted = reqBodyWanted
122 , itrReqBodyWasteAll = reqBodyWasteAll
123 , itrReceivedBody = receivedBody
125 , itrWillReceiveBody = willReceiveBody
126 , itrWillChunkBody = willChunkBody
127 , itrWillDiscardBody = willDiscardBody
128 , itrWillClose = willClose
130 , itrBodyToSend = bodyToSend
131 , itrBodyIsNull = bodyIsNull
135 , itrWroteContinue = wroteContinue
136 , itrWroteHeader = wroteHeader
140 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
141 writeItr itr accessor value
142 = writeTVar (accessor itr) value
145 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
146 readItr itr accessor reader
147 = readTVar (accessor itr) >>= return . reader
150 readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
151 readItrF itr accessor reader
152 = readItr itr accessor (fmap reader)
155 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
156 updateItr itr accessor updator
157 = do old <- readItr itr accessor id
158 writeItr itr accessor (updator old)
161 updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
162 updateItrF itr accessor updator
163 = updateItr itr accessor (fmap updator)