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     , chunksToLBS
  15     , chunksFromLBS
  16
  17     , writeItr
  18     , readItr
  19     , updateItr
  20     )
  21     where
  22 import Control.Applicative
  23 import Control.Concurrent.STM
  24 import Data.Ascii (Ascii)
  25 import qualified Data.ByteString as BS
  26 import qualified Data.ByteString.Lazy as LBS
  27 import Data.Foldable
  28 import Data.Sequence (Seq)
  29 import qualified Data.Sequence as S
  30 import Network.Socket
  31 import Network.HTTP.Lucu.Config
  32 import Network.HTTP.Lucu.Headers
  33 import Network.HTTP.Lucu.HttpVersion
  34 import Network.HTTP.Lucu.Request
  35 import Network.HTTP.Lucu.Response
  36 import OpenSSL.X509
  37 import Prelude.Unicode
  38
  39 data Interaction = Interaction {
  40       itrConfig            ∷ !Config
  41     , itrLocalPort         ∷ !PortNumber
  42     , itrRemoteAddr        ∷ !SockAddr
  43     , itrRemoteCert        ∷ !(Maybe X509)
  44     , itrResourcePath      ∷ !(Maybe [Ascii])
  45     , itrRequest           ∷ !(TVar (Maybe Request))
  46     , itrResponse          ∷ !(TVar Response)
  47
  48     , itrRequestHasBody    ∷ !(TVar Bool)
  49     , itrRequestIsChunked  ∷ !(TVar Bool)
  50     , itrExpectedContinue  ∷ !(TVar Bool)
  51
  52     , itrReqChunkLength    ∷ !(TVar (Maybe Int))
  53     , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
  54     , itrReqChunkIsOver    ∷ !(TVar Bool)
  55     , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
  56     , itrReqBodyWasteAll   ∷ !(TVar Bool)
  57     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
  58
  59     , itrWillReceiveBody   ∷ !(TVar Bool)
  60     , itrWillChunkBody     ∷ !(TVar Bool)
  61     , itrWillDiscardBody   ∷ !(TVar Bool)
  62     , itrWillClose         ∷ !(TVar Bool)
  63
  64     , itrBodyToSend        ∷ !(TVar (Seq BS.ByteString))
  65     , itrBodyIsNull        ∷ !(TVar Bool)
  66
  67     , itrState             ∷ !(TVar InteractionState)
  68
  69     , itrWroteContinue     ∷ !(TVar Bool)
  70     , itrWroteHeader       ∷ !(TVar Bool)
  71     }
  72
  73 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
  74 -- initial state.
  75 data InteractionState = ExaminingRequest
  76                       | GettingBody
  77                       | DecidingHeader
  78                       | DecidingBody
  79                       | Done
  80                         deriving (Show, Eq, Ord, Enum)
  81
  82 type InteractionQueue = TVar (Seq Interaction)
  83
  84 newInteractionQueue ∷ IO InteractionQueue
  85 newInteractionQueue = newTVarIO S.empty
  86
  87 defaultPageContentType ∷ Ascii
  88 defaultPageContentType = "application/xhtml+xml"
  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 [("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 S.empty
 109
 110          willReceiveBody   ← newTVarIO False
 111          willChunkBody     ← newTVarIO False
 112          willDiscardBody   ← newTVarIO False
 113          willClose         ← newTVarIO False
 114
 115          bodyToSend ← newTVarIO S.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 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 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) → (a → b) → Interaction → STM b
 171 {-# INLINE readItr #-}
 172 readItr accessor reader itr
 173     = reader <$> 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 id itr
 179          writeItr accessor (updator old) itr