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          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    ∷ !(S.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