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