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 , itrResourcePath :: Maybe [String]
30 , itrRequest :: Maybe Request
31 , itrResponse :: TVar (Maybe Response)
33 -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
34 -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
35 -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
37 , itrRequestHasBody :: TVar Bool
38 , itrRequestIsChunked :: TVar Bool
39 , itrExpectedContinue :: TVar Bool
41 , itrReqChunkLength :: TVar (Maybe Int)
42 , itrReqChunkRemaining :: TVar (Maybe Int)
43 , itrReqChunkIsOver :: TVar Bool
44 , itrReqBodyWanted :: TVar (Maybe Int)
45 , itrReqBodyWasteAll :: TVar Bool
46 , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される
48 , itrWillReceiveBody :: TVar Bool
49 , itrWillChunkBody :: TVar Bool
50 , itrWillDiscardBody :: TVar Bool
51 , itrWillClose :: TVar Bool
53 , itrBodyToSend :: TVar ByteString
54 , itrBodyIsNull :: TVar Bool
56 , itrState :: TVar InteractionState
58 , itrWroteContinue :: TVar Bool
59 , itrWroteHeader :: TVar Bool
62 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
63 -- 状態は ExaminingRequest。
64 data InteractionState = ExaminingRequest
69 deriving (Show, Eq, Ord, Enum)
71 type InteractionQueue = TVar (Seq Interaction)
74 newInteractionQueue :: IO InteractionQueue
75 newInteractionQueue = newTVarIO S.empty
78 newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
79 newInteraction conf host req
80 = do responce <- newTVarIO Nothing
82 requestHasBody <- newTVarIO False
83 requestIsChunked <- newTVarIO False
84 expectedContinue <- newTVarIO False
86 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
87 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
88 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
89 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
90 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
91 receivedBody <- newTVarIO B.empty
93 willReceiveBody <- newTVarIO False
94 willChunkBody <- newTVarIO False
95 willDiscardBody <- newTVarIO False
96 willClose <- newTVarIO False
98 bodyToSend <- newTVarIO B.empty
99 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
101 state <- newTVarIO ExaminingRequest
103 wroteContinue <- newTVarIO False
104 wroteHeader <- newTVarIO False
106 return $ Interaction {
108 , itrRemoteHost = host
109 , itrResourcePath = Nothing
111 , itrResponse = responce
113 , itrRequestHasBody = requestHasBody
114 , itrRequestIsChunked = requestIsChunked
115 , itrExpectedContinue = expectedContinue
117 , itrReqChunkLength = reqChunkLength
118 , itrReqChunkRemaining = reqChunkRemaining
119 , itrReqChunkIsOver = reqChunkIsOver
120 , itrReqBodyWanted = reqBodyWanted
121 , itrReqBodyWasteAll = reqBodyWasteAll
122 , itrReceivedBody = receivedBody
124 , itrWillReceiveBody = willReceiveBody
125 , itrWillChunkBody = willChunkBody
126 , itrWillDiscardBody = willDiscardBody
127 , itrWillClose = willClose
129 , itrBodyToSend = bodyToSend
130 , itrBodyIsNull = bodyIsNull
134 , itrWroteContinue = wroteContinue
135 , itrWroteHeader = wroteHeader
139 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
140 writeItr itr accessor value
141 = writeTVar (accessor itr) value
144 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
145 readItr itr accessor reader
146 = readTVar (accessor itr) >>= return . reader
149 readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
150 readItrF itr accessor reader
151 = readItr itr accessor (fmap reader)
154 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
155 updateItr itr accessor updator
156 = do old <- readItr itr accessor id
157 writeItr itr accessor (updator old)
160 updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
161 updateItrF itr accessor updator
162 = updateItr itr accessor (fmap updator)