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