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     where
   9
  10 import           Control.Concurrent.STM
  11 import qualified Data.ByteString.Lazy.Char8 as B
  12 import           Data.ByteString.Lazy.Char8 (ByteString)
  13 import qualified Data.Sequence as S
  14 import           Data.Sequence (Seq)
  15 import           Network
  16 import           Network.HTTP.Lucu.Request
  17 import           Network.HTTP.Lucu.Response
  18
  19 data Interaction = Interaction {
  20       itrRemoteHost  :: HostName
  21     , itrRequest     :: Maybe Request
  22     , itrResponse    :: TVar (Maybe Response)
  23
  24     , itrRequestHasBody    :: TVar Bool
  25     , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明
  26     , itrRequestIsChunked  :: TVar Bool
  27     , itrReceivedBody      :: TVar ByteString -- Resource が受領した部分は削除される
  28
  29     , itrExpectedContinue  :: TVar Bool
  30
  31     , itrWillChunkBody    :: TVar Bool
  32     , itrWillDiscardBody  :: TVar Bool
  33     , itrWillClose        :: TVar Bool
  34     , itrBodyToSend       :: TVar ByteString
  35
  36     , itrState :: TVar InteractionState
  37
  38     , itrWroteContinue :: TVar Bool
  39     , itrWroteHeader   :: TVar Bool
  40     }
  41
  42 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
  43 -- 状態は ExaminingHeader (リクエストボディが有る時) または
  44 -- DecidingHeader (無い時)。終了状態は常に Done
  45 data InteractionState = ExaminingHeader
  46                       | GettingBody
  47                       | DecidingHeader
  48                       | DecidingBody
  49                       | Done
  50                         deriving (Show, Eq, Ord)
  51
  52 type InteractionQueue = TVar (Seq Interaction)
  53
  54
  55 newInteractionQueue :: IO InteractionQueue
  56 newInteractionQueue = newTVarIO S.empty
  57
  58
  59 newInteraction :: HostName -> Maybe Request -> IO Interaction
  60 newInteraction host req
  61     = do responce <- newTVarIO Nothing
  62
  63          requestHasBody    <- newTVarIO False
  64          requestBodyLength <- newTVarIO Nothing
  65          requestIsChunked  <- newTVarIO False
  66          receivedBody      <- newTVarIO B.empty
  67
  68          expectedContinue <- newTVarIO False
  69
  70          willChunkBody   <- newTVarIO False
  71          willDiscardBody <- newTVarIO False
  72          willClose       <- newTVarIO False
  73          bodyToSend      <- newTVarIO B.empty
  74
  75          state <- newTVarIO undefined
  76
  77          wroteContinue <- newTVarIO False
  78          wroteHeader   <- newTVarIO False
  79
  80          return $ Interaction {
  81                       itrRemoteHost = host
  82                     , itrRequest    = req
  83                     , itrResponse   = responce
  84
  85                     , itrRequestHasBody    = requestHasBody
  86                     , itrRequestBodyLength = requestBodyLength
  87                     , itrRequestIsChunked  = requestIsChunked
  88                     , itrReceivedBody      = receivedBody
  89
  90                     , itrExpectedContinue = expectedContinue
  91
  92                     , itrWillChunkBody    = willChunkBody
  93                     , itrWillDiscardBody  = willDiscardBody
  94                     , itrWillClose        = willClose
  95                     , itrBodyToSend       = bodyToSend
  96
  97                     , itrState = state
  98
  99                     , itrWroteContinue = wroteContinue
 100                     , itrWroteHeader   = wroteHeader
 101                     }