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