module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) , InteractionQueue , newInteractionQueue -- IO InteractionQueue , newInteraction -- HostName -> Maybe Request -> IO Interaction , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM () , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b , readItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) , updateItr -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () ) where import Control.Concurrent.STM import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.Sequence as S import Data.Sequence (Seq) import Network import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response data Interaction = Interaction { itrRemoteHost :: HostName , itrRequest :: Maybe Request , itrResponse :: TVar (Maybe Response) , itrRequestHasBody :: TVar Bool , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明 , itrRequestIsChunked :: TVar Bool , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される , itrExpectedContinue :: TVar Bool , itrWillChunkBody :: TVar Bool , itrWillDiscardBody :: TVar Bool , itrWillClose :: TVar Bool , itrBodyToSend :: TVar ByteString , itrState :: TVar InteractionState , itrWroteContinue :: TVar Bool , itrWroteHeader :: TVar Bool } -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 -- 状態は ExaminingHeader (リクエストボディが有る時) または -- DecidingHeader (無い時)。終了状態は常に Done data InteractionState = ExaminingHeader | GettingBody | DecidingHeader | DecidingBody | Done deriving (Show, Eq, Ord) type InteractionQueue = TVar (Seq Interaction) newInteractionQueue :: IO InteractionQueue newInteractionQueue = newTVarIO S.empty newInteraction :: HostName -> Maybe Request -> IO Interaction newInteraction host req = do responce <- newTVarIO Nothing requestHasBody <- newTVarIO False requestBodyLength <- newTVarIO Nothing requestIsChunked <- newTVarIO False receivedBody <- newTVarIO B.empty expectedContinue <- newTVarIO False willChunkBody <- newTVarIO False willDiscardBody <- newTVarIO False willClose <- newTVarIO False bodyToSend <- newTVarIO B.empty state <- newTVarIO undefined wroteContinue <- newTVarIO False wroteHeader <- newTVarIO False return $ Interaction { itrRemoteHost = host , itrRequest = req , itrResponse = responce , itrRequestHasBody = requestHasBody , itrRequestBodyLength = requestBodyLength , itrRequestIsChunked = requestIsChunked , itrReceivedBody = receivedBody , itrExpectedContinue = expectedContinue , itrWillChunkBody = willChunkBody , itrWillDiscardBody = willDiscardBody , itrWillClose = willClose , itrBodyToSend = bodyToSend , itrState = state , itrWroteContinue = wroteContinue , itrWroteHeader = wroteHeader } writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM () writeItr itr accessor value = writeTVar (accessor itr) value readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b readItr itr accessor reader = readTVar (accessor itr) >>= return . reader readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) readItrF itr accessor reader = readItr itr accessor (fmap reader) updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () updateItr itr accessor updator = do old <- readItr itr accessor id writeItr itr accessor (updator old) updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () updateItrF itr accessor updator = updateItr itr accessor (fmap updator)