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