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 :: 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 responce <- newTVarIO $ Response {
88 resVersion = HttpVersion 1 1
90 , resHeaders = [("Content-Type", defaultPageContentType)]
93 requestHasBody <- newTVarIO False
94 requestIsChunked <- newTVarIO False
95 expectedContinue <- newTVarIO False
97 reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
98 reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
99 reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
100 reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
101 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
102 receivedBody <- newTVarIO B.empty
104 willReceiveBody <- newTVarIO False
105 willChunkBody <- newTVarIO False
106 willDiscardBody <- newTVarIO False
107 willClose <- newTVarIO False
109 bodyToSend <- newTVarIO B.empty
110 bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
112 state <- newTVarIO ExaminingRequest
114 wroteContinue <- newTVarIO False
115 wroteHeader <- newTVarIO False
117 return $ Interaction {
119 , itrRemoteHost = host
120 , itrResourcePath = Nothing
122 , itrResponse = responce
124 , itrRequestHasBody = requestHasBody
125 , itrRequestIsChunked = requestIsChunked
126 , itrExpectedContinue = expectedContinue
128 , itrReqChunkLength = reqChunkLength
129 , itrReqChunkRemaining = reqChunkRemaining
130 , itrReqChunkIsOver = reqChunkIsOver
131 , itrReqBodyWanted = reqBodyWanted
132 , itrReqBodyWasteAll = reqBodyWasteAll
133 , itrReceivedBody = receivedBody
135 , itrWillReceiveBody = willReceiveBody
136 , itrWillChunkBody = willChunkBody
137 , itrWillDiscardBody = willDiscardBody
138 , itrWillClose = willClose
140 , itrBodyToSend = bodyToSend
141 , itrBodyIsNull = bodyIsNull
145 , itrWroteContinue = wroteContinue
146 , itrWroteHeader = wroteHeader
150 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
151 writeItr itr accessor value
152 = writeTVar (accessor itr) value
155 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
156 readItr itr accessor reader
157 = readTVar (accessor itr) >>= return . reader
160 readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
161 readItrF itr accessor reader
162 = readItr itr accessor (fmap reader)
165 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
166 updateItr itr accessor updator
167 = do old <- readItr itr accessor id
168 writeItr itr accessor (updator old)
171 updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
172 updateItrF itr accessor updator
173 = updateItr itr accessor (fmap updator)