Network/HTTP/Lucu/Interaction.hs

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