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