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