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       , seiWillClose        ∷ !Bool
 115       , seiBodyToSend       ∷ !Builder
 116       }
 117     deriving Typeable
 118 instance Interaction SemanticallyInvalidInteraction
 119
 120 mkSemanticallyInvalidInteraction ∷ Config
 121                                  → AugmentedRequest
 122                                  → IO SemanticallyInvalidInteraction
 123 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
 124     = do date ← getCurrentDate
 125          let res  = setHeader "Server"       cnfServerSoftware      $
 126                     setHeader "Date"         date                   $
 127                     setHeader "Content-Type" defaultPageContentType $
 128                     ( if arWillChunkBody
 129                       then setHeader "Transfer-Encoding" "chunked"
 130                       else id
 131                     ) $
 132                     ( if arWillClose
 133                       then setHeader "Connection" "close"
 134                       else id
 135                     ) $
 136                     emptyResponse arInitialStatus
 137              body = defaultPageForResponse config (Just arRequest) res
 138          return SEI {
 139                   seiRequest          = arRequest
 140                 , seiExpectedContinue = arExpectedContinue
 141                 , seiReqBodyLength    = arReqBodyLength
 142
 143                 , seiResponse         = res
 144                 , seiWillChunkBody    = arWillChunkBody
 145                 , seiWillClose        = arWillClose
 146                 , seiBodyToSend       = body
 147                 }
 148
 149 -- |'NormalInteraction' is an 'Interaction' with a semantically
 150 -- correct 'Request'.
 151 data NormalInteraction
 152     = NI {
 153         niConfig           ∷ !Config
 154       , niRemoteAddr       ∷ !SockAddr
 155 #if defined(HAVE_SSL)
 156       , niRemoteCert       ∷ !(Maybe X509)
 157 #endif
 158       , niRequest          ∷ !Request
 159       , niResourcePath     ∷ !Path
 160       , niExpectedContinue ∷ !Bool
 161       , niReqBodyLength    ∷ !(Maybe RequestBodyLength)
 162
 163       , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
 164       , niReceivedBody     ∷ !(TMVar ByteString)
 165
 166       , niResponse         ∷ !(TVar Response)
 167       , niSendContinue     ∷ !(TMVar Bool)
 168       , niWillChunkBody    ∷ !Bool
 169       , niWillClose        ∷ !(TVar Bool)
 170       , niResponseHasCType ∷ !(TVar Bool)
 171       -- FIXME: use TBChan Builder (in stm-chans package)
 172       , niBodyToSend       ∷ !(TMVar Builder)
 173
 174       , niState            ∷ !(TVar InteractionState)
 175       }
 176     deriving Typeable
 177 instance Interaction NormalInteraction
 178
 179 data ReceiveBodyRequest
 180     = ReceiveBody !Int -- ^ Maximum number of octets to receive.
 181     | WasteAll
 182     deriving (Show, Eq)
 183
 184 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
 185 -- initial state.
 186 data InteractionState
 187     = ExaminingRequest
 188     | ReceivingBody
 189     | DecidingHeader
 190     | SendingBody
 191     | Done
 192     deriving (Show, Eq, Ord, Enum)
 193
 194 mkNormalInteraction ∷ Config
 195                     → SockAddr
 196 #if defined(HAVE_SSL)
 197                     → Maybe X509
 198 #endif
 199                     → AugmentedRequest
 200                     → Path
 201                     → IO NormalInteraction
 202 #if defined(HAVE_SSL)
 203 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
 204 #else
 205 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
 206 #endif
 207     = do receiveBodyReq   ← newEmptyTMVarIO
 208          receivedBody     ← newEmptyTMVarIO
 209
 210          response         ← newTVarIO $ emptyResponse arInitialStatus
 211          sendContinue     ← newEmptyTMVarIO
 212          willClose        ← newTVarIO arWillClose
 213          responseHasCType ← newTVarIO False
 214          bodyToSend       ← newEmptyTMVarIO
 215
 216          state            ← newTVarIO ExaminingRequest
 217
 218          return NI {
 219                   niConfig           = config
 220                 , niRemoteAddr       = remoteAddr
 221 #if defined(HAVE_SSL)
 222                 , niRemoteCert       = remoteCert
 223 #endif
 224                 , niRequest          = arRequest
 225                 , niResourcePath     = rsrcPath
 226                 , niExpectedContinue = arExpectedContinue
 227                 , niReqBodyLength    = arReqBodyLength
 228
 229                 , niReceiveBodyReq   = receiveBodyReq
 230                 , niReceivedBody     = receivedBody
 231
 232                 , niResponse         = response
 233                 , niSendContinue     = sendContinue
 234                 , niWillChunkBody    = arWillChunkBody
 235                 , niWillClose        = willClose
 236                 , niResponseHasCType = responseHasCType
 237                 , niBodyToSend       = bodyToSend
 238
 239                 , niState            = state
 240                 }
 241
 242 type InteractionQueue = TVar (Seq SomeInteraction)
 243
 244 mkInteractionQueue ∷ IO InteractionQueue
 245 {-# INLINE mkInteractionQueue #-}
 246 mkInteractionQueue = newTVarIO (∅)
 247
 248 getCurrentDate ∷ IO Ascii
 249 {-# INLINE getCurrentDate #-}
 250 getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime