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     , itrSendContinue      ∷ !(TMVar Bool)
  46     , itrResponse          ∷ !(TVar Response)
  47     , itrWillChunkBody     ∷ !(TVar Bool)
  48     , itrWillDiscardBody   ∷ !(TVar Bool)
  49     , itrWillClose         ∷ !(TVar Bool)
  50     , itrResponseHasCType  ∷ !(TVar Bool)
  51     , itrBodyToSend        ∷ !(TMVar Builder)
  52
  53     , itrState             ∷ !(TVar InteractionState)
  54     }
  55
  56 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
  57 -- initial state.
  58 data InteractionState
  59     = ExaminingRequest
  60     | ReceivingBody
  61     | DecidingHeader
  62     | SendingBody
  63     | Done
  64     deriving (Show, Eq, Ord, Enum)
  65
  66 type InteractionQueue = TVar (Seq Interaction)
  67
  68 data ReceiveBodyRequest
  69     = ReceiveBody !Int -- ^ Maximum number of octets to receive.
  70     | WasteAll
  71     deriving (Show, Eq)
  72
  73 newInteractionQueue ∷ IO InteractionQueue
  74 newInteractionQueue = newTVarIO S.empty
  75
  76 newInteraction ∷ Config
  77                → PortNumber
  78                → SockAddr
  79                → Maybe X509
  80                → Either StatusCode Request
  81                → IO Interaction
  82 newInteraction conf@(Config {..}) port addr cert request
  83     = do let ar  = preprocess cnfServerHost port request
  84              res = Response {
  85                      resVersion = HttpVersion 1 1
  86                    , resStatus  = arInitialStatus ar
  87                    , resHeaders = (∅)
  88                    }
  89
  90          receiveBodyReq   ← newEmptyTMVarIO
  91          receivedBody     ← newEmptyTMVarIO
  92
  93          sendContinue     ← newEmptyTMVarIO
  94          response         ← newTVarIO res
  95          willChunkBody    ← newTVarIO False
  96          willDiscardBody  ← newTVarIO (arWillDiscardBody ar)
  97          willClose        ← newTVarIO (arWillClose       ar)
  98          bodyToSend       ← newEmptyTMVarIO
  99          responseHasCType ← newTVarIO False
 100
 101          state            ← newTVarIO ExaminingRequest
 102
 103          return Interaction {
 104                       itrConfig           = conf
 105                     , itrLocalPort        = port
 106                     , itrRemoteAddr       = addr
 107                     , itrRemoteCert       = cert
 108                     , itrResourcePath     = Nothing
 109                     , itrRequest          = arRequest ar
 110
 111                     , itrExpectedContinue = arExpectedContinue ar
 112                     , itrReqBodyLength    = arReqBodyLength    ar
 113
 114                     , itrReceiveBodyReq   = receiveBodyReq
 115                     , itrReceivedBody     = receivedBody
 116
 117                     , itrSendContinue     = sendContinue
 118                     , itrResponse         = response
 119                     , itrWillChunkBody    = willChunkBody
 120                     , itrWillDiscardBody  = willDiscardBody
 121                     , itrWillClose        = willClose
 122                     , itrResponseHasCType = responseHasCType
 123                     , itrBodyToSend       = bodyToSend
 124
 125                     , itrState            = state
 126                     }
 127
 128 setResponseStatus ∷ Interaction → StatusCode → STM ()
 129 setResponseStatus (Interaction {..}) sc
 130     = do res ← readTVar itrResponse
 131          let res' = res {
 132                       resStatus = sc
 133                     }
 134          writeTVar itrResponse res'