Network/HTTP/Lucu/Interaction.hs

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