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     , defaultPageContentType
  13
  14     , setResponseStatus
  15     )
  16     where
  17 import Blaze.ByteString.Builder (Builder)
  18 import Control.Concurrent.STM
  19 import Data.Ascii (Ascii)
  20 import qualified Data.ByteString as BS
  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.Headers
  27 import Network.HTTP.Lucu.HttpVersion
  28 import Network.HTTP.Lucu.Preprocess
  29 import Network.HTTP.Lucu.Request
  30 import Network.HTTP.Lucu.Response
  31 import OpenSSL.X509
  32
  33 data Interaction = Interaction {
  34       itrConfig            ∷ !Config
  35     , itrLocalPort         ∷ !PortNumber
  36     , itrRemoteAddr        ∷ !SockAddr
  37     , itrRemoteCert        ∷ !(Maybe X509)
  38     , itrResourcePath      ∷ !(Maybe [Text])
  39     , itrRequest           ∷ !(Maybe Request)
  40
  41     , itrExpectedContinue  ∷ !(Maybe Bool)
  42     , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
  43
  44     , itrReqBodyWanted     ∷ !(TVar Int)
  45     , itrReqBodyWasteAll   ∷ !(TVar Bool)
  46     , itrReqChunkIsOver    ∷ !(TVar Bool)
  47     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
  48     , itrReceivedBodyLen   ∷ !(TVar Int)
  49
  50     , itrResponse          ∷ !(TVar Response)
  51     , itrWillChunkBody     ∷ !(TVar Bool)
  52     , itrWillDiscardBody   ∷ !(TVar Bool)
  53     , itrWillClose         ∷ !(TVar Bool)
  54     , itrBodyToSend        ∷ !(TMVar Builder)
  55     , itrSentNoBodySoFar   ∷ !(TVar Bool)
  56
  57     , itrState             ∷ !(TVar InteractionState)
  58     }
  59
  60 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
  61 -- initial state.
  62 data InteractionState = ExaminingRequest
  63                       | GettingBody
  64                       | DecidingHeader
  65                       | DecidingBody
  66                       | Done
  67                         deriving (Show, Eq, Ord, Enum)
  68
  69 type InteractionQueue = TVar (Seq Interaction)
  70
  71 newInteractionQueue ∷ IO InteractionQueue
  72 newInteractionQueue = newTVarIO S.empty
  73
  74 defaultPageContentType ∷ Ascii
  75 defaultPageContentType = "application/xhtml+xml"
  76
  77 newInteraction ∷ Config
  78                → PortNumber
  79                → SockAddr
  80                → Maybe X509
  81                → Either StatusCode Request
  82                → IO Interaction
  83 newInteraction conf@(Config {..}) port addr cert request
  84     = do let ar  = preprocess cnfServerHost port request
  85              res = Response {
  86                      resVersion = HttpVersion 1 1
  87                    , resStatus  = arInitialStatus ar
  88                    , resHeaders = singleton "Content-Type" defaultPageContentType
  89                    }
  90
  91          reqBodyWanted   ← newTVarIO 0
  92          reqBodyWasteAll ← newTVarIO False
  93          reqChunkIsOver  ← newTVarIO False
  94          receivedBody    ← newTVarIO S.empty
  95          receivedBodyLen ← newTVarIO 0
  96
  97          response        ← newTVarIO res
  98          willChunkBody   ← newTVarIO False
  99          willDiscardBody ← newTVarIO False
 100          willClose       ← newTVarIO False
 101          bodyToSend      ← newEmptyTMVarIO
 102          sentNoBodySoFar ← newTVarIO True
 103
 104          state           ← newTVarIO ExaminingRequest
 105
 106          return Interaction {
 107                       itrConfig       = conf
 108                     , itrLocalPort    = port
 109                     , itrRemoteAddr   = addr
 110                     , itrRemoteCert   = cert
 111                     , itrResourcePath = Nothing
 112                     , itrRequest      = arRequest ar
 113
 114                     , itrExpectedContinue = arExpectedContinue ar
 115                     , itrReqBodyLength    = arReqBodyLength    ar
 116
 117                     , itrReqBodyWanted    = reqBodyWanted
 118                     , itrReqBodyWasteAll  = reqBodyWasteAll
 119                     , itrReqChunkIsOver   = reqChunkIsOver
 120                     , itrReceivedBody     = receivedBody
 121                     , itrReceivedBodyLen  = receivedBodyLen
 122
 123                     , itrResponse         = response
 124                     , itrWillChunkBody    = willChunkBody
 125                     , itrWillDiscardBody  = willDiscardBody
 126                     , itrWillClose        = willClose
 127                     , itrBodyToSend       = bodyToSend
 128                     , itrSentNoBodySoFar  = sentNoBodySoFar
 129
 130                     , itrState            = state
 131                     }
 132
 133 setResponseStatus ∷ Interaction → StatusCode → STM ()
 134 setResponseStatus (Interaction {..}) sc
 135     = do res ← readTVar itrResponse
 136          let res' = res {
 137                       resStatus = sc
 138                     }
 139          writeTVar itrResponse res'