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.Concurrent.STM
  21 import Data.Ascii (Ascii)
  22 import qualified Data.ByteString as BS
  23 import Data.Sequence (Seq)
  24 import qualified Data.Sequence as S
  25 import Data.Text (Text)
  26 import Network.Socket
  27 import Network.HTTP.Lucu.Config
  28 import Network.HTTP.Lucu.Headers
  29 import Network.HTTP.Lucu.HttpVersion
  30 import Network.HTTP.Lucu.Request
  31 import Network.HTTP.Lucu.Response
  32 import OpenSSL.X509
  33
  34 data Interaction = Interaction {
  35       itrConfig            ∷ !Config
  36     , itrLocalPort         ∷ !PortNumber
  37     , itrRemoteAddr        ∷ !SockAddr
  38     , itrRemoteCert        ∷ !(Maybe X509)
  39     , itrResourcePath      ∷ !(Maybe [Text])
  40     , itrRequest           ∷ !(TVar (Maybe Request))
  41     , itrResponse          ∷ !(TVar Response)
  42
  43     , itrRequestHasBody    ∷ !(TVar Bool)
  44     , itrRequestIsChunked  ∷ !(TVar Bool)
  45     , itrExpectedContinue  ∷ !(TVar Bool)
  46
  47     , itrReqChunkLength    ∷ !(TVar (Maybe Int))
  48     , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
  49     , itrReqChunkIsOver    ∷ !(TVar Bool)
  50     , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
  51     , itrReqBodyWasteAll   ∷ !(TVar Bool)
  52     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
  53     , itrReceivedBodyLen   ∷ !(TVar Int)
  54
  55     , itrWillReceiveBody   ∷ !(TVar Bool)
  56     , itrWillChunkBody     ∷ !(TVar Bool)
  57     , itrWillDiscardBody   ∷ !(TVar Bool)
  58     , itrWillClose         ∷ !(TVar Bool)
  59
  60     , itrBodyToSend        ∷ !(TMVar Builder)
  61     , itrSentNoBody        ∷ !(TVar Bool)
  62
  63     , itrState             ∷ !(TVar InteractionState)
  64
  65     , itrWroteContinue     ∷ !(TVar Bool)
  66     , itrWroteHeader       ∷ !(TVar Bool)
  67     }
  68
  69 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
  70 -- initial state.
  71 data InteractionState = ExaminingRequest
  72                       | GettingBody
  73                       | DecidingHeader
  74                       | DecidingBody
  75                       | Done
  76                         deriving (Show, Eq, Ord, Enum)
  77
  78 type InteractionQueue = TVar (Seq Interaction)
  79
  80 newInteractionQueue ∷ IO InteractionQueue
  81 newInteractionQueue = newTVarIO S.empty
  82
  83 defaultPageContentType ∷ Ascii
  84 defaultPageContentType = "application/xhtml+xml"
  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 [("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 S.empty
 105          receivedBodyLen    ← newTVarIO 0
 106
 107          willReceiveBody   ← newTVarIO False
 108          willChunkBody     ← newTVarIO False
 109          willDiscardBody   ← newTVarIO False
 110          willClose         ← newTVarIO False
 111
 112          bodyToSend ← newEmptyTMVarIO
 113          sentNoBody ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
 114
 115          state ← newTVarIO ExaminingRequest
 116
 117          wroteContinue ← newTVarIO False
 118          wroteHeader   ← newTVarIO False
 119
 120          return Interaction {
 121                       itrConfig       = conf
 122                     , itrLocalPort    = port
 123                     , itrRemoteAddr   = addr
 124                     , itrRemoteCert   = cert
 125                     , itrResourcePath = Nothing
 126                     , itrRequest      = request
 127                     , itrResponse     = responce
 128
 129                     , itrRequestHasBody   = requestHasBody
 130                     , itrRequestIsChunked = requestIsChunked
 131                     , itrExpectedContinue = expectedContinue
 132
 133                     , itrReqChunkLength    = reqChunkLength
 134                     , itrReqChunkRemaining = reqChunkRemaining
 135                     , itrReqChunkIsOver    = reqChunkIsOver
 136                     , itrReqBodyWanted     = reqBodyWanted
 137                     , itrReqBodyWasteAll   = reqBodyWasteAll
 138                     , itrReceivedBody      = receivedBody
 139                     , itrReceivedBodyLen   = receivedBodyLen
 140
 141                     , itrWillReceiveBody   = willReceiveBody
 142                     , itrWillChunkBody     = willChunkBody
 143                     , itrWillDiscardBody   = willDiscardBody
 144                     , itrWillClose         = willClose
 145
 146                     , itrBodyToSend = bodyToSend
 147                     , itrSentNoBody = sentNoBody
 148
 149                     , itrState = state
 150
 151                     , itrWroteContinue = wroteContinue
 152                     , itrWroteHeader   = wroteHeader
 153                     }
 154
 155 {-
 156 chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
 157 {-# INLINE chunksToLBS #-}
 158 chunksToLBS = LBS.fromChunks ∘ toList
 159
 160 chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
 161 {-# INLINE chunksFromLBS #-}
 162 chunksFromLBS = S.fromList ∘ LBS.toChunks
 163 -}
 164
 165 writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
 166 {-# INLINE writeItr #-}
 167 writeItr accessor a itr
 168     = writeTVar (accessor itr) a
 169
 170 readItr ∷ (Interaction → TVar a) → Interaction → STM a
 171 {-# INLINE readItr #-}
 172 readItr accessor itr
 173     = readTVar (accessor itr)
 174
 175 updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
 176 {-# INLINE updateItr #-}
 177 updateItr accessor updator itr
 178     = do old ← readItr accessor itr
 179          writeItr accessor (updator old) itr