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