Network/HTTP/Lucu/RequestReader.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , ScopedTypeVariables
   6   , UnicodeSyntax
   7   #-}
   8 module Network.HTTP.Lucu.RequestReader
   9     ( requestReader
  10     )
  11     where
  12 import Control.Concurrent
  13 import Control.Concurrent.STM
  14 import Control.Exception hiding (block)
  15 import Control.Monad
  16 import qualified Data.Attoparsec.Lazy as LP
  17 import qualified Data.ByteString as Strict
  18 import qualified Data.ByteString.Lazy as Lazy
  19 import Data.List
  20 import Data.Maybe
  21 import Data.Monoid.Unicode
  22 import qualified Data.Sequence as S
  23 import Data.Sequence.Unicode hiding ((∅))
  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.Socket
  36 import Prelude.Unicode
  37 import System.IO (hPutStrLn, stderr)
  38
  39 data Context h
  40     = Context {
  41         cConfig    ∷ !Config
  42       , cResTree   ∷ !ResTree
  43       , cFallbacks ∷ ![FallbackHandler]
  44       , cHandle    ∷ !h
  45       , cPort      ∷ !PortNumber
  46       , cAddr      ∷ !SockAddr
  47       , cQueue     ∷ !InteractionQueue
  48       }
  49
  50 data ChunkReceivingState
  51     = Initial
  52     | InChunk !Int -- ^Number of remaining octets in the current
  53                    -- chunk. It's always positive.
  54
  55 requestReader ∷ HandleLike h
  56               ⇒ Config
  57               → ResTree
  58               → [FallbackHandler]
  59               → h
  60               → PortNumber
  61               → SockAddr
  62               → InteractionQueue
  63               → IO ()
  64 requestReader cnf tree fbs h port addr tQueue
  65     = do input ← hGetLBS h
  66          acceptRequest (Context cnf tree fbs h port addr tQueue) input
  67       `catches`
  68       [ Handler handleAsyncE
  69       , Handler handleBIOS
  70       , Handler handleOthers
  71       ]
  72     where
  73       handleAsyncE ∷ AsyncException → IO ()
  74       handleAsyncE ThreadKilled = return ()
  75       handleAsyncE e            = dump e
  76
  77       handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
  78       handleBIOS = dump
  79
  80       handleOthers ∷ SomeException → IO ()
  81       handleOthers = dump
  82
  83       dump ∷ Exception e ⇒ e → IO ()
  84       dump e
  85           = do hPutStrLn stderr "requestReader caught an exception:"
  86                hPutStrLn stderr (show $ toException e)
  87
  88 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
  89 acceptRequest ctx@(Context {..}) input
  90     -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
  91     -- それが限度以下になるまで待つ。
  92     = do atomically $
  93              do queue ← readTVar cQueue
  94                 when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
  95                     retry
  96          -- リクエストを讀む。パースできない場合は直ちに 400 Bad
  97          -- Request 應答を設定し、それを出力してから切斷するやうに
  98          -- ResponseWriter に通知する。
  99          case LP.parse request 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 rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
 119                 case rsrc of
 120                   Nothing
 121                       → do let ar' = ar {
 122                                        arInitialStatus = fromStatusCode NotFound
 123                                      }
 124                            acceptSemanticallyInvalidRequest ctx ar' input
 125                   Just (path, def)
 126                       → acceptRequestForResource ctx ar input path def
 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                          → ResourceDef
 144                          → IO ()
 145 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
 146     = do cert ← hGetPeerCert cHandle
 147          ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
 148          tid  ← spawnResource rsrcDef ni
 149          enqueue ctx ni
 150          if reqMustHaveBody arRequest then
 151              waitForReceiveBodyReq ctx ni tid input
 152          else
 153              acceptRequest ctx input
 154
 155 waitForReceiveBodyReq ∷ HandleLike h
 156                       ⇒ Context h
 157                       → NormalInteraction
 158                       → ThreadId
 159                       → Lazy.ByteString
 160                       → IO ()
 161 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
 162     = case fromJust niReqBodyLength of
 163         Chunked
 164             → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
 165         Fixed len
 166             → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
 167
 168 -- Toooooo long name for a function...
 169 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
 170                                             ⇒ Context h
 171                                             → NormalInteraction
 172                                             → ThreadId
 173                                             → Lazy.ByteString
 174                                             → IO ()
 175 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
 176     = join $
 177       atomically $
 178       do req ← takeTMVar niReceiveBodyReq
 179          case req of
 180            ReceiveBody wanted
 181                → do putTMVar niSendContinue niExpectedContinue
 182                     return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
 183            WasteAll
 184                → do putTMVar niSendContinue False
 185                     return $ wasteAllChunks ctx rsrcTid input Initial
 186
 187 waitForReceiveChunkedBodyReq ∷ HandleLike h
 188                              ⇒ Context h
 189                              → NormalInteraction
 190                              → ThreadId
 191                              → Lazy.ByteString
 192                              → ChunkReceivingState
 193                              → IO ()
 194 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
 195     = do req ← atomically $ takeTMVar niReceiveBodyReq
 196          case req of
 197            ReceiveBody wanted
 198                → readCurrentChunk ctx ni rsrcTid wanted input st
 199            WasteAll
 200                → wasteAllChunks ctx rsrcTid input st
 201
 202 wasteAllChunks ∷ HandleLike h
 203                ⇒ Context h
 204                → ThreadId
 205                → Lazy.ByteString
 206                → ChunkReceivingState
 207                → IO ()
 208 wasteAllChunks ctx rsrcTid = go
 209     where
 210       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
 211       go input Initial
 212           = case LP.parse chunkHeader input of
 213               LP.Done input' chunkLen
 214                   | chunkLen ≡ 0 → gotFinalChunk input'
 215                   | otherwise    → gotChunk input' chunkLen
 216               LP.Fail _ eCtx e
 217                   → chunkWasMalformed rsrcTid eCtx e
 218                        "wasteAllChunks: chunkHeader"
 219       go input (InChunk chunkLen)
 220           = gotChunk input chunkLen
 221
 222       gotChunk ∷ Lazy.ByteString → Int → IO ()
 223       gotChunk input chunkLen
 224           = let input' = Lazy.drop (fromIntegral chunkLen) input
 225             in
 226               case LP.parse chunkFooter input' of
 227                 LP.Done input'' _
 228                     → go input'' Initial
 229                 LP.Fail _ eCtx e
 230                     → chunkWasMalformed rsrcTid eCtx e
 231                           "wasteAllChunks: chunkFooter"
 232
 233       gotFinalChunk ∷ Lazy.ByteString → IO ()
 234       gotFinalChunk input
 235           = case LP.parse chunkTrailer input of
 236               LP.Done input' _
 237                   → acceptRequest ctx input'
 238               LP.Fail _ eCtx e
 239                   → chunkWasMalformed rsrcTid eCtx e
 240                         "wasteAllChunks: chunkTrailer"
 241
 242 readCurrentChunk ∷ HandleLike h
 243                  ⇒ Context h
 244                  → NormalInteraction
 245                  → ThreadId
 246                  → Int
 247                  → Lazy.ByteString
 248                  → ChunkReceivingState
 249                  → IO ()
 250 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
 251     where
 252       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
 253       go input Initial
 254           = case LP.parse chunkHeader input of
 255               LP.Done input' chunkLen
 256                   | chunkLen ≡ 0
 257                       → gotFinalChunk input'
 258                   | otherwise
 259                       → gotChunk input' chunkLen
 260               LP.Fail _ eCtx e
 261                   → chunkWasMalformed rsrcTid eCtx e
 262                         "readCurrentChunk: chunkHeader"
 263       go input (InChunk chunkLen)
 264           = gotChunk input chunkLen
 265
 266       gotChunk ∷ Lazy.ByteString → Int → IO ()
 267       gotChunk input chunkLen
 268           = do let bytesToRead     = min wanted chunkLen
 269                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 270                    block'          = Strict.concat $ Lazy.toChunks block
 271                    actualReadBytes = Strict.length block'
 272                    chunkLen'       = chunkLen - actualReadBytes
 273                atomically $ putTMVar niReceivedBody block'
 274                if chunkLen' ≡ 0 then
 275                    case LP.parse chunkFooter input' of
 276                      LP.Done input'' _
 277                          → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
 278                      LP.Fail _ eCtx e
 279                          → chunkWasMalformed rsrcTid eCtx e
 280                                "readCurrentChunk: chunkFooter"
 281                else
 282                    waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
 283
 284       gotFinalChunk ∷ Lazy.ByteString → IO ()
 285       gotFinalChunk input
 286           = do atomically $ putTMVar niReceivedBody (∅)
 287                case LP.parse chunkTrailer input of
 288                  LP.Done input' _
 289                      → acceptRequest ctx input'
 290                  LP.Fail _ eCtx e
 291                      → chunkWasMalformed rsrcTid eCtx e
 292                            "readCurrentChunk: chunkTrailer"
 293
 294 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
 295 chunkWasMalformed tid eCtx e msg
 296     = let abo = mkAbortion BadRequest [("Connection", "close")]
 297                 $ Just
 298                 $ "chunkWasMalformed: "
 299                 ⊕ T.pack msg
 300                 ⊕ ": "
 301                 ⊕ T.pack (intercalate ", " eCtx)
 302                 ⊕ ": "
 303                 ⊕ T.pack e
 304       in
 305         throwTo tid abo
 306
 307 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
 308                                                ⇒ Context h
 309                                                → NormalInteraction
 310                                                → Lazy.ByteString
 311                                                → Int
 312                                                → IO ()
 313 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
 314     = join $
 315       atomically $
 316       do req ← takeTMVar niReceiveBodyReq
 317          case req of
 318            ReceiveBody wanted
 319                → do putTMVar niSendContinue niExpectedContinue
 320                     return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
 321            WasteAll
 322                → do putTMVar niSendContinue False
 323                     return $ wasteNonChunkedRequestBody ctx input bodyLen
 324
 325 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
 326                                 ⇒ Context h
 327                                 → NormalInteraction
 328                                 → Lazy.ByteString
 329                                 → Int
 330                                 → IO ()
 331 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
 332     = do req ← atomically $ takeTMVar niReceiveBodyReq
 333          case req of
 334            ReceiveBody wanted
 335                → readNonChunkedRequestBody ctx ni input bodyLen wanted
 336            WasteAll
 337                → wasteNonChunkedRequestBody ctx input bodyLen
 338
 339 wasteNonChunkedRequestBody ∷ HandleLike h
 340                            ⇒ Context h
 341                            → Lazy.ByteString
 342                            → Int
 343                            → IO ()
 344 wasteNonChunkedRequestBody ctx input bodyLen
 345     = do let input' = Lazy.drop (fromIntegral bodyLen) input
 346          acceptRequest ctx input'
 347
 348 readNonChunkedRequestBody ∷ HandleLike h
 349                           ⇒ Context h
 350                           → NormalInteraction
 351                           → Lazy.ByteString
 352                           → Int
 353                           → Int
 354                           → IO ()
 355 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
 356     | bodyLen ≡ 0 = gotEndOfRequest
 357     | otherwise   = gotBody
 358     where
 359       gotBody ∷ IO ()
 360       gotBody
 361           = do let bytesToRead     = min wanted bodyLen
 362                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 363                    block'          = Strict.concat $ Lazy.toChunks block
 364                    actualReadBytes = Strict.length block'
 365                    bodyLen'        = bodyLen - actualReadBytes
 366                atomically $ putTMVar niReceivedBody block'
 367                waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
 368
 369       gotEndOfRequest ∷ IO ()
 370       gotEndOfRequest
 371           = do atomically $ putTMVar niReceivedBody (∅)
 372                acceptRequest ctx input
 373
 374 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
 375 {-# INLINEABLE enqueue #-}
 376 enqueue (Context {..}) itr
 377     = atomically $
 378       do queue ← readTVar cQueue
 379          writeTVar cQueue (toInteraction itr ⊲ queue)