Network/HTTP/Lucu/RequestReader.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , UnboxedTuples
   4   , UnicodeSyntax
   5   #-}
   6 module Network.HTTP.Lucu.RequestReader
   7     ( requestReader
   8     )
   9     where
  10
  11 import           Control.Concurrent.STM
  12 import           Control.Exception
  13 import           Control.Monad
  14 import qualified Data.ByteString.Lazy.Char8 as B
  15 import           Data.ByteString.Lazy.Char8 (ByteString)
  16 import           Data.Maybe
  17 import qualified Data.Sequence as S
  18 import           Data.Sequence ((<|))
  19 import           GHC.Conc (unsafeIOToSTM)
  20 import           Network.Socket
  21 import           Network.HTTP.Lucu.Config
  22 import           Network.HTTP.Lucu.Chunk
  23 import           Network.HTTP.Lucu.DefaultPage
  24 import           Network.HTTP.Lucu.HandleLike
  25 import           Network.HTTP.Lucu.Interaction
  26 import           Network.HTTP.Lucu.Parser
  27 import           Network.HTTP.Lucu.Postprocess
  28 import           Network.HTTP.Lucu.Preprocess
  29 import           Network.HTTP.Lucu.Request
  30 import           Network.HTTP.Lucu.Response
  31 import           Network.HTTP.Lucu.Resource.Tree
  32 import           Prelude hiding (catch)
  33 import           System.IO (stderr)
  34
  35 requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> PortNumber -> SockAddr -> InteractionQueue -> IO ()
  36 requestReader !cnf !tree !fbs !h !port !addr !tQueue
  37     = do input <- hGetLBS h
  38          acceptRequest input
  39       `catches`
  40       [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
  41       , Handler  ( \ ThreadKilled        -> return () )
  42       , Handler  ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestReader: blocked indefinitely" )
  43       , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
  44       ]
  45     where
  46       acceptRequest :: ByteString -> IO ()
  47       acceptRequest input
  48           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
  49           -- 時は、それが限度以下になるまで待つ。
  50           = {-# SCC "acceptRequest" #-}
  51             do atomically $ do queue    <- readTVar tQueue
  52                                when (S.length queue >= cnfMaxPipelineDepth cnf)
  53                                     retry
  54
  55                -- リクエストを讀む。パースできない場合は直ちに 400 Bad
  56                -- Request 應答を設定し、それを出力してから切斷するやう
  57                -- に ResponseWriter に通知する。
  58                case parse requestP input of
  59                  (# Success req , input' #) -> acceptParsableRequest req input'
  60                  (# IllegalInput, _      #) -> acceptNonparsableRequest BadRequest
  61                  (# ReachedEOF  , _      #) -> acceptNonparsableRequest BadRequest
  62
  63       acceptNonparsableRequest :: StatusCode -> IO ()
  64       acceptNonparsableRequest status
  65           = {-# SCC "acceptNonparsableRequest" #-}
  66             do itr <- newInteraction cnf port addr Nothing Nothing
  67                atomically $ do updateItr itr itrResponse
  68                                              $ \ res -> res {
  69                                                           resStatus = status
  70                                                         }
  71                                writeItr itr itrWillClose True
  72                                writeItr itr itrState     Done
  73                                writeDefaultPage itr
  74                                postprocess itr
  75                                enqueue itr
  76
  77       acceptParsableRequest :: Request -> ByteString -> IO ()
  78       acceptParsableRequest req input
  79           = {-# SCC "acceptParsableRequest" #-}
  80             do cert <- hGetPeerCert h
  81                itr  <- newInteraction cnf port addr cert (Just req)
  82                action
  83                    <- atomically $
  84                       do preprocess itr
  85                          isErr <- readItr itr itrResponse (isError . resStatus)
  86                          if isErr then
  87                              acceptSemanticallyInvalidRequest itr input
  88                            else
  89                              do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req
  90                                 case rsrcM of
  91                                   Nothing -- Resource が無かった
  92                                       -> acceptRequestForNonexistentResource itr input
  93
  94                                   Just (rsrcPath, rsrcDef) -- あった
  95                                       -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
  96                action
  97
  98       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
  99       acceptSemanticallyInvalidRequest itr input
 100           = {-# SCC "acceptSemanticallyInvalidRequest" #-}
 101             do writeItr itr itrState Done
 102                writeDefaultPage itr
 103                postprocess itr
 104                enqueue itr
 105                return $ acceptRequest input
 106
 107       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
 108       acceptRequestForNonexistentResource itr input
 109           = {-# SCC "acceptRequestForNonexistentResource" #-}
 110             do updateItr itr itrResponse
 111                              $ \res -> res {
 112                                          resStatus = NotFound
 113                                        }
 114                writeItr itr itrState Done
 115                writeDefaultPage itr
 116                postprocess itr
 117                enqueue itr
 118                return $ acceptRequest input
 119
 120       acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
 121       acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
 122           = {-# SCC "acceptRequestForExistentResource" #-}
 123             do let itr = oldItr { itrResourcePath = Just rsrcPath }
 124                requestHasBody <- readItr itr itrRequestHasBody id
 125                enqueue itr
 126                return $ do _ <- runResource rsrcDef itr
 127                            if requestHasBody then
 128                                observeRequest itr input
 129                              else
 130                                acceptRequest input
 131
 132       observeRequest :: Interaction -> ByteString -> IO ()
 133       observeRequest itr input
 134           = {-# SCC "observeRequest" #-}
 135             do isChunked <- atomically $ readItr itr itrRequestIsChunked id
 136                if isChunked then
 137                    observeChunkedRequest itr input
 138                  else
 139                    observeNonChunkedRequest itr input
 140
 141       observeChunkedRequest :: Interaction -> ByteString -> IO ()
 142       observeChunkedRequest itr input
 143           = {-# SCC "observeChunkedRequest" #-}
 144             do action
 145                    <- atomically $
 146                       do isOver <- readItr itr itrReqChunkIsOver id
 147                          if isOver then
 148                              return $ acceptRequest input
 149                            else
 150                              do wantedM <- readItr itr itrReqBodyWanted id
 151                                 if wantedM == Nothing then
 152                                     do wasteAll <- readItr itr itrReqBodyWasteAll id
 153                                        if wasteAll then
 154                                            -- 破棄要求が來た
 155                                            do remainingM <- readItr itr itrReqChunkRemaining id
 156                                               if fmap (> 0) remainingM == Just True then
 157                                                   -- 現在のチャンクをまだ
 158                                                   -- 讀み終へてゐない
 159                                                   do let (_, input') = B.splitAt (fromIntegral
 160                                                                                   $ fromJust remainingM) input
 161                                                          (# footerR, input'' #) = parse chunkFooterP input'
 162
 163                                                      if footerR == Success () then
 164                                                          -- チャンクフッタを正常に讀めた
 165                                                          do writeItr itr itrReqChunkRemaining $ Just 0
 166
 167                                                             return $ observeChunkedRequest itr input''
 168                                                        else
 169                                                          return $ chunkWasMalformed itr
 170                                                 else
 171                                                   -- 次のチャンクを讀み始める
 172                                                   seekNextChunk itr input
 173                                          else
 174                                            -- 要求がまだ來ない
 175                                            retry
 176                                   else
 177                                     -- 受信要求が來た
 178                                     do remainingM <- readItr itr itrReqChunkRemaining id
 179                                        if fmap (> 0) remainingM == Just True then
 180                                            -- 現在のチャンクをまだ讀み
 181                                            -- 終へてゐない
 182                                            do let wanted             = fromJust wantedM
 183                                                   remaining          = fromJust remainingM
 184                                                   bytesToRead        = fromIntegral $ min wanted remaining
 185                                                   (chunk, input')    = B.splitAt bytesToRead input
 186                                                   actualReadBytes    = fromIntegral $ B.length chunk
 187                                                   newWanted          = case wanted - actualReadBytes of
 188                                                                          0 -> Nothing
 189                                                                          n -> Just n
 190                                                   newRemaining       = Just $ remaining - actualReadBytes
 191                                                   updateStates
 192                                                       = do writeItr itr itrReqChunkRemaining newRemaining
 193                                                            writeItr itr itrReqBodyWanted newWanted
 194                                                            updateItr itr itrReceivedBody $ flip B.append chunk
 195
 196                                               if newRemaining == Just 0 then
 197                                                   -- チャンクフッタを讀む
 198                                                   case parse chunkFooterP input' of
 199                                                     (# Success _, input'' #)
 200                                                         -> do updateStates
 201                                                               return $ observeChunkedRequest itr input''
 202                                                     (# _, _ #)
 203                                                         -> return $ chunkWasMalformed itr
 204                                                 else
 205                                                   -- まだチャンクの終はりに達してゐない
 206                                                   do updateStates
 207                                                      return $ observeChunkedRequest itr input'
 208                                          else
 209                                            -- 次のチャンクを讀み始める
 210                                            seekNextChunk itr input
 211                action
 212
 213       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
 214       seekNextChunk itr input
 215           = {-# SCC "seekNextChunk" #-}
 216             case parse chunkHeaderP input of
 217               -- 最終チャンク (中身が空)
 218               (# Success 0, input' #)
 219                   -> case parse chunkTrailerP input' of
 220                        (# Success _, input'' #)
 221                            -> do writeItr itr itrReqChunkLength $ Nothing
 222                                  writeItr itr itrReqChunkRemaining $ Nothing
 223                                  writeItr itr itrReqChunkIsOver True
 224
 225                                  return $ acceptRequest input''
 226                        (# _, _ #)
 227                            -> return $ chunkWasMalformed itr
 228               -- 最終でないチャンク
 229               (# Success len, input' #)
 230                   -> do writeItr itr itrReqChunkLength $ Just len
 231                         writeItr itr itrReqChunkRemaining $ Just len
 232
 233                         return $ observeChunkedRequest itr input'
 234               -- チャンクヘッダがをかしい
 235               (# _, _ #)
 236                   -> return $ chunkWasMalformed itr
 237
 238       chunkWasMalformed :: Interaction -> IO ()
 239       chunkWasMalformed itr
 240           = {-# SCC "chunkWasMalformed" #-}
 241             atomically $ do updateItr itr itrResponse
 242                                           $ \ res -> res {
 243                                                        resStatus = BadRequest
 244                                                      }
 245                             writeItr itr itrWillClose True
 246                             writeItr itr itrState Done
 247                             writeDefaultPage itr
 248                             postprocess itr
 249
 250       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 251       observeNonChunkedRequest itr input
 252           = {-# SCC "observeNonChunkedRequest" #-}
 253             do action
 254                    <- atomically $
 255                       do wantedM <- readItr itr itrReqBodyWanted id
 256                          if wantedM == Nothing then
 257                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 258                                 if wasteAll then
 259                                     -- 破棄要求が來た
 260                                     do remainingM <- readItr itr itrReqChunkRemaining id
 261
 262                                        let (_, input') = if remainingM == Nothing then
 263                                                              (B.takeWhile (\ _ -> True) input, B.empty)
 264                                                          else
 265                                                              B.splitAt (fromIntegral $ fromJust remainingM) input
 266
 267                                        writeItr itr itrReqChunkRemaining $ Just 0
 268                                        writeItr itr itrReqChunkIsOver True
 269
 270                                        return $ acceptRequest input'
 271                                   else
 272                                     -- 要求がまだ来ない
 273                                     retry
 274                            else
 275                                -- 受信要求が來た
 276                                do remainingM <- readItr itr itrReqChunkRemaining id
 277
 278                                   let wanted          = fromJust wantedM
 279                                       bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
 280                                       (chunk, input') = B.splitAt bytesToRead input
 281                                       newRemaining    = fmap
 282                                                         (\ x -> x - (fromIntegral $ B.length chunk))
 283                                                         remainingM
 284                                       isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
 285
 286                                   writeItr itr itrReqChunkRemaining newRemaining
 287                                   writeItr itr itrReqChunkIsOver isOver
 288                                   writeItr itr itrReqBodyWanted Nothing
 289                                   writeItr itr itrReceivedBody chunk
 290
 291                                   if isOver then
 292                                       return $ acceptRequest input'
 293                                     else
 294                                       return $ observeNonChunkedRequest itr input'
 295                action
 296
 297       enqueue :: Interaction -> STM ()
 298       enqueue itr = {-# SCC "enqueue" #-}
 299                     do queue <- readTVar tQueue
 300                        writeTVar tQueue (itr <| queue)