Network/HTTP/Lucu/Interaction.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , RecordWildCards
   4   , UnicodeSyntax
   5   #-}
   6 module Network.HTTP.Lucu.Interaction
   7     ( Interaction(..)
   8     , InteractionState(..)
   9     , InteractionQueue
  10     , ReceiveBodyRequest(..)
  11     , newInteractionQueue
  12     , newInteraction
  13
  14     , setResponseStatus
  15     )
  16     where
  17 import Blaze.ByteString.Builder (Builder)
  18 import Control.Concurrent.STM
  19 import qualified Data.ByteString as Strict
  20 import Data.Monoid.Unicode
  21 import Data.Sequence (Seq)
  22 import qualified Data.Sequence as S
  23 import Network.Socket
  24 import Network.HTTP.Lucu.Config
  25 import Network.HTTP.Lucu.HttpVersion
  26 import Network.HTTP.Lucu.Preprocess
  27 import Network.HTTP.Lucu.Request
  28 import Network.HTTP.Lucu.Response
  29 import OpenSSL.X509
  30
  31 data Interaction = Interaction {
  32       itrConfig            ∷ !Config
  33     , itrLocalPort         ∷ !PortNumber
  34     , itrRemoteAddr        ∷ !SockAddr
  35     , itrRemoteCert        ∷ !(Maybe X509)
  36     , itrResourcePath      ∷ !(Maybe [Strict.ByteString])
  37     , itrRequest           ∷ !(Maybe Request)
  38
  39     , itrExpectedContinue  ∷ !(Maybe Bool)
  40     , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
  41
  42     , itrReceiveBodyReq    ∷ !(TMVar ReceiveBodyRequest)
  43     , itrReceivedBody      ∷ !(TMVar Strict.ByteString)
  44
  45     , itrResponse          ∷ !(TVar Response)
  46     , itrWillChunkBody     ∷ !(TVar Bool)
  47     , itrWillDiscardBody   ∷ !(TVar Bool)
  48     , itrWillClose         ∷ !(TVar Bool)
  49     , itrResponseHasCType  ∷ !(TVar Bool)
  50     , itrBodyToSend        ∷ !(TMVar Builder)
  51
  52     , itrState             ∷ !(TVar InteractionState)
  53     }
  54
  55 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
  56 -- initial state.
  57 data InteractionState
  58     = ExaminingRequest
  59     | ReceivingBody
  60     | DecidingHeader
  61     | SendingBody
  62     | Done
  63     deriving (Show, Eq, Ord, Enum)
  64
  65 type InteractionQueue = TVar (Seq Interaction)
  66
  67 data ReceiveBodyRequest
  68     = ReceiveBody !Int -- ^ Maximum number of octets to receive.
  69     | WasteAll
  70     deriving (Show, Eq)
  71
  72 newInteractionQueue ∷ IO InteractionQueue
  73 newInteractionQueue = newTVarIO S.empty
  74
  75 newInteraction ∷ Config
  76                → PortNumber
  77                → SockAddr
  78                → Maybe X509
  79                → Either StatusCode Request
  80                → IO Interaction
  81 newInteraction conf@(Config {..}) port addr cert request
  82     = do let ar  = preprocess cnfServerHost port request
  83              res = Response {
  84                      resVersion = HttpVersion 1 1
  85                    , resStatus  = arInitialStatus ar
  86                    , resHeaders = (∅)
  87                    }
  88
  89          receiveBodyReq   ← newEmptyTMVarIO
  90          receivedBody     ← newEmptyTMVarIO
  91
  92          response         ← newTVarIO res
  93          willChunkBody    ← newTVarIO False
  94          willDiscardBody  ← newTVarIO (arWillDiscardBody ar)
  95          willClose        ← newTVarIO (arWillClose       ar)
  96          bodyToSend       ← newEmptyTMVarIO
  97          responseHasCType ← newTVarIO False
  98
  99          state            ← newTVarIO ExaminingRequest
 100
 101          return Interaction {
 102                       itrConfig           = conf
 103                     , itrLocalPort        = port
 104                     , itrRemoteAddr       = addr
 105                     , itrRemoteCert       = cert
 106                     , itrResourcePath     = Nothing
 107                     , itrRequest          = arRequest ar
 108
 109                     , itrExpectedContinue = arExpectedContinue ar
 110                     , itrReqBodyLength    = arReqBodyLength    ar
 111
 112                     , itrReceiveBodyReq   = receiveBodyReq
 113                     , itrReceivedBody     = receivedBody
 114
 115                     , itrResponse         = response
 116                     , itrWillChunkBody    = willChunkBody
 117                     , itrWillDiscardBody  = willDiscardBody
 118                     , itrWillClose        = willClose
 119                     , itrResponseHasCType = responseHasCType
 120                     , itrBodyToSend       = bodyToSend
 121
 122                     , itrState            = state
 123                     }
 124
 125 setResponseStatus ∷ Interaction → StatusCode → STM ()
 126 setResponseStatus (Interaction {..}) sc
 127     = do res ← readTVar itrResponse
 128          let res' = res {
 129                       resStatus = sc
 130                     }
 131          writeTVar itrResponse res'