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 { arInitialStatus = NotFound }
 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 cert ← hGetPeerCert cHandle
 145          ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
 146          tid  ← spawnResource rsrcDef ni
 147          enqueue ctx ni
 148          if reqMustHaveBody arRequest then
 149              waitForReceiveBodyReq ctx ni tid input
 150          else
 151              acceptRequest ctx input
 152
 153 waitForReceiveBodyReq ∷ HandleLike h
 154                       ⇒ Context h
 155                       → NormalInteraction
 156                       → ThreadId
 157                       → Lazy.ByteString
 158                       → IO ()
 159 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
 160     = case fromJust niReqBodyLength of
 161         Chunked
 162             → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
 163         Fixed len
 164             → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
 165
 166 -- Toooooo long name for a function...
 167 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
 168                                             ⇒ Context h
 169                                             → NormalInteraction
 170                                             → ThreadId
 171                                             → Lazy.ByteString
 172                                             → IO ()
 173 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
 174     = join $
 175       atomically $
 176       do req ← takeTMVar niReceiveBodyReq
 177          case req of
 178            ReceiveBody wanted
 179                → do putTMVar niSendContinue niExpectedContinue
 180                     return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
 181            WasteAll
 182                → do putTMVar niSendContinue False
 183                     return $ wasteAllChunks ctx rsrcTid input Initial
 184
 185 waitForReceiveChunkedBodyReq ∷ HandleLike h
 186                              ⇒ Context h
 187                              → NormalInteraction
 188                              → ThreadId
 189                              → Lazy.ByteString
 190                              → ChunkReceivingState
 191                              → IO ()
 192 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
 193     = do req ← atomically $ takeTMVar niReceiveBodyReq
 194          case req of
 195            ReceiveBody wanted
 196                → readCurrentChunk ctx ni rsrcTid wanted input st
 197            WasteAll
 198                → wasteAllChunks ctx rsrcTid input st
 199
 200 wasteAllChunks ∷ HandleLike h
 201                ⇒ Context h
 202                → ThreadId
 203                → Lazy.ByteString
 204                → ChunkReceivingState
 205                → IO ()
 206 wasteAllChunks ctx rsrcTid = go
 207     where
 208       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
 209       go input Initial
 210           = case LP.parse chunkHeader input of
 211               LP.Done input' chunkLen
 212                   | chunkLen ≡ 0 → gotFinalChunk input'
 213                   | otherwise    → gotChunk input' chunkLen
 214               LP.Fail _ eCtx e
 215                   → chunkWasMalformed rsrcTid eCtx e
 216                        "wasteAllChunks: chunkHeader"
 217       go input (InChunk chunkLen)
 218           = gotChunk input chunkLen
 219
 220       gotChunk ∷ Lazy.ByteString → Int → IO ()
 221       gotChunk input chunkLen
 222           = let input' = Lazy.drop (fromIntegral chunkLen) input
 223             in
 224               case LP.parse chunkFooter input' of
 225                 LP.Done input'' _
 226                     → go input'' Initial
 227                 LP.Fail _ eCtx e
 228                     → chunkWasMalformed rsrcTid eCtx e
 229                           "wasteAllChunks: chunkFooter"
 230
 231       gotFinalChunk ∷ Lazy.ByteString → IO ()
 232       gotFinalChunk input
 233           = case LP.parse chunkTrailer input of
 234               LP.Done input' _
 235                   → acceptRequest ctx input'
 236               LP.Fail _ eCtx e
 237                   → chunkWasMalformed rsrcTid eCtx e
 238                         "wasteAllChunks: chunkTrailer"
 239
 240 readCurrentChunk ∷ HandleLike h
 241                  ⇒ Context h
 242                  → NormalInteraction
 243                  → ThreadId
 244                  → Int
 245                  → Lazy.ByteString
 246                  → ChunkReceivingState
 247                  → IO ()
 248 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
 249     where
 250       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
 251       go input Initial
 252           = case LP.parse chunkHeader input of
 253               LP.Done input' chunkLen
 254                   | chunkLen ≡ 0
 255                       → gotFinalChunk input'
 256                   | otherwise
 257                       → gotChunk input' chunkLen
 258               LP.Fail _ eCtx e
 259                   → chunkWasMalformed rsrcTid eCtx e
 260                         "readCurrentChunk: chunkHeader"
 261       go input (InChunk chunkLen)
 262           = gotChunk input chunkLen
 263
 264       gotChunk ∷ Lazy.ByteString → Int → IO ()
 265       gotChunk input chunkLen
 266           = do let bytesToRead     = min wanted chunkLen
 267                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 268                    block'          = Strict.concat $ Lazy.toChunks block
 269                    actualReadBytes = Strict.length block'
 270                    chunkLen'       = chunkLen - actualReadBytes
 271                atomically $ putTMVar niReceivedBody block'
 272                if chunkLen' ≡ 0 then
 273                    case LP.parse chunkFooter input' of
 274                      LP.Done input'' _
 275                          → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
 276                      LP.Fail _ eCtx e
 277                          → chunkWasMalformed rsrcTid eCtx e
 278                                "readCurrentChunk: chunkFooter"
 279                else
 280                    waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
 281
 282       gotFinalChunk ∷ Lazy.ByteString → IO ()
 283       gotFinalChunk input
 284           = do atomically $ putTMVar niReceivedBody (∅)
 285                case LP.parse chunkTrailer input of
 286                  LP.Done input' _
 287                      → acceptRequest ctx input'
 288                  LP.Fail _ eCtx e
 289                      → chunkWasMalformed rsrcTid eCtx e
 290                            "readCurrentChunk: chunkTrailer"
 291
 292 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
 293 chunkWasMalformed tid eCtx e msg
 294     = let abo = mkAbortion BadRequest [("Connection", "close")]
 295                 $ Just
 296                 $ "chunkWasMalformed: "
 297                 ⊕ T.pack msg
 298                 ⊕ ": "
 299                 ⊕ T.pack (intercalate ", " eCtx)
 300                 ⊕ ": "
 301                 ⊕ T.pack e
 302       in
 303         throwTo tid abo
 304
 305 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
 306                                                ⇒ Context h
 307                                                → NormalInteraction
 308                                                → Lazy.ByteString
 309                                                → Int
 310                                                → IO ()
 311 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
 312     = join $
 313       atomically $
 314       do req ← takeTMVar niReceiveBodyReq
 315          case req of
 316            ReceiveBody wanted
 317                → do putTMVar niSendContinue niExpectedContinue
 318                     return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
 319            WasteAll
 320                → do putTMVar niSendContinue False
 321                     return $ wasteNonChunkedRequestBody ctx input bodyLen
 322
 323 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
 324                                 ⇒ Context h
 325                                 → NormalInteraction
 326                                 → Lazy.ByteString
 327                                 → Int
 328                                 → IO ()
 329 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
 330     = do req ← atomically $ takeTMVar niReceiveBodyReq
 331          case req of
 332            ReceiveBody wanted
 333                → readNonChunkedRequestBody ctx ni input bodyLen wanted
 334            WasteAll
 335                → wasteNonChunkedRequestBody ctx input bodyLen
 336
 337 wasteNonChunkedRequestBody ∷ HandleLike h
 338                            ⇒ Context h
 339                            → Lazy.ByteString
 340                            → Int
 341                            → IO ()
 342 wasteNonChunkedRequestBody ctx input bodyLen
 343     = do let input' = Lazy.drop (fromIntegral bodyLen) input
 344          acceptRequest ctx input'
 345
 346 readNonChunkedRequestBody ∷ HandleLike h
 347                           ⇒ Context h
 348                           → NormalInteraction
 349                           → Lazy.ByteString
 350                           → Int
 351                           → Int
 352                           → IO ()
 353 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
 354     | bodyLen ≡ 0 = gotEndOfRequest
 355     | otherwise   = gotBody
 356     where
 357       gotBody ∷ IO ()
 358       gotBody
 359           = do let bytesToRead     = min wanted bodyLen
 360                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 361                    block'          = Strict.concat $ Lazy.toChunks block
 362                    actualReadBytes = Strict.length block'
 363                    bodyLen'        = bodyLen - actualReadBytes
 364                atomically $ putTMVar niReceivedBody block'
 365                waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
 366
 367       gotEndOfRequest ∷ IO ()
 368       gotEndOfRequest
 369           = do atomically $ putTMVar niReceivedBody (∅)
 370                acceptRequest ctx input
 371
 372 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
 373 {-# INLINEABLE enqueue #-}
 374 enqueue (Context {..}) itr
 375     = atomically $
 376       do queue ← readTVar cQueue
 377          writeTVar cQueue (toInteraction itr ⊲ queue)