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       , niBodyToSend       ∷ !(TMVar Builder)
 151
 152       , niState            ∷ !(TVar InteractionState)
 153       }
 154     deriving Typeable
 155 instance Interaction NormalInteraction
 156
 157 data ReceiveBodyRequest
 158     = ReceiveBody !Int -- ^ Maximum number of octets to receive.
 159     | WasteAll
 160     deriving (Show, Eq)
 161
 162 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
 163 -- initial state.
 164 data InteractionState
 165     = ExaminingRequest
 166     | ReceivingBody
 167     | DecidingHeader
 168     | SendingBody
 169     | Done
 170     deriving (Show, Eq, Ord, Enum)
 171
 172 mkNormalInteraction ∷ Config
 173                     → SockAddr
 174                     → Maybe X509
 175                     → AugmentedRequest
 176                     → [Strict.ByteString]
 177                     → IO NormalInteraction
 178 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
 179     = do receiveBodyReq   ← newEmptyTMVarIO
 180          receivedBody     ← newEmptyTMVarIO
 181
 182          response         ← newTVarIO $ emptyResponse arInitialStatus
 183          sendContinue     ← newEmptyTMVarIO
 184          willDiscardBody  ← newTVarIO arWillDiscardBody
 185          willClose        ← newTVarIO arWillClose
 186          responseHasCType ← newTVarIO False
 187          bodyToSend       ← newEmptyTMVarIO
 188
 189          state            ← newTVarIO ExaminingRequest
 190
 191          return NI {
 192                   niConfig           = config
 193                 , niRemoteAddr       = remoteAddr
 194                 , niRemoteCert       = remoteCert
 195                 , niRequest          = arRequest
 196                 , niResourcePath     = rsrcPath
 197                 , niExpectedContinue = arExpectedContinue
 198                 , niReqBodyLength    = arReqBodyLength
 199
 200                 , niReceiveBodyReq   = receiveBodyReq
 201                 , niReceivedBody     = receivedBody
 202
 203                 , niResponse         = response
 204                 , niSendContinue     = sendContinue
 205                 , niWillChunkBody    = arWillChunkBody
 206                 , niWillDiscardBody  = willDiscardBody
 207                 , niWillClose        = willClose
 208                 , niResponseHasCType = responseHasCType
 209                 , niBodyToSend       = bodyToSend
 210
 211                 , niState            = state
 212                 }
 213
 214 type InteractionQueue = TVar (Seq SomeInteraction)
 215
 216 mkInteractionQueue ∷ IO InteractionQueue
 217 mkInteractionQueue = newTVarIO (∅)
 218
 219 setResponseStatus ∷ StatusCode sc ⇒ NormalInteraction → sc → STM ()
 220 setResponseStatus (NI {..}) sc
 221     = do res ← readTVar niResponse
 222          let res' = res {
 223                       resStatus = fromStatusCode sc
 224                     }
 225          writeTVar niResponse res'
 226
 227 getCurrentDate ∷ IO Ascii
 228 getCurrentDate = HTTP.toAscii <$> getCurrentTime