Network/HTTP/Lucu/Interaction.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , OverloadedStrings
   4   , UnicodeSyntax
   5   #-}
   6 module Network.HTTP.Lucu.Interaction
   7     ( Interaction(..)
   8     , InteractionState(..)
   9     , InteractionQueue
  10     , newInteractionQueue
  11     , newInteraction
  12     , defaultPageContentType
  13
  14     , writeItr
  15     , readItr
  16     , updateItr
  17     )
  18     where
  19 import Blaze.ByteString.Builder (Builder)
  20 import Control.Applicative
  21 import Control.Concurrent.STM
  22 import Data.Ascii (Ascii)
  23 import qualified Data.ByteString as BS
  24 import Data.Sequence (Seq)
  25 import qualified Data.Sequence as S
  26 import Data.Text (Text)
  27 import Network.Socket
  28 import Network.HTTP.Lucu.Config
  29 import Network.HTTP.Lucu.Headers
  30 import Network.HTTP.Lucu.HttpVersion
  31 import Network.HTTP.Lucu.Request
  32 import Network.HTTP.Lucu.Response
  33 import OpenSSL.X509
  34
  35 data Interaction = Interaction {
  36       itrConfig            ∷ !Config
  37     , itrLocalPort         ∷ !PortNumber
  38     , itrRemoteAddr        ∷ !SockAddr
  39     , itrRemoteCert        ∷ !(Maybe X509)
  40     , itrResourcePath      ∷ !(Maybe [Text])
  41     , itrRequest           ∷ !(TVar (Maybe Request))
  42     , itrResponse          ∷ !(TVar Response)
  43
  44     , itrRequestHasBody    ∷ !(TVar Bool)
  45     , itrRequestIsChunked  ∷ !(TVar Bool)
  46     , itrExpectedContinue  ∷ !(TVar Bool)
  47
  48     , itrReqChunkLength    ∷ !(TVar (Maybe Int))
  49     , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
  50     , itrReqChunkIsOver    ∷ !(TVar Bool)
  51     , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
  52     , itrReqBodyWasteAll   ∷ !(TVar Bool)
  53     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
  54     , itrReceivedBodyLen   ∷ !(TVar Int)
  55
  56     , itrWillReceiveBody   ∷ !(TVar Bool)
  57     , itrWillChunkBody     ∷ !(TVar Bool)
  58     , itrWillDiscardBody   ∷ !(TVar Bool)
  59     , itrWillClose         ∷ !(TVar Bool)
  60
  61     , itrBodyToSend        ∷ !(TMVar Builder)
  62     , itrBodyIsNull        ∷ !(TVar Bool)
  63
  64     , itrState             ∷ !(TVar InteractionState)
  65
  66     , itrWroteContinue     ∷ !(TVar Bool)
  67     , itrWroteHeader       ∷ !(TVar Bool)
  68     }
  69
  70 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
  71 -- initial state.
  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 newInteractionQueue ∷ IO InteractionQueue
  82 newInteractionQueue = newTVarIO S.empty
  83
  84 defaultPageContentType ∷ Ascii
  85 defaultPageContentType = "application/xhtml+xml"
  86
  87 newInteraction ∷ Config → PortNumber → SockAddr → Maybe X509 → Maybe Request → IO Interaction
  88 newInteraction !conf !port !addr !cert !req
  89     = do request  ← newTVarIO req
  90          responce ← newTVarIO Response {
  91                        resVersion = HttpVersion 1 1
  92                      , resStatus  = Ok
  93                      , resHeaders = toHeaders [("Content-Type", defaultPageContentType)]
  94                      }
  95
  96          requestHasBody     ← newTVarIO False
  97          requestIsChunked   ← newTVarIO False
  98          expectedContinue   ← newTVarIO False
  99
 100          reqChunkLength     ← newTVarIO Nothing -- 現在のチャンク長
 101          reqChunkRemaining  ← newTVarIO Nothing -- 現在のチャンクの殘り
 102          reqChunkIsOver     ← newTVarIO False   -- 最後のチャンクを讀み終へた
 103          reqBodyWanted      ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
 104          reqBodyWasteAll    ← newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
 105          receivedBody       ← newTVarIO S.empty
 106          receivedBodyLen    ← newTVarIO 0
 107
 108          willReceiveBody   ← newTVarIO False
 109          willChunkBody     ← newTVarIO False
 110          willDiscardBody   ← newTVarIO False
 111          willClose         ← newTVarIO False
 112
 113          bodyToSend ← newEmptyTMVarIO
 114          bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
 115
 116          state ← newTVarIO ExaminingRequest
 117
 118          wroteContinue ← newTVarIO False
 119          wroteHeader   ← newTVarIO False
 120
 121          return Interaction {
 122                       itrConfig       = conf
 123                     , itrLocalPort    = port
 124                     , itrRemoteAddr   = addr
 125                     , itrRemoteCert   = cert
 126                     , itrResourcePath = Nothing
 127                     , itrRequest      = request
 128                     , itrResponse     = responce
 129
 130                     , itrRequestHasBody   = requestHasBody
 131                     , itrRequestIsChunked = requestIsChunked
 132                     , itrExpectedContinue = expectedContinue
 133
 134                     , itrReqChunkLength    = reqChunkLength
 135                     , itrReqChunkRemaining = reqChunkRemaining
 136                     , itrReqChunkIsOver    = reqChunkIsOver
 137                     , itrReqBodyWanted     = reqBodyWanted
 138                     , itrReqBodyWasteAll   = reqBodyWasteAll
 139                     , itrReceivedBody      = receivedBody
 140                     , itrReceivedBodyLen   = receivedBodyLen
 141
 142                     , itrWillReceiveBody   = willReceiveBody
 143                     , itrWillChunkBody     = willChunkBody
 144                     , itrWillDiscardBody   = willDiscardBody
 145                     , itrWillClose         = willClose
 146
 147                     , itrBodyToSend = bodyToSend
 148                     , itrBodyIsNull = bodyIsNull
 149
 150                     , itrState = state
 151
 152                     , itrWroteContinue = wroteContinue
 153                     , itrWroteHeader   = wroteHeader
 154                     }
 155
 156 {-
 157 chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
 158 {-# INLINE chunksToLBS #-}
 159 chunksToLBS = LBS.fromChunks ∘ toList
 160
 161 chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
 162 {-# INLINE chunksFromLBS #-}
 163 chunksFromLBS = S.fromList ∘ LBS.toChunks
 164 -}
 165
 166 writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
 167 {-# INLINE writeItr #-}
 168 writeItr accessor a itr
 169     = writeTVar (accessor itr) a
 170
 171 readItr ∷ (Interaction → TVar a) → (a → b) → Interaction → STM b
 172 {-# INLINE readItr #-}
 173 readItr accessor reader itr
 174     = reader <$> readTVar (accessor itr)
 175
 176 updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
 177 {-# INLINE updateItr #-}
 178 updateItr accessor updator itr
 179     = do old ← readItr accessor id itr
 180          writeItr accessor (updator old) itr