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