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