Network/HTTP/Lucu/Interaction.hs

   1 module Network.HTTP.Lucu.Interaction
   2     ( Interaction(..)
   3     , InteractionState(..)
   4     , InteractionQueue
   5     , newInteractionQueue -- IO InteractionQueue
   6     , newInteraction      -- Config -> HostName -> Maybe Request -> IO Interaction
   7
   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 ()
  13     )
  14     where
  15
  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)
  21 import           Network
  22 import           Network.HTTP.Lucu.Config
  23 import           Network.HTTP.Lucu.Request
  24 import           Network.HTTP.Lucu.Response
  25
  26 data Interaction = Interaction {
  27       itrConfig      :: Config
  28     , itrRemoteHost  :: HostName
  29     , itrRequest     :: Maybe Request
  30     , itrResponse    :: TVar (Maybe Response)
  31
  32     , itrRequestHasBody    :: TVar Bool
  33     , itrRequestIsChunked  :: TVar Bool
  34     , itrExpectedContinue  :: TVar Bool
  35
  36     , itrReqChunkLength    :: TVar (Maybe Int)
  37     , itrReqChunkRemaining :: TVar (Maybe Int)
  38     , itrReqChunkIsOver    :: TVar Bool
  39     , itrReqBodyWanted     :: TVar (Maybe Int)
  40     , itrReqBodyWasteAll   :: TVar Bool
  41     , itrReceivedBody      :: TVar ByteString -- Resource が受領した部分は削除される
  42
  43     , itrWillReceiveBody   :: TVar Bool
  44     , itrWillChunkBody     :: TVar Bool
  45     , itrWillDiscardBody   :: TVar Bool
  46     , itrWillClose         :: TVar Bool
  47
  48     , itrBodyToSend :: TVar ByteString
  49     , itrBodyIsNull :: TVar Bool
  50
  51     , itrState :: TVar InteractionState
  52
  53     , itrWroteContinue :: TVar Bool
  54     , itrWroteHeader   :: TVar Bool
  55     }
  56
  57 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
  58 -- 状態は ExaminingHeader (リクエストボディが有る時) または
  59 -- DecidingHeader (無い時)。終了状態は常に Done
  60 data InteractionState = ExaminingHeader
  61                       | GettingBody
  62                       | DecidingHeader
  63                       | DecidingBody
  64                       | Done
  65                         deriving (Show, Eq, Ord, Enum)
  66
  67 type InteractionQueue = TVar (Seq Interaction)
  68
  69
  70 newInteractionQueue :: IO InteractionQueue
  71 newInteractionQueue = newTVarIO S.empty
  72
  73
  74 newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
  75 newInteraction conf host req
  76     = do responce <- newTVarIO Nothing
  77
  78          requestHasBody     <- newTVarIO False
  79          requestIsChunked   <- newTVarIO False
  80          expectedContinue   <- newTVarIO False
  81
  82          reqChunkLength     <- newTVarIO Nothing -- 現在のチャンク長
  83          reqChunkRemaining  <- newTVarIO Nothing -- 現在のチャンクの殘り
  84          reqChunkIsOver     <- newTVarIO False   -- 最後のチャンクを讀み終へた
  85          reqBodyWanted      <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
  86          reqBodyWasteAll    <- newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
  87          receivedBody       <- newTVarIO B.empty
  88
  89          willReceiveBody   <- newTVarIO False
  90          willChunkBody     <- newTVarIO False
  91          willDiscardBody   <- newTVarIO False
  92          willClose         <- newTVarIO False
  93
  94          bodyToSend <- newTVarIO B.empty
  95          bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
  96
  97          state <- newTVarIO undefined
  98
  99          wroteContinue <- newTVarIO False
 100          wroteHeader   <- newTVarIO False
 101
 102          return $ Interaction {
 103                       itrConfig     = conf
 104                     , itrRemoteHost = host
 105                     , itrRequest    = req
 106                     , itrResponse   = responce
 107
 108                     , itrRequestHasBody    = requestHasBody
 109                     , itrRequestIsChunked  = requestIsChunked
 110                     , itrExpectedContinue = expectedContinue
 111
 112                     , itrReqChunkLength    = reqChunkLength
 113                     , itrReqChunkRemaining = reqChunkRemaining
 114                     , itrReqChunkIsOver    = reqChunkIsOver
 115                     , itrReqBodyWanted     = reqBodyWanted
 116                     , itrReqBodyWasteAll   = reqBodyWasteAll
 117                     , itrReceivedBody      = receivedBody
 118
 119                     , itrWillReceiveBody   = willReceiveBody
 120                     , itrWillChunkBody     = willChunkBody
 121                     , itrWillDiscardBody   = willDiscardBody
 122                     , itrWillClose         = willClose
 123
 124                     , itrBodyToSend = bodyToSend
 125                     , itrBodyIsNull = bodyIsNull
 126
 127                     , itrState = state
 128
 129                     , itrWroteContinue = wroteContinue
 130                     , itrWroteHeader   = wroteHeader
 131                     }
 132
 133
 134 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
 135 writeItr itr accessor value
 136     = writeTVar (accessor itr) value
 137
 138
 139 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
 140 readItr itr accessor reader
 141     = readTVar (accessor itr) >>= return . reader
 142
 143
 144 readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
 145 readItrF itr accessor reader
 146     = readItr itr accessor (fmap reader)
 147
 148
 149 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
 150 updateItr itr accessor updator
 151     = do old <- readItr itr accessor id
 152          writeItr itr accessor (updator old)
 153
 154
 155 updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
 156 updateItrF itr accessor updator
 157     = updateItr itr accessor (fmap updator)