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