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