2 module Network.HTTP.Lucu.Interaction
8 , defaultPageContentType
18 import Control.Concurrent.STM
19 import qualified Data.ByteString.Lazy.Char8 as B
20 import Data.ByteString.Lazy.Char8 (ByteString)
21 import qualified Data.Sequence as S
22 import Data.Sequence (Seq)
24 import Network.HTTP.Lucu.Config
25 import Network.HTTP.Lucu.HttpVersion
26 import Network.HTTP.Lucu.Request
27 import Network.HTTP.Lucu.Response
29 data Interaction = Interaction {
31 , itrRemoteHost :: HostName
32 , itrResourcePath :: Maybe [String]
33 , itrRequest :: TVar (Maybe Request)
34 , itrResponse :: TVar Response
36 -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
37 -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
38 -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
40 , itrRequestHasBody :: TVar Bool
41 , itrRequestIsChunked :: TVar Bool
42 , itrExpectedContinue :: TVar Bool
44 , itrReqChunkLength :: TVar (Maybe Int)
45 , itrReqChunkRemaining :: TVar (Maybe Int)
46 , itrReqChunkIsOver :: TVar Bool
47 , itrReqBodyWanted :: TVar (Maybe Int)
48 , itrReqBodyWasteAll :: TVar Bool
49 , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される
51 , itrWillReceiveBody :: TVar Bool
52 , itrWillChunkBody :: TVar Bool
53 , itrWillDiscardBody :: TVar Bool
54 , itrWillClose :: TVar Bool
56 , itrBodyToSend :: TVar ByteString
57 , itrBodyIsNull :: TVar Bool
59 , itrState :: TVar InteractionState
61 , itrWroteContinue :: TVar Bool
62 , itrWroteHeader :: TVar Bool
65 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
66 -- 状態は ExaminingRequest。
67 data InteractionState = ExaminingRequest
72 deriving (Show, Eq, Ord, Enum)
74 type InteractionQueue = TVar (Seq Interaction)
77 newInteractionQueue :: IO InteractionQueue
78 newInteractionQueue = newTVarIO S.empty
81 defaultPageContentType :: String
82 defaultPageContentType = "application/xhtml+xml"
85 newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
86 newInteraction conf host req
87 = do request <- newTVarIO $ req
88 responce <- newTVarIO $ Response {
89 resVersion = HttpVersion 1 1
91 , resHeaders = [("Content-Type", defaultPageContentType)]
94 requestHasBody <- newTVarIO False
95 requestIsChunked <- newTVarIO False
96 expectedContinue <- newTVarIO False
98 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
99 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
100 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
101 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
102 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
103 receivedBody <- newTVarIO B.empty
105 willReceiveBody <- newTVarIO False
106 willChunkBody <- newTVarIO False
107 willDiscardBody <- newTVarIO False
108 willClose <- newTVarIO False
110 bodyToSend <- newTVarIO B.empty
111 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
113 state <- newTVarIO ExaminingRequest
115 wroteContinue <- newTVarIO False
116 wroteHeader <- newTVarIO False
118 return $ Interaction {
120 , itrRemoteHost = host
121 , itrResourcePath = Nothing
122 , itrRequest = request
123 , itrResponse = responce
125 , itrRequestHasBody = requestHasBody
126 , itrRequestIsChunked = requestIsChunked
127 , itrExpectedContinue = expectedContinue
129 , itrReqChunkLength = reqChunkLength
130 , itrReqChunkRemaining = reqChunkRemaining
131 , itrReqChunkIsOver = reqChunkIsOver
132 , itrReqBodyWanted = reqBodyWanted
133 , itrReqBodyWasteAll = reqBodyWasteAll
134 , itrReceivedBody = receivedBody
136 , itrWillReceiveBody = willReceiveBody
137 , itrWillChunkBody = willChunkBody
138 , itrWillDiscardBody = willDiscardBody
139 , itrWillClose = willClose
141 , itrBodyToSend = bodyToSend
142 , itrBodyIsNull = bodyIsNull
146 , itrWroteContinue = wroteContinue
147 , itrWroteHeader = wroteHeader
151 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
152 writeItr itr accessor value
153 = writeTVar (accessor itr) value
156 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
157 readItr itr accessor reader
158 = readTVar (accessor itr) >>= return . reader
161 readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
162 readItrF itr accessor reader
163 = readItr itr accessor (fmap reader)
166 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
167 updateItr itr accessor updator
168 = do old <- readItr itr accessor id
169 writeItr itr accessor (updator old)
172 updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
173 updateItrF itr accessor updator
174 = updateItr itr accessor (fmap updator)