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