1 module Network.HTTP.Lucu.Interaction
5 , newInteractionQueue -- IO InteractionQueue
6 , newInteraction -- 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.Request
23 import Network.HTTP.Lucu.Response
25 data Interaction = Interaction {
26 itrRemoteHost :: HostName
27 , itrRequest :: Maybe Request
28 , itrResponse :: TVar (Maybe Response)
30 , itrRequestHasBody :: TVar Bool
31 , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明
32 , itrRequestIsChunked :: TVar Bool
33 , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される
35 , itrExpectedContinue :: TVar Bool
37 , itrWillChunkBody :: TVar Bool
38 , itrWillDiscardBody :: TVar Bool
39 , itrWillClose :: TVar Bool
40 , itrBodyToSend :: TVar ByteString
42 , itrState :: TVar InteractionState
44 , itrWroteContinue :: TVar Bool
45 , itrWroteHeader :: TVar Bool
48 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
49 -- 状態は ExaminingHeader (リクエストボディが有る時) または
50 -- DecidingHeader (無い時)。終了状態は常に Done
51 data InteractionState = ExaminingHeader
56 deriving (Show, Eq, Ord)
58 type InteractionQueue = TVar (Seq Interaction)
61 newInteractionQueue :: IO InteractionQueue
62 newInteractionQueue = newTVarIO S.empty
65 newInteraction :: HostName -> Maybe Request -> IO Interaction
66 newInteraction host req
67 = do responce <- newTVarIO Nothing
69 requestHasBody <- newTVarIO False
70 requestBodyLength <- newTVarIO Nothing
71 requestIsChunked <- newTVarIO False
72 receivedBody <- newTVarIO B.empty
74 expectedContinue <- newTVarIO False
76 willChunkBody <- newTVarIO False
77 willDiscardBody <- newTVarIO False
78 willClose <- newTVarIO False
79 bodyToSend <- newTVarIO B.empty
81 state <- newTVarIO undefined
83 wroteContinue <- newTVarIO False
84 wroteHeader <- newTVarIO False
86 return $ Interaction {
89 , itrResponse = responce
91 , itrRequestHasBody = requestHasBody
92 , itrRequestBodyLength = requestBodyLength
93 , itrRequestIsChunked = requestIsChunked
94 , itrReceivedBody = receivedBody
96 , itrExpectedContinue = expectedContinue
98 , itrWillChunkBody = willChunkBody
99 , itrWillDiscardBody = willDiscardBody
100 , itrWillClose = willClose
101 , itrBodyToSend = bodyToSend
105 , itrWroteContinue = wroteContinue
106 , itrWroteHeader = wroteHeader
110 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
111 writeItr itr accessor value
112 = writeTVar (accessor itr) value
115 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
116 readItr itr accessor reader
117 = readTVar (accessor itr) >>= return . reader
120 readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
121 readItrF itr accessor reader
122 = readItr itr accessor (fmap reader)
125 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
126 updateItr itr accessor updator
127 = do old <- readItr itr accessor id
128 writeItr itr accessor (updator old)
131 updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
132 updateItrF itr accessor updator
133 = updateItr itr accessor (fmap updator)