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 conf@(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 = defaultPageForResponse conf 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                     ( if arWillChunkBody
 127                       then setHeader "Transfer-Encoding" "chunked"
 128                       else id
 129                     ) $
 130                     ( if arWillClose
 131                       then setHeader "Connection" "close"
 132                       else id
 133                     ) $
 134                     emptyResponse arInitialStatus
 135              body = defaultPageForResponse config (Just arRequest) res
 136          return SEI {
 137                   seiRequest          = arRequest
 138                 , seiExpectedContinue = arExpectedContinue
 139                 , seiReqBodyLength    = arReqBodyLength
 140
 141                 , seiResponse         = res
 142                 , seiWillChunkBody    = arWillChunkBody
 143                 , seiWillDiscardBody  = arWillDiscardBody
 144                 , seiWillClose        = arWillClose
 145                 , seiBodyToSend       = body
 146                 }
 147
 148 -- |'NormalInteraction' is an 'Interaction' with a semantically
 149 -- correct 'Request'.
 150 data NormalInteraction
 151     = NI {
 152         niConfig           ∷ !Config
 153       , niRemoteAddr       ∷ !SockAddr
 154 #if defined(HAVE_SSL)
 155       , niRemoteCert       ∷ !(Maybe X509)
 156 #endif
 157       , niRequest          ∷ !Request
 158       , niResourcePath     ∷ !Path
 159       , niExpectedContinue ∷ !Bool
 160       , niReqBodyLength    ∷ !(Maybe RequestBodyLength)
 161
 162       , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
 163       , niReceivedBody     ∷ !(TMVar ByteString)
 164
 165       , niResponse         ∷ !(TVar Response)
 166       , niSendContinue     ∷ !(TMVar Bool)
 167       , niWillChunkBody    ∷ !Bool
 168       , niWillDiscardBody  ∷ !(TVar 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          willDiscardBody  ← newTVarIO arWillDiscardBody
 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                 , niWillDiscardBody  = willDiscardBody
 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 mkInteractionQueue = newTVarIO (∅)
 248
 249 getCurrentDate ∷ IO Ascii
 250 getCurrentDate = HTTP.toAscii <$> getCurrentTime