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
  13     , SyntacticallyInvalidInteraction(..)
  14     , mkSyntacticallyInvalidInteraction
  15
  16     , SemanticallyInvalidInteraction(..)
  17     , mkSemanticallyInvalidInteraction
  18
  19     , NormalInteraction(..)
  20     , InteractionState(..)
  21     , ReceiveBodyRequest(..)
  22     , mkNormalInteraction
  23
  24     , InteractionQueue
  25     , mkInteractionQueue
  26
  27     , setResponseStatus
  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 qualified Data.ByteString as Strict
  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 #if defined(HAVE_SSL)
  49 import OpenSSL.X509
  50 #endif
  51
  52 class Typeable i ⇒ Interaction i where
  53     toInteraction ∷ i → SomeInteraction
  54     toInteraction = SomeInteraction
  55
  56     fromInteraction ∷ SomeInteraction → Maybe i
  57     fromInteraction (SomeInteraction i) = cast i
  58
  59 data SomeInteraction
  60     = ∀i. Interaction i ⇒ SomeInteraction !i
  61     deriving Typeable
  62
  63 instance Interaction SomeInteraction where
  64     toInteraction   = id
  65     fromInteraction = Just
  66
  67 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
  68 -- a syntactically valid 'Request'. The response code will always be
  69 -- 'BadRequest'.
  70 data SyntacticallyInvalidInteraction
  71     = SYI {
  72         syiResponse   ∷ !Response
  73       , syiBodyToSend ∷ !Builder
  74       }
  75     deriving Typeable
  76 instance Interaction SyntacticallyInvalidInteraction
  77
  78 mkSyntacticallyInvalidInteraction ∷ Config
  79                                   → IO SyntacticallyInvalidInteraction
  80 mkSyntacticallyInvalidInteraction config@(Config {..})
  81     = do date ← getCurrentDate
  82          let res  = setHeader "Server"       cnfServerSoftware      $
  83                     setHeader "Date"         date                   $
  84                     setHeader "Content-Type" defaultPageContentType $
  85                     emptyResponse BadRequest
  86              body = getDefaultPage config Nothing res
  87          return SYI {
  88                   syiResponse   = res
  89                 , syiBodyToSend = body
  90                 }
  91
  92 -- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
  93 -- semantically valid 'Request'. The response code will always satisfy
  94 -- 'isError'.
  95 data SemanticallyInvalidInteraction
  96     = SEI {
  97         seiRequest          ∷ !Request
  98       , seiExpectedContinue ∷ !Bool
  99       , seiReqBodyLength    ∷ !(Maybe RequestBodyLength)
 100
 101       , seiResponse         ∷ !Response
 102       , seiWillChunkBody    ∷ !Bool
 103       , seiWillDiscardBody  ∷ !Bool
 104       , seiWillClose        ∷ !Bool
 105       , seiBodyToSend       ∷ !Builder
 106       }
 107     deriving Typeable
 108 instance Interaction SemanticallyInvalidInteraction
 109
 110 mkSemanticallyInvalidInteraction ∷ Config
 111                                  → AugmentedRequest
 112                                  → IO SemanticallyInvalidInteraction
 113 mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
 114     = do date ← getCurrentDate
 115          let res  = setHeader "Server"       cnfServerSoftware      $
 116                     setHeader "Date"         date                   $
 117                     setHeader "Content-Type" defaultPageContentType $
 118                     emptyResponse arInitialStatus
 119              body = getDefaultPage config (Just arRequest) res
 120          return SEI {
 121                   seiRequest          = arRequest
 122                 , seiExpectedContinue = arExpectedContinue
 123                 , seiReqBodyLength    = arReqBodyLength
 124
 125                 , seiResponse         = res
 126                 , seiWillChunkBody    = arWillChunkBody
 127                 , seiWillDiscardBody  = arWillDiscardBody
 128                 , seiWillClose        = arWillClose
 129                 , seiBodyToSend       = body
 130                 }
 131
 132 -- |'NormalInteraction' is an 'Interaction' with a semantically
 133 -- correct 'Request'.
 134 data NormalInteraction
 135     = NI {
 136         niConfig           ∷ !Config
 137       , niRemoteAddr       ∷ !SockAddr
 138 #if defined(HAVE_SSL)
 139       , niRemoteCert       ∷ !(Maybe X509)
 140 #endif
 141       , niRequest          ∷ !Request
 142       , niResourcePath     ∷ ![Strict.ByteString]
 143       , niExpectedContinue ∷ !Bool
 144       , niReqBodyLength    ∷ !(Maybe RequestBodyLength)
 145
 146       , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
 147       , niReceivedBody     ∷ !(TMVar Strict.ByteString)
 148
 149       , niResponse         ∷ !(TVar Response)
 150       , niSendContinue     ∷ !(TMVar Bool)
 151       , niWillChunkBody    ∷ !Bool
 152       , niWillDiscardBody  ∷ !(TVar Bool)
 153       , niWillClose        ∷ !(TVar Bool)
 154       , niResponseHasCType ∷ !(TVar Bool)
 155       -- FIXME: use TBChan Builder (in stm-chans package)
 156       , niBodyToSend       ∷ !(TMVar Builder)
 157
 158       , niState            ∷ !(TVar InteractionState)
 159       }
 160     deriving Typeable
 161 instance Interaction NormalInteraction
 162
 163 data ReceiveBodyRequest
 164     = ReceiveBody !Int -- ^ Maximum number of octets to receive.
 165     | WasteAll
 166     deriving (Show, Eq)
 167
 168 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
 169 -- initial state.
 170 data InteractionState
 171     = ExaminingRequest
 172     | ReceivingBody
 173     | DecidingHeader
 174     | SendingBody
 175     | Done
 176     deriving (Show, Eq, Ord, Enum)
 177
 178 mkNormalInteraction ∷ Config
 179                     → SockAddr
 180 #if defined(HAVE_SSL)
 181                     → Maybe X509
 182 #endif
 183                     → AugmentedRequest
 184                     → [Strict.ByteString]
 185                     → IO NormalInteraction
 186 #if defined(HAVE_SSL)
 187 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
 188 #else
 189 mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
 190 #endif
 191     = do receiveBodyReq   ← newEmptyTMVarIO
 192          receivedBody     ← newEmptyTMVarIO
 193
 194          response         ← newTVarIO $ emptyResponse arInitialStatus
 195          sendContinue     ← newEmptyTMVarIO
 196          willDiscardBody  ← newTVarIO arWillDiscardBody
 197          willClose        ← newTVarIO arWillClose
 198          responseHasCType ← newTVarIO False
 199          bodyToSend       ← newEmptyTMVarIO
 200
 201          state            ← newTVarIO ExaminingRequest
 202
 203          return NI {
 204                   niConfig           = config
 205                 , niRemoteAddr       = remoteAddr
 206 #if defined(HAVE_SSL)
 207                 , niRemoteCert       = remoteCert
 208 #endif
 209                 , niRequest          = arRequest
 210                 , niResourcePath     = rsrcPath
 211                 , niExpectedContinue = arExpectedContinue
 212                 , niReqBodyLength    = arReqBodyLength
 213
 214                 , niReceiveBodyReq   = receiveBodyReq
 215                 , niReceivedBody     = receivedBody
 216
 217                 , niResponse         = response
 218                 , niSendContinue     = sendContinue
 219                 , niWillChunkBody    = arWillChunkBody
 220                 , niWillDiscardBody  = willDiscardBody
 221                 , niWillClose        = willClose
 222                 , niResponseHasCType = responseHasCType
 223                 , niBodyToSend       = bodyToSend
 224
 225                 , niState            = state
 226                 }
 227
 228 type InteractionQueue = TVar (Seq SomeInteraction)
 229
 230 mkInteractionQueue ∷ IO InteractionQueue
 231 mkInteractionQueue = newTVarIO (∅)
 232
 233 -- FIXME: Response.hs should provide setStatus ∷ sc → Response → Response
 234 setResponseStatus ∷ StatusCode sc ⇒ NormalInteraction → sc → STM ()
 235 setResponseStatus (NI {..}) sc
 236     = do res ← readTVar niResponse
 237          let res' = res {
 238                       resStatus = fromStatusCode sc
 239                     }
 240          writeTVar niResponse res'
 241
 242 getCurrentDate ∷ IO Ascii
 243 getCurrentDate = HTTP.toAscii <$> getCurrentTime