Network/HTTP/Lucu/Interaction.hs

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