Network/HTTP/Lucu/Interaction.hs

   1 module Network.HTTP.Lucu.Interaction
   2     ( Interaction(..)
   3     , InteractionState(..)
   4     , InteractionQueue
   5     , newInteractionQueue -- IO InteractionQueue
   6     , newInteraction      -- 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.Request
  23 import           Network.HTTP.Lucu.Response
  24
  25 data Interaction = Interaction {
  26       itrRemoteHost  :: HostName
  27     , itrRequest     :: Maybe Request
  28     , itrResponse    :: TVar (Maybe Response)
  29
  30     , itrRequestHasBody    :: TVar Bool
  31     , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明
  32     , itrRequestIsChunked  :: TVar Bool
  33     , itrReceivedBody      :: TVar ByteString -- Resource が受領した部分は削除される
  34
  35     , itrExpectedContinue  :: TVar Bool
  36
  37     , itrWillChunkBody    :: TVar Bool
  38     , itrWillDiscardBody  :: TVar Bool
  39     , itrWillClose        :: TVar Bool
  40     , itrBodyToSend       :: TVar ByteString
  41
  42     , itrState :: TVar InteractionState
  43
  44     , itrWroteContinue :: TVar Bool
  45     , itrWroteHeader   :: TVar Bool
  46     }
  47
  48 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
  49 -- 状態は ExaminingHeader (リクエストボディが有る時) または
  50 -- DecidingHeader (無い時)。終了状態は常に Done
  51 data InteractionState = ExaminingHeader
  52                       | GettingBody
  53                       | DecidingHeader
  54                       | DecidingBody
  55                       | Done
  56                         deriving (Show, Eq, Ord)
  57
  58 type InteractionQueue = TVar (Seq Interaction)
  59
  60
  61 newInteractionQueue :: IO InteractionQueue
  62 newInteractionQueue = newTVarIO S.empty
  63
  64
  65 newInteraction :: HostName -> Maybe Request -> IO Interaction
  66 newInteraction host req
  67     = do responce <- newTVarIO Nothing
  68
  69          requestHasBody    <- newTVarIO False
  70          requestBodyLength <- newTVarIO Nothing
  71          requestIsChunked  <- newTVarIO False
  72          receivedBody      <- newTVarIO B.empty
  73
  74          expectedContinue <- newTVarIO False
  75
  76          willChunkBody   <- newTVarIO False
  77          willDiscardBody <- newTVarIO False
  78          willClose       <- newTVarIO False
  79          bodyToSend      <- newTVarIO B.empty
  80
  81          state <- newTVarIO undefined
  82
  83          wroteContinue <- newTVarIO False
  84          wroteHeader   <- newTVarIO False
  85
  86          return $ Interaction {
  87                       itrRemoteHost = host
  88                     , itrRequest    = req
  89                     , itrResponse   = responce
  90
  91                     , itrRequestHasBody    = requestHasBody
  92                     , itrRequestBodyLength = requestBodyLength
  93                     , itrRequestIsChunked  = requestIsChunked
  94                     , itrReceivedBody      = receivedBody
  95
  96                     , itrExpectedContinue = expectedContinue
  97
  98                     , itrWillChunkBody    = willChunkBody
  99                     , itrWillDiscardBody  = willDiscardBody
 100                     , itrWillClose        = willClose
 101                     , itrBodyToSend       = bodyToSend
 102
 103                     , itrState = state
 104
 105                     , itrWroteContinue = wroteContinue
 106                     , itrWroteHeader   = wroteHeader
 107                     }
 108
 109
 110 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
 111 writeItr itr accessor value
 112     = writeTVar (accessor itr) value
 113
 114
 115 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
 116 readItr itr accessor reader
 117     = readTVar (accessor itr) >>= return . reader
 118
 119
 120 readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
 121 readItrF itr accessor reader
 122     = readItr itr accessor (fmap reader)
 123
 124
 125 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
 126 updateItr itr accessor updator
 127     = do old <- readItr itr accessor id
 128          writeItr itr accessor (updator old)
 129
 130
 131 updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
 132 updateItrF itr accessor updator
 133     = updateItr itr accessor (fmap updator)