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          -- FIXME: DRY
 113          let res  = setHeader "Server"       cnfServerSoftware      $
 114                     setHeader "Date"         date                   $
 115                     setHeader "Content-Type" defaultPageContentType $
 116                     emptyResponse arInitialStatus
 117              body = getDefaultPage config (Just arRequest) res
 118          return SEI {
 119                   seiRequest          = arRequest
 120                 , seiExpectedContinue = arExpectedContinue
 121                 , seiReqBodyLength    = arReqBodyLength
 122
 123                 , seiResponse         = res
 124                 , seiWillChunkBody    = arWillChunkBody
 125                 , seiWillDiscardBody  = arWillDiscardBody
 126                 , seiWillClose        = arWillClose
 127                 , seiBodyToSend       = body
 128                 }
 129
 130 -- |'NormalInteraction' is an 'Interaction' with a semantically
 131 -- correct 'Request'.
 132 data NormalInteraction
 133     = NI {
 134         niConfig           ∷ !Config
 135       , niRemoteAddr       ∷ !SockAddr
 136       , niRemoteCert       ∷ !(Maybe X509)
 137       , niRequest          ∷ !Request
 138       , niResourcePath     ∷ ![Strict.ByteString]
 139       , niExpectedContinue ∷ !Bool
 140       , niReqBodyLength    ∷ !(Maybe RequestBodyLength)
 141
 142       , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
 143       , niReceivedBody     ∷ !(TMVar Strict.ByteString)
 144
 145       , niResponse         ∷ !(TVar Response)
 146       , niSendContinue     ∷ !(TMVar Bool)
 147       , niWillChunkBody    ∷ !Bool
 148       , niWillDiscardBody  ∷ !(TVar Bool)
 149       , niWillClose        ∷ !(TVar Bool)
 150       , niResponseHasCType ∷ !(TVar Bool)
 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 setResponseStatus ∷ NormalInteraction → StatusCode → STM ()
 221 setResponseStatus (NI {..}) sc
 222     = do res ← readTVar niResponse
 223          let res' = res {
 224                       resStatus = sc
 225                     }
 226          writeTVar niResponse res'
 227
 228 getCurrentDate ∷ IO Ascii
 229 getCurrentDate = HTTP.toAscii <$> getCurrentTime