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