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