Network/HTTP/Lucu/Interaction.hs

   1 {-# LANGUAGE
   2     CPP
   3   , DeriveDataTypeable
   4   , ExistentialQuantification
   5   , OverloadedStrings
   6   , RecordWildCards
   7   , UnicodeSyntax
   8   #-}
   9 module Network.HTTP.Lucu.Interaction
  10     ( Interaction(..)
  11     , SomeInteraction(..)
  12     , EndOfInteraction(..)
  13
  14     , SyntacticallyInvalidInteraction(..)
  15     , mkSyntacticallyInvalidInteraction
  16
  17     , SemanticallyInvalidInteraction(..)
  18     , mkSemanticallyInvalidInteraction
  19
  20     , NormalInteraction(..)
  21     , InteractionState(..)
  22     , ReceiveBodyRequest(..)
  23     , mkNormalInteraction
  24
  25     , InteractionQueue
  26     , mkInteractionQueue
  27
  28     , getCurrentDate
  29     )
  30     where
  31 import Blaze.ByteString.Builder (Builder)
  32 import Control.Applicative
  33 import Control.Concurrent.STM
  34 import Data.Ascii (Ascii)
  35 import qualified Data.ByteString as Strict
  36 import Data.Monoid.Unicode
  37 import Data.Sequence (Seq)
  38 import Data.Time
  39 import qualified Data.Time.HTTP as HTTP
  40 import Data.Typeable
  41 import Network.Socket
  42 import Network.HTTP.Lucu.Config
  43 import Network.HTTP.Lucu.DefaultPage
  44 import Network.HTTP.Lucu.Headers
  45 import Network.HTTP.Lucu.Preprocess
  46 import Network.HTTP.Lucu.Request
  47 import Network.HTTP.Lucu.Response
  48 #if defined(HAVE_SSL)
  49 import OpenSSL.X509
  50 #endif
  51
  52 class Typeable i ⇒ Interaction i where
  53     toInteraction ∷ i → SomeInteraction
  54     toInteraction = SomeInteraction
  55
  56     fromInteraction ∷ SomeInteraction → Maybe i
  57     fromInteraction (SomeInteraction i) = cast i
  58
  59 data SomeInteraction
  60     = ∀i. Interaction i ⇒ SomeInteraction !i
  61     deriving Typeable
  62
  63 instance Interaction SomeInteraction where
  64     toInteraction   = id
  65     fromInteraction = Just
  66
  67 -- |'EndOfInteraction' is an 'Interaction' indicating the end of
  68 -- (possibly pipelined) requests. The connection has already been
  69 -- closed so no need to reply anything.
  70 data EndOfInteraction = EndOfInteraction
  71     deriving Typeable
  72 instance Interaction EndOfInteraction
  73
  74 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
  75 -- a syntactically valid 'Request'. The response code will always be
  76 -- 'BadRequest'.
  77 data SyntacticallyInvalidInteraction
  78     = SYI {
  79         syiResponse   ∷ !Response
  80       , syiBodyToSend ∷ !Builder
  81       }
  82     deriving Typeable
  83 instance Interaction SyntacticallyInvalidInteraction
  84
  85 mkSyntacticallyInvalidInteraction ∷ Config
  86                                   → IO SyntacticallyInvalidInteraction
  87 mkSyntacticallyInvalidInteraction config@(Config {..})
  88     = do date ← getCurrentDate
  89          let res  = setHeader "Server"       cnfServerSoftware      $
  90                     setHeader "Date"         date                   $
  91                     setHeader "Content-Type" defaultPageContentType $
  92                     emptyResponse BadRequest
  93              body = getDefaultPage config Nothing res
  94          return SYI {
  95                   syiResponse   = res
  96                 , syiBodyToSend = body
  97                 }
  98
  99 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
 100 -- semantically valid 'Request'. The response code will always satisfy
 101 -- 'isError'.
 102 data SemanticallyInvalidInteraction
 103     = SEI {
 104         seiRequest          ∷ !Request
 105       , seiExpectedContinue ∷ !Bool
 106       , seiReqBodyLength    ∷ !(Maybe RequestBodyLength)
 107
 108       , seiResponse         ∷ !Response
 109       , seiWillChunkBody    ∷ !Bool
 110       , seiWillDiscardBody  ∷ !Bool
 111       , seiWillClose        ∷ !Bool
 112       , seiBodyToSend       ∷ !Builder
 113       }
 114     deriving Typeable
 115 instance Interaction SemanticallyInvalidInteraction
 116
 117 mkSemanticallyInvalidInteraction ∷ Config
 118                                  → AugmentedRequest
 119                                  → IO SemanticallyInvalidInteraction
 120 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
 121     = do date ← getCurrentDate
 122          let res  = setHeader "Server"       cnfServerSoftware      $
 123                     setHeader "Date"         date                   $
 124                     setHeader "Content-Type" defaultPageContentType $
 125                     emptyResponse arInitialStatus
 126              body = getDefaultPage config (Just arRequest) res
 127          return SEI {
 128                   seiRequest          = arRequest
 129                 , seiExpectedContinue = arExpectedContinue
 130                 , seiReqBodyLength    = arReqBodyLength
 131
 132                 , seiResponse         = res
 133                 , seiWillChunkBody    = arWillChunkBody
 134                 , seiWillDiscardBody  = arWillDiscardBody
 135                 , seiWillClose        = arWillClose
 136                 , seiBodyToSend       = body
 137                 }
 138
 139 -- |'NormalInteraction' is an 'Interaction' with a semantically
 140 -- correct 'Request'.
 141 data NormalInteraction
 142     = NI {
 143         niConfig           ∷ !Config
 144       , niRemoteAddr       ∷ !SockAddr
 145 #if defined(HAVE_SSL)
 146       , niRemoteCert       ∷ !(Maybe X509)
 147 #endif
 148       , niRequest          ∷ !Request
 149       , niResourcePath     ∷ ![Strict.ByteString]
 150       , niExpectedContinue ∷ !Bool
 151       , niReqBodyLength    ∷ !(Maybe RequestBodyLength)
 152
 153       , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
 154       , niReceivedBody     ∷ !(TMVar Strict.ByteString)
 155
 156       , niResponse         ∷ !(TVar Response)
 157       , niSendContinue     ∷ !(TMVar Bool)
 158       , niWillChunkBody    ∷ !Bool
 159       , niWillDiscardBody  ∷ !(TVar Bool)
 160       , niWillClose        ∷ !(TVar Bool)
 161       , niResponseHasCType ∷ !(TVar Bool)
 162       -- FIXME: use TBChan Builder (in stm-chans package)
 163       , niBodyToSend       ∷ !(TMVar Builder)
 164
 165       , niState            ∷ !(TVar InteractionState)
 166       }
 167     deriving Typeable
 168 instance Interaction NormalInteraction
 169
 170 data ReceiveBodyRequest
 171     = ReceiveBody !Int -- ^ Maximum number of octets to receive.
 172     | WasteAll
 173     deriving (Show, Eq)
 174
 175 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
 176 -- initial state.
 177 data InteractionState
 178     = ExaminingRequest
 179     | ReceivingBody
 180     | DecidingHeader
 181     | SendingBody
 182     | Done
 183     deriving (Show, Eq, Ord, Enum)
 184
 185 mkNormalInteraction ∷ Config
 186                     → SockAddr
 187 #if defined(HAVE_SSL)
 188                     → Maybe X509
 189 #endif
 190                     → AugmentedRequest
 191                     → [Strict.ByteString]
 192                     → IO NormalInteraction
 193 #if defined(HAVE_SSL)
 194 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
 195 #else
 196 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
 197 #endif
 198     = do receiveBodyReq   ← newEmptyTMVarIO
 199          receivedBody     ← newEmptyTMVarIO
 200
 201          response         ← newTVarIO $ emptyResponse arInitialStatus
 202          sendContinue     ← newEmptyTMVarIO
 203          willDiscardBody  ← newTVarIO arWillDiscardBody
 204          willClose        ← newTVarIO arWillClose
 205          responseHasCType ← newTVarIO False
 206          bodyToSend       ← newEmptyTMVarIO
 207
 208          state            ← newTVarIO ExaminingRequest
 209
 210          return NI {
 211                   niConfig           = config
 212                 , niRemoteAddr       = remoteAddr
 213 #if defined(HAVE_SSL)
 214                 , niRemoteCert       = remoteCert
 215 #endif
 216                 , niRequest          = arRequest
 217                 , niResourcePath     = rsrcPath
 218                 , niExpectedContinue = arExpectedContinue
 219                 , niReqBodyLength    = arReqBodyLength
 220
 221                 , niReceiveBodyReq   = receiveBodyReq
 222                 , niReceivedBody     = receivedBody
 223
 224                 , niResponse         = response
 225                 , niSendContinue     = sendContinue
 226                 , niWillChunkBody    = arWillChunkBody
 227                 , niWillDiscardBody  = willDiscardBody
 228                 , niWillClose        = willClose
 229                 , niResponseHasCType = responseHasCType
 230                 , niBodyToSend       = bodyToSend
 231
 232                 , niState            = state
 233                 }
 234
 235 type InteractionQueue = TVar (Seq SomeInteraction)
 236
 237 mkInteractionQueue ∷ IO InteractionQueue
 238 mkInteractionQueue = newTVarIO (∅)
 239
 240 getCurrentDate ∷ IO Ascii
 241 getCurrentDate = HTTP.toAscii <$> getCurrentTime