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     , readItrF
  17     , updateItr
  18     , updateItrF
  19     )
  20     where
  21 import Control.Applicative
  22 import Control.Concurrent.STM
  23 import Data.Ascii (Ascii)
  24 import qualified Data.ByteString as BS
  25 import Data.Sequence (Seq)
  26 import qualified Data.Sequence as S
  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 import Prelude.Unicode
  35
  36 data Interaction = Interaction {
  37       itrConfig            ∷ !Config
  38     , itrLocalPort         ∷ !PortNumber
  39     , itrRemoteAddr        ∷ !SockAddr
  40     , itrRemoteCert        ∷ !(Maybe X509)
  41     , itrResourcePath      ∷ !(Maybe [Ascii])
  42     , itrRequest           ∷ !(TVar (Maybe Request))
  43     , itrResponse          ∷ !(TVar Response)
  44
  45     , itrRequestHasBody    ∷ !(TVar Bool)
  46     , itrRequestIsChunked  ∷ !(TVar Bool)
  47     , itrExpectedContinue  ∷ !(TVar Bool)
  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 (Seq BS.ByteString))
  55
  56     , itrWillReceiveBody   ∷ !(TVar Bool)
  57     , itrWillChunkBody     ∷ !(TVar Bool)
  58     , itrWillDiscardBody   ∷ !(TVar Bool)
  59     , itrWillClose         ∷ !(TVar Bool)
  60
  61     , itrBodyToSend        ∷ !(TVar (Seq BS.ByteString))
  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
 107          willReceiveBody   ← newTVarIO False
 108          willChunkBody     ← newTVarIO False
 109          willDiscardBody   ← newTVarIO False
 110          willClose         ← newTVarIO False
 111
 112          bodyToSend ← newTVarIO S.empty
 113          bodyIsNull ← 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
 140                     , itrWillReceiveBody   = willReceiveBody
 141                     , itrWillChunkBody     = willChunkBody
 142                     , itrWillDiscardBody   = willDiscardBody
 143                     , itrWillClose         = willClose
 144
 145                     , itrBodyToSend = bodyToSend
 146                     , itrBodyIsNull = bodyIsNull
 147
 148                     , itrState = state
 149
 150                     , itrWroteContinue = wroteContinue
 151                     , itrWroteHeader   = wroteHeader
 152                     }
 153
 154 writeItr ∷ Interaction → (Interaction → TVar a) → a → STM ()
 155 {-# INLINE writeItr #-}
 156 writeItr itr accessor
 157     = writeTVar (accessor itr)
 158
 159 readItr ∷ Interaction → (Interaction → TVar a) → (a → b) → STM b
 160 {-# INLINE readItr #-}
 161 readItr itr accessor reader
 162     = reader <$> readTVar (accessor itr)
 163
 164 readItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → b) → STM (f b)
 165 {-# INLINE readItrF #-}
 166 readItrF itr accessor reader
 167     = readItr itr accessor (fmap reader)
 168
 169 updateItr ∷ Interaction → (Interaction → TVar a) → (a → a) → STM ()
 170 {-# INLINE updateItr #-}
 171 updateItr itr accessor updator
 172     = do old ← readItr itr accessor id
 173          writeItr itr accessor (updator old)
 174
 175 updateItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → a) → STM ()
 176 {-# INLINE updateItrF #-}
 177 updateItrF itr accessor
 178     = updateItr itr accessor ∘ fmap