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 import           OpenSSL.X509
  31
  32 data Interaction = Interaction {
  33       itrConfig       :: !Config
  34     , itrRemoteAddr   :: !SockAddr
  35     , itrRemoteCert   :: !(Maybe X509)
  36     , itrResourcePath :: !(Maybe [String])
  37     , itrRequest      :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
  38     , itrResponse     :: !(TVar Response)
  39
  40     , itrRequestHasBody    :: !(TVar Bool) -- FIXME: TVar である必要無し
  41     , itrRequestIsChunked  :: !(TVar Bool) -- FIXME: TVar である必要無し
  42     , itrExpectedContinue  :: !(TVar Bool) -- FIXME: TVar である必要無し
  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 Lazy.ByteString) -- Resource が受領した部分は削除される
  50
  51     , itrWillReceiveBody   :: !(TVar Bool)
  52     , itrWillChunkBody     :: !(TVar Bool)
  53     , itrWillDiscardBody   :: !(TVar Bool)
  54     , itrWillClose         :: !(TVar Bool)
  55
  56     , itrBodyToSend :: !(TVar Lazy.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 :: Strict.ByteString
  82 defaultPageContentType = C8.pack "application/xhtml+xml"
  83
  84
  85 newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
  86 newInteraction !conf !addr !cert !req
  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                     , itrRemoteCert   = cert
 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     = writeTVar (accessor itr) value
 155
 156
 157 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
 158 readItr !itr !accessor !reader
 159     = fmap reader $ readTVar (accessor itr)
 160
 161
 162 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
 163 readItrF !itr !accessor !reader
 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     = do old <- readItr itr accessor id
 171          writeItr itr accessor (updator old)
 172
 173
 174 updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
 175 updateItrF !itr !accessor !updator
 176     = updateItr itr accessor (fmap updator)
 177 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}