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