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                                                            updateItr itrReceivedBodyLen (+ actualReadBytes) itr
 194
 195                                               if newRemaining == Just 0 then
 196                                                   -- チャンクフッタを讀む
 197                                                   case parse chunkFooterP input' of
 198                                                     (# Success _, input'' #)
 199                                                         -> do updateStates
 200                                                               return $ observeChunkedRequest itr input''
 201                                                     (# _, _ #)
 202                                                         -> return $ chunkWasMalformed itr
 203                                                 else
 204                                                   -- まだチャンクの終はりに達してゐない
 205                                                   do updateStates
 206                                                      return $ observeChunkedRequest itr input'
 207                                          else
 208                                            -- 次のチャンクを讀み始める
 209                                            seekNextChunk itr input
 210                action
 211
 212       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
 213       seekNextChunk itr input
 214           = {-# SCC "seekNextChunk" #-}
 215             case parse chunkHeaderP input of
 216               -- 最終チャンク (中身が空)
 217               (# Success 0, input' #)
 218                   -> case parse chunkTrailerP input' of
 219                        (# Success _, input'' #)
 220                            -> do writeItr itr itrReqChunkLength $ Nothing
 221                                  writeItr itr itrReqChunkRemaining $ Nothing
 222                                  writeItr itr itrReqChunkIsOver True
 223
 224                                  return $ acceptRequest input''
 225                        (# _, _ #)
 226                            -> return $ chunkWasMalformed itr
 227               -- 最終でないチャンク
 228               (# Success len, input' #)
 229                   -> do writeItr itr itrReqChunkLength $ Just len
 230                         writeItr itr itrReqChunkRemaining $ Just len
 231
 232                         return $ observeChunkedRequest itr input'
 233               -- チャンクヘッダがをかしい
 234               (# _, _ #)
 235                   -> return $ chunkWasMalformed itr
 236
 237       chunkWasMalformed :: Interaction -> IO ()
 238       chunkWasMalformed itr
 239           = {-# SCC "chunkWasMalformed" #-}
 240             atomically $ do updateItr itr itrResponse
 241                                           $ \ res -> res {
 242                                                        resStatus = BadRequest
 243                                                      }
 244                             writeItr itr itrWillClose True
 245                             writeItr itr itrState Done
 246                             writeDefaultPage itr
 247                             postprocess itr
 248
 249       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 250       observeNonChunkedRequest itr input
 251           = {-# SCC "observeNonChunkedRequest" #-}
 252             do action
 253                    <- atomically $
 254                       do wantedM <- readItr itr itrReqBodyWanted id
 255                          if wantedM == Nothing then
 256                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 257                                 if wasteAll then
 258                                     -- 破棄要求が來た
 259                                     do remainingM <- readItr itr itrReqChunkRemaining id
 260
 261                                        let (_, input') = if remainingM == Nothing then
 262                                                              (B.takeWhile (\ _ -> True) input, B.empty)
 263                                                          else
 264                                                              B.splitAt (fromIntegral $ fromJust remainingM) input
 265
 266                                        writeItr itr itrReqChunkRemaining $ Just 0
 267                                        writeItr itr itrReqChunkIsOver True
 268
 269                                        return $ acceptRequest input'
 270                                   else
 271                                     -- 要求がまだ来ない
 272                                     retry
 273                            else
 274                                -- 受信要求が來た
 275                                do remainingM <- readItr itr itrReqChunkRemaining id
 276
 277                                   let wanted          = fromJust wantedM
 278                                       bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
 279                                       (chunk, input') = B.splitAt bytesToRead input
 280                                       actualReadBytes = fromIntegral $ B.length chunk
 281                                       newRemaining    = (- actualReadBytes) <$> remainingM
 282                                       isOver          = actualReadBytes < 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                                   writeItr itrReceivedBody actualReadBytes
 289
 290                                   if isOver then
 291                                       return $ acceptRequest input'
 292                                     else
 293                                       return $ observeNonChunkedRequest itr input'
 294                action
 295
 296       enqueue :: Interaction -> STM ()
 297       enqueue itr = {-# SCC "enqueue" #-}
 298                     do queue <- readTVar tQueue
 299                        writeTVar tQueue (itr <| queue)