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     , GetBodyRequest(..)
  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 Data.Text (Text)
  24 import Network.Socket
  25 import Network.HTTP.Lucu.Config
  26 import Network.HTTP.Lucu.HttpVersion
  27 import Network.HTTP.Lucu.Preprocess
  28 import Network.HTTP.Lucu.Request
  29 import Network.HTTP.Lucu.Response
  30 import OpenSSL.X509
  31
  32 data Interaction = Interaction {
  33       itrConfig            ∷ !Config
  34     , itrLocalPort         ∷ !PortNumber
  35     , itrRemoteAddr        ∷ !SockAddr
  36     , itrRemoteCert        ∷ !(Maybe X509)
  37     , itrResourcePath      ∷ !(Maybe [Text])
  38     , itrRequest           ∷ !(Maybe Request)
  39
  40     , itrExpectedContinue  ∷ !(Maybe Bool)
  41     , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
  42
  43     , itrGetBodyRequest    ∷ !(TMVar GetBodyRequest)
  44     , itrGotBody           ∷ !(TMVar Strict.ByteString)
  45
  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     | GettingBody
  61     | DecidingHeader
  62     | DecidingBody
  63     | Done
  64     deriving (Show, Eq, Ord, Enum)
  65
  66 type InteractionQueue = TVar (Seq Interaction)
  67
  68 data GetBodyRequest
  69     = GetBody !Int -- ^ Maximum number of bytes.
  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          getBodyRequest   ← newEmptyTMVarIO
  91          gotBody          ← newEmptyTMVarIO
  92
  93          response         ← newTVarIO res
  94          willChunkBody    ← newTVarIO False
  95          willDiscardBody  ← newTVarIO (arWillDiscardBody ar)
  96          willClose        ← newTVarIO (arWillClose       ar)
  97          bodyToSend       ← newEmptyTMVarIO
  98          responseHasCType ← newTVarIO False
  99
 100          state            ← newTVarIO ExaminingRequest
 101
 102          return Interaction {
 103                       itrConfig           = conf
 104                     , itrLocalPort        = port
 105                     , itrRemoteAddr       = addr
 106                     , itrRemoteCert       = cert
 107                     , itrResourcePath     = Nothing
 108                     , itrRequest          = arRequest ar
 109
 110                     , itrExpectedContinue = arExpectedContinue ar
 111                     , itrReqBodyLength    = arReqBodyLength    ar
 112
 113                     , itrGetBodyRequest   = getBodyRequest
 114                     , itrGotBody          = gotBody
 115
 116                     , itrResponse         = response
 117                     , itrWillChunkBody    = willChunkBody
 118                     , itrWillDiscardBody  = willDiscardBody
 119                     , itrWillClose        = willClose
 120                     , itrResponseHasCType = responseHasCType
 121                     , itrBodyToSend       = bodyToSend
 122
 123                     , itrState            = state
 124                     }
 125
 126 setResponseStatus ∷ Interaction → StatusCode → STM ()
 127 setResponseStatus (Interaction {..}) sc
 128     = do res ← readTVar itrResponse
 129          let res' = res {
 130                       resStatus = sc
 131                     }
 132          writeTVar itrResponse res'