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     , itrLocalPort    :: !PortNumber
  35     , itrRemoteAddr   :: !SockAddr
  36     , itrRemoteCert   :: !(Maybe X509)
  37     , itrResourcePath :: !(Maybe [String])
  38     , itrRequest      :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
  39     , itrResponse     :: !(TVar Response)
  40
  41     , itrRequestHasBody    :: !(TVar Bool) -- FIXME: TVar である必要無し
  42     , itrRequestIsChunked  :: !(TVar Bool) -- FIXME: TVar である必要無し
  43     , itrExpectedContinue  :: !(TVar Bool) -- FIXME: TVar である必要無し
  44
  45     , itrReqChunkLength    :: !(TVar (Maybe Int))
  46     , itrReqChunkRemaining :: !(TVar (Maybe Int))
  47     , itrReqChunkIsOver    :: !(TVar Bool)
  48     , itrReqBodyWanted     :: !(TVar (Maybe Int))
  49     , itrReqBodyWasteAll   :: !(TVar Bool)
  50     , itrReceivedBody      :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される
  51
  52     , itrWillReceiveBody   :: !(TVar Bool)
  53     , itrWillChunkBody     :: !(TVar Bool)
  54     , itrWillDiscardBody   :: !(TVar Bool)
  55     , itrWillClose         :: !(TVar Bool)
  56
  57     , itrBodyToSend :: !(TVar Lazy.ByteString)
  58     , itrBodyIsNull :: !(TVar Bool)
  59
  60     , itrState :: !(TVar InteractionState)
  61
  62     , itrWroteContinue :: !(TVar Bool)
  63     , itrWroteHeader   :: !(TVar Bool)
  64     }
  65
  66 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
  67 -- 状態は ExaminingRequest。
  68 data InteractionState = ExaminingRequest
  69                       | GettingBody
  70                       | DecidingHeader
  71                       | DecidingBody
  72                       | Done
  73                         deriving (Show, Eq, Ord, Enum)
  74
  75 type InteractionQueue = TVar (Seq Interaction)
  76
  77
  78 newInteractionQueue :: IO InteractionQueue
  79 newInteractionQueue = newTVarIO S.empty
  80
  81
  82 defaultPageContentType :: Strict.ByteString
  83 defaultPageContentType = C8.pack "application/xhtml+xml"
  84
  85
  86 newInteraction :: Config -> PortNumber -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
  87 newInteraction !conf !port !addr !cert !req
  88     = do request  <- newTVarIO req
  89          responce <- newTVarIO Response {
  90                        resVersion = HttpVersion 1 1
  91                      , resStatus  = Ok
  92                      , resHeaders = toHeaders [(C8.pack "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 L8.empty
 105
 106          willReceiveBody   <- newTVarIO False
 107          willChunkBody     <- newTVarIO False
 108          willDiscardBody   <- newTVarIO False
 109          willClose         <- newTVarIO False
 110
 111          bodyToSend <- newTVarIO L8.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                     , itrLocalPort    = port
 122                     , itrRemoteAddr   = addr
 123                     , itrRemoteCert   = cert
 124                     , itrResourcePath = Nothing
 125                     , itrRequest      = request
 126                     , itrResponse     = responce
 127
 128                     , itrRequestHasBody   = requestHasBody
 129                     , itrRequestIsChunked = requestIsChunked
 130                     , itrExpectedContinue = expectedContinue
 131
 132                     , itrReqChunkLength    = reqChunkLength
 133                     , itrReqChunkRemaining = reqChunkRemaining
 134                     , itrReqChunkIsOver    = reqChunkIsOver
 135                     , itrReqBodyWanted     = reqBodyWanted
 136                     , itrReqBodyWasteAll   = reqBodyWasteAll
 137                     , itrReceivedBody      = receivedBody
 138
 139                     , itrWillReceiveBody   = willReceiveBody
 140                     , itrWillChunkBody     = willChunkBody
 141                     , itrWillDiscardBody   = willDiscardBody
 142                     , itrWillClose         = willClose
 143
 144                     , itrBodyToSend = bodyToSend
 145                     , itrBodyIsNull = bodyIsNull
 146
 147                     , itrState = state
 148
 149                     , itrWroteContinue = wroteContinue
 150                     , itrWroteHeader   = wroteHeader
 151                     }
 152
 153
 154 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
 155 writeItr !itr !accessor !value
 156     = writeTVar (accessor itr) value
 157
 158
 159 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
 160 readItr !itr !accessor !reader
 161     = fmap reader $ readTVar (accessor itr)
 162
 163
 164 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
 165 readItrF !itr !accessor !reader
 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     = 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     = updateItr itr accessor (fmap updator)
 179 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}