Network/HTTP/Lucu/Interaction.hs

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