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     , newInteractionQueue
  11     , newInteraction
  12
  13     , setResponseStatus
  14     )
  15     where
  16 import Blaze.ByteString.Builder (Builder)
  17 import Control.Concurrent.STM
  18 import qualified Data.ByteString as BS
  19 import Data.Monoid.Unicode
  20 import Data.Sequence (Seq)
  21 import qualified Data.Sequence as S
  22 import Data.Text (Text)
  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 [Text])
  37     , itrRequest           ∷ !(Maybe Request)
  38
  39     , itrExpectedContinue  ∷ !(Maybe Bool)
  40     , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
  41
  42     , itrReqBodyWanted     ∷ !(TVar Int)
  43     , itrReqBodyWasteAll   ∷ !(TVar Bool)
  44     , itrReqChunkIsOver    ∷ !(TVar Bool)
  45     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
  46     , itrReceivedBodyLen   ∷ !(TVar Int)
  47
  48     , itrResponse          ∷ !(TVar Response)
  49     , itrWillChunkBody     ∷ !(TVar Bool)
  50     , itrWillDiscardBody   ∷ !(TVar Bool)
  51     , itrWillClose         ∷ !(TVar Bool)
  52     , itrResponseHasCType  ∷ !(TVar Bool)
  53     , itrBodyToSend        ∷ !(TMVar Builder)
  54
  55     , itrState             ∷ !(TVar InteractionState)
  56     }
  57
  58 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
  59 -- initial state.
  60 data InteractionState = ExaminingRequest
  61                       | GettingBody
  62                       | DecidingHeader
  63                       | DecidingBody
  64                       | Done
  65                         deriving (Show, Eq, Ord, Enum)
  66
  67 type InteractionQueue = TVar (Seq Interaction)
  68
  69 newInteractionQueue ∷ IO InteractionQueue
  70 newInteractionQueue = newTVarIO S.empty
  71
  72 newInteraction ∷ Config
  73                → PortNumber
  74                → SockAddr
  75                → Maybe X509
  76                → Either StatusCode Request
  77                → IO Interaction
  78 newInteraction conf@(Config {..}) port addr cert request
  79     = do let ar  = preprocess cnfServerHost port request
  80              res = Response {
  81                      resVersion = HttpVersion 1 1
  82                    , resStatus  = arInitialStatus ar
  83                    , resHeaders = (∅)
  84                    }
  85
  86          reqBodyWanted   ← newTVarIO 0
  87          reqBodyWasteAll ← newTVarIO False
  88          reqChunkIsOver  ← newTVarIO False
  89          receivedBody    ← newTVarIO S.empty
  90          receivedBodyLen ← newTVarIO 0
  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                     , itrReqBodyWanted    = reqBodyWanted
 113                     , itrReqBodyWasteAll  = reqBodyWasteAll
 114                     , itrReqChunkIsOver   = reqChunkIsOver
 115                     , itrReceivedBody     = receivedBody
 116                     , itrReceivedBodyLen  = receivedBodyLen
 117
 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'