Network/HTTP/Lucu/Interaction.hs

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