Network/HTTP/Lucu/RequestReader.hs

   1 {-# LANGUAGE
   2     CPP
   3   , DoAndIfThenElse
   4   , OverloadedStrings
   5   , RecordWildCards
   6   , ScopedTypeVariables
   7   , UnicodeSyntax
   8   #-}
   9 module Network.HTTP.Lucu.RequestReader
  10     ( requestReader
  11     )
  12     where
  13 import Control.Concurrent
  14 import Control.Concurrent.STM
  15 import Control.Exception hiding (block)
  16 import Control.Monad
  17 import Control.Monad.Trans.Maybe
  18 import qualified Data.Attoparsec.Lazy as LP
  19 import qualified Data.ByteString as Strict
  20 import qualified Data.ByteString.Lazy as Lazy
  21 import Data.Convertible.Base
  22 import Data.Convertible.Instances.Text ()
  23 import Data.Default
  24 import Data.List
  25 import Data.Maybe
  26 import Data.Monoid.Unicode
  27 import qualified Data.Sequence as S
  28 import Network.HTTP.Lucu.Abortion
  29 import Network.HTTP.Lucu.Config
  30 import Network.HTTP.Lucu.Chunk
  31 import Network.HTTP.Lucu.Dispatcher.Internal
  32 import Network.HTTP.Lucu.HandleLike
  33 import Network.HTTP.Lucu.Interaction
  34 import Network.HTTP.Lucu.Preprocess
  35 import Network.HTTP.Lucu.Request
  36 import Network.HTTP.Lucu.Response
  37 import Network.HTTP.Lucu.Resource.Internal
  38 import Network.HTTP.Lucu.Utils
  39 import Network.Socket
  40 import Prelude.Unicode
  41 import System.IO (hPutStrLn, stderr)
  42
  43 data Context h
  44     = Context {
  45         cConfig  ∷ !Config
  46       , cHostMap ∷ !HostMap
  47       , cHandle  ∷ !h
  48       , cPort    ∷ !PortNumber
  49       , cAddr    ∷ !SockAddr
  50       , cQueue   ∷ !InteractionQueue
  51       }
  52
  53 data ChunkReceivingState
  54     = Initial
  55     | InChunk !Int -- ^Number of remaining octets in the current
  56                    -- chunk. It's always positive.
  57
  58 requestReader ∷ (HostMapper hm, HandleLike h)
  59               ⇒ Config
  60               → hm
  61               → h
  62               → PortNumber
  63               → SockAddr
  64               → InteractionQueue
  65               → IO ()
  66 requestReader cnf hm h port addr tQueue
  67     = do input ← hGetLBS h
  68          acceptRequest (Context cnf (hostMap hm) h port addr tQueue) input
  69       `catches`
  70       [ Handler handleAsyncE
  71       , Handler handleOthers
  72       ]
  73       `finally`
  74       enqueue' tQueue EndOfInteraction
  75     where
  76       handleAsyncE ∷ AsyncException → IO ()
  77       handleAsyncE ThreadKilled = return ()
  78       handleAsyncE e            = dump e
  79
  80       handleOthers ∷ SomeException → IO ()
  81       handleOthers = dump
  82
  83       dump ∷ Exception e ⇒ e → IO ()
  84       dump e
  85           = do hPutStrLn stderr "Lucu: requestReader caught an exception:"
  86                hPutStrLn stderr $ show e
  87
  88 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
  89 acceptRequest ctx@(Context {..}) input
  90     = do atomically $
  91              do queue ← readTVar cQueue
  92                 when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
  93                     -- Too many requests in the pipeline...
  94                     retry
  95          if Lazy.null input then
  96              return ()
  97          else
  98              case LP.parse def input of
  99                LP.Done input' req → acceptParsableRequest ctx req input'
 100                LP.Fail _ _ _      → acceptNonparsableRequest ctx
 101
 102 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
 103 acceptNonparsableRequest ctx@(Context {..})
 104     = do syi ← mkSyntacticallyInvalidInteraction cConfig
 105          enqueue ctx syi
 106
 107 acceptParsableRequest ∷ HandleLike h
 108                       ⇒ Context h
 109                       → Request
 110                       → Lazy.ByteString
 111                       → IO ()
 112 acceptParsableRequest ctx@(Context {..}) req input
 113     = do let ar = preprocess (cnfServerHost cConfig) cPort req
 114          if isError $ arInitialStatus ar then
 115              acceptSemanticallyInvalidRequest ctx ar input
 116          else
 117              do rsrcM ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
 118                 case rsrcM of
 119                   Nothing
 120                       → do let ar' = ar {
 121                                        arInitialStatus = fromStatusCode NotFound
 122                                      }
 123                            acceptSemanticallyInvalidRequest ctx ar' input
 124                   Just (path, rsrc)
 125                       → acceptRequestForResource ctx ar input path rsrc
 126
 127 acceptSemanticallyInvalidRequest ∷ HandleLike h
 128                                  ⇒ Context h
 129                                  → AugmentedRequest
 130                                  → Lazy.ByteString
 131                                  → IO ()
 132 acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
 133     = do sei ← mkSemanticallyInvalidInteraction cConfig ar
 134          enqueue ctx sei
 135          acceptRequest ctx input
 136
 137 acceptRequestForResource ∷ HandleLike h
 138                          ⇒ Context h
 139                          → AugmentedRequest
 140                          → Lazy.ByteString
 141                          → [Strict.ByteString]
 142                          → Resource
 143                          → IO ()
 144 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrc
 145     = do
 146 #if defined(HAVE_SSL)
 147          cert ← hGetPeerCert cHandle
 148          ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
 149 #else
 150          ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
 151 #endif
 152          tid  ← spawnRsrc rsrc ni
 153          enqueue ctx ni
 154          if reqHasBody arRequest then
 155              waitForReceiveBodyReq ctx ni tid input
 156          else
 157              acceptRequest ctx input
 158
 159 waitForReceiveBodyReq ∷ HandleLike h
 160                       ⇒ Context h
 161                       → NormalInteraction
 162                       → ThreadId
 163                       → Lazy.ByteString
 164                       → IO ()
 165 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
 166     = case fromJust niReqBodyLength of
 167         Chunked
 168             → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
 169         Fixed len
 170             → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
 171
 172 -- Toooooo long name for a function...
 173 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
 174                                             ⇒ Context h
 175                                             → NormalInteraction
 176                                             → ThreadId
 177                                             → Lazy.ByteString
 178                                             → IO ()
 179 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
 180     = join $
 181       atomically $
 182       do req ← takeTMVar niReceiveBodyReq
 183          case req of
 184            ReceiveBody wanted
 185                → do putTMVar niSendContinue niExpectedContinue
 186                     return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
 187            WasteAll
 188                → do putTMVar niSendContinue False
 189                     return $ wasteAllChunks ctx rsrcTid input Initial
 190
 191 waitForReceiveChunkedBodyReq ∷ HandleLike h
 192                              ⇒ Context h
 193                              → NormalInteraction
 194                              → ThreadId
 195                              → Lazy.ByteString
 196                              → ChunkReceivingState
 197                              → IO ()
 198 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
 199     = do req ← atomically $ takeTMVar niReceiveBodyReq
 200          case req of
 201            ReceiveBody wanted
 202                → readCurrentChunk ctx ni rsrcTid wanted input st
 203            WasteAll
 204                → wasteAllChunks ctx rsrcTid input st
 205
 206 wasteAllChunks ∷ HandleLike h
 207                ⇒ Context h
 208                → ThreadId
 209                → Lazy.ByteString
 210                → ChunkReceivingState
 211                → IO ()
 212 wasteAllChunks ctx rsrcTid = go
 213     where
 214       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
 215       go input Initial
 216           = case LP.parse chunkHeader input of
 217               LP.Done input' chunkLen
 218                   | chunkLen ≡ 0 → gotFinalChunk input'
 219                   | otherwise    → gotChunk input' chunkLen
 220               LP.Fail _ eCtx e
 221                   → chunkWasMalformed rsrcTid eCtx e
 222                        "wasteAllChunks: chunkHeader"
 223       go input (InChunk chunkLen)
 224           = gotChunk input chunkLen
 225
 226       gotChunk ∷ Lazy.ByteString → Int → IO ()
 227       gotChunk input chunkLen
 228           = let input' = Lazy.drop (fromIntegral chunkLen) input
 229             in
 230               case LP.parse chunkFooter input' of
 231                 LP.Done input'' _
 232                     → go input'' Initial
 233                 LP.Fail _ eCtx e
 234                     → chunkWasMalformed rsrcTid eCtx e
 235                           "wasteAllChunks: chunkFooter"
 236
 237       gotFinalChunk ∷ Lazy.ByteString → IO ()
 238       gotFinalChunk input
 239           = case LP.parse chunkTrailer input of
 240               LP.Done input' _
 241                   → acceptRequest ctx input'
 242               LP.Fail _ eCtx e
 243                   → chunkWasMalformed rsrcTid eCtx e
 244                         "wasteAllChunks: chunkTrailer"
 245
 246 readCurrentChunk ∷ HandleLike h
 247                  ⇒ Context h
 248                  → NormalInteraction
 249                  → ThreadId
 250                  → Int
 251                  → Lazy.ByteString
 252                  → ChunkReceivingState
 253                  → IO ()
 254 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
 255     where
 256       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
 257       go input Initial
 258           = case LP.parse chunkHeader input of
 259               LP.Done input' chunkLen
 260                   | chunkLen ≡ 0
 261                       → gotFinalChunk input'
 262                   | otherwise
 263                       → gotChunk input' chunkLen
 264               LP.Fail _ eCtx e
 265                   → chunkWasMalformed rsrcTid eCtx e
 266                         "readCurrentChunk: chunkHeader"
 267       go input (InChunk chunkLen)
 268           = gotChunk input chunkLen
 269
 270       gotChunk ∷ Lazy.ByteString → Int → IO ()
 271       gotChunk input chunkLen
 272           = do let bytesToRead     = min wanted chunkLen
 273                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 274                    block'          = Strict.concat $ Lazy.toChunks block
 275                    actualReadBytes = Strict.length block'
 276                    chunkLen'       = chunkLen - actualReadBytes
 277                atomically $ putTMVar niReceivedBody block'
 278                if chunkLen' ≡ 0 then
 279                    case LP.parse chunkFooter input' of
 280                      LP.Done input'' _
 281                          → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
 282                      LP.Fail _ eCtx e
 283                          → chunkWasMalformed rsrcTid eCtx e
 284                                "readCurrentChunk: chunkFooter"
 285                else
 286                    waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
 287
 288       gotFinalChunk ∷ Lazy.ByteString → IO ()
 289       gotFinalChunk input
 290           = do atomically $ putTMVar niReceivedBody (∅)
 291                case LP.parse chunkTrailer input of
 292                  LP.Done input' _
 293                      → acceptRequest ctx input'
 294                  LP.Fail _ eCtx e
 295                      → chunkWasMalformed rsrcTid eCtx e
 296                            "readCurrentChunk: chunkTrailer"
 297
 298 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
 299 chunkWasMalformed tid eCtx e msg
 300     = let abo = mkAbortion BadRequest [("Connection", "close")]
 301                 $ Just
 302                 $ "chunkWasMalformed: "
 303                 ⊕ cs msg
 304                 ⊕ ": "
 305                 ⊕ cs (intercalate ", " eCtx)
 306                 ⊕ ": "
 307                 ⊕ cs e
 308       in
 309         throwTo tid abo
 310
 311 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
 312                                                ⇒ Context h
 313                                                → NormalInteraction
 314                                                → Lazy.ByteString
 315                                                → Int
 316                                                → IO ()
 317 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
 318     = join $
 319       atomically $
 320       do req ← takeTMVar niReceiveBodyReq
 321          case req of
 322            ReceiveBody wanted
 323                → do putTMVar niSendContinue niExpectedContinue
 324                     return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
 325            WasteAll
 326                → do putTMVar niSendContinue False
 327                     return $ wasteNonChunkedRequestBody ctx input bodyLen
 328
 329 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
 330                                 ⇒ Context h
 331                                 → NormalInteraction
 332                                 → Lazy.ByteString
 333                                 → Int
 334                                 → IO ()
 335 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
 336     = do req ← atomically $ takeTMVar niReceiveBodyReq
 337          case req of
 338            ReceiveBody wanted
 339                → readNonChunkedRequestBody ctx ni input bodyLen wanted
 340            WasteAll
 341                → wasteNonChunkedRequestBody ctx input bodyLen
 342
 343 wasteNonChunkedRequestBody ∷ HandleLike h
 344                            ⇒ Context h
 345                            → Lazy.ByteString
 346                            → Int
 347                            → IO ()
 348 wasteNonChunkedRequestBody ctx input bodyLen
 349     = do let input' = Lazy.drop (fromIntegral bodyLen) input
 350          acceptRequest ctx input'
 351
 352 readNonChunkedRequestBody ∷ HandleLike h
 353                           ⇒ Context h
 354                           → NormalInteraction
 355                           → Lazy.ByteString
 356                           → Int
 357                           → Int
 358                           → IO ()
 359 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
 360     | bodyLen ≡ 0 = gotEndOfRequest
 361     | otherwise   = gotBody
 362     where
 363       gotBody ∷ IO ()
 364       gotBody
 365           = do let bytesToRead     = min wanted bodyLen
 366                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 367                    block'          = Strict.concat $ Lazy.toChunks block
 368                    actualReadBytes = Strict.length block'
 369                    bodyLen'        = bodyLen - actualReadBytes
 370                atomically $ putTMVar niReceivedBody block'
 371                waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
 372
 373       gotEndOfRequest ∷ IO ()
 374       gotEndOfRequest
 375           = do atomically $ putTMVar niReceivedBody (∅)
 376                acceptRequest ctx input
 377
 378 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
 379 enqueue (Context {..}) = enqueue' cQueue
 380
 381 enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
 382 enqueue' tQueue itr
 383     = atomically $
 384       do queue ← readTVar tQueue
 385          writeTVar tQueue (toInteraction itr ⊲ queue)