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