diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,11 @@ `wai-rate-limit-postgres` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.6.0.0 + +* Update library to work with wai-rate-limit 0.3.0.0 - needs major bump as types are user visible types are changed. +* Now works work GHC 9.2 + ## 0.5.0.0 * Remove last remaining debug print statement diff --git a/src/Network/Wai/RateLimit/Postgres.hs b/src/Network/Wai/RateLimit/Postgres.hs --- a/src/Network/Wai/RateLimit/Postgres.hs +++ b/src/Network/Wai/RateLimit/Postgres.hs @@ -11,11 +11,15 @@ where import Control.Concurrent (forkIO, threadDelay) -import Control.Exception (Handler (..), catches, throwIO, try) +import Control.Exception (Exception, Handler (..), catches, throwIO, try) +import Control.Monad (forever, void) +import Data.ByteString (ByteString) import Data.Pool (Pool, withResource) +import Data.String (fromString) +import Data.Text (Text, unpack) import qualified Data.Text as T import qualified Database.PostgreSQL.Simple as PG -import Network.Wai.RateLimit.Backend (Backend (..)) +import Network.Wai.RateLimit.Backend (Backend (..), BackendError (..)) -- | Represents reasons for why requests made to Postgres backend have failed. data PGBackendError @@ -35,13 +39,13 @@ initPostgresBackend p tableName = withResource p $ \c -> do res <- try $ PG.execute_ c createTableQuery either - (throwIO . PGBackendErrorInit) + (throwIO . BackendError . PGBackendErrorInit) (const $ return ()) res where createTableQuery = fromString $ - toString $ + unpack $ T.intercalate " " [ "CREATE TABLE IF NOT EXISTS", @@ -53,28 +57,25 @@ sqlHandlers :: [Handler a] sqlHandlers = - [ Handler (throwIO . PGBackendErrorBugFmt), - Handler (throwIO . PGBackendErrorBugQry), - Handler (throwIO . PGBackendErrorBugRes), - Handler (throwIO . PGBackendErrorBugSql) + [ Handler (throwIO . BackendError . PGBackendErrorBugFmt), + Handler (throwIO . BackendError . PGBackendErrorBugQry), + Handler (throwIO . BackendError . PGBackendErrorBugRes), + Handler (throwIO . BackendError . PGBackendErrorBugSql) ] -pgBackendGetUsage :: Pool PG.Connection -> Text -> ByteString -> IO (Either PGBackendError Integer) +pgBackendGetUsage :: Pool PG.Connection -> Text -> ByteString -> IO Integer pgBackendGetUsage p tableName key = withResource p $ \c -> do - res <- - try $ - PG.query c getUsageQuery (PG.Only $ PG.Binary key) `catches` sqlHandlers - return $ do - rows <- res - case rows of - [] -> Right 0 - [PG.Only a] -> Right a - _ -> Left PGBackendErrorAtMostOneRow + rows <- + PG.query c getUsageQuery (PG.Only $ PG.Binary key) `catches` sqlHandlers + case rows of + [] -> pure 0 + [PG.Only a] -> pure a + _ -> throwIO $ BackendError PGBackendErrorAtMostOneRow where getUsageQuery = fromString $ - toString $ + unpack $ T.intercalate " " [ "SELECT usage FROM", @@ -83,18 +84,16 @@ "AND expires_at > CURRENT_TIMESTAMP" ] -pgBackendIncAndGetUsage :: Pool PG.Connection -> Text -> ByteString -> Integer -> IO (Either PGBackendError Integer) +pgBackendIncAndGetUsage :: Pool PG.Connection -> Text -> ByteString -> Integer -> IO Integer pgBackendIncAndGetUsage p tableName key usage = withResource p $ \c -> do - res <- try $ PG.query c incAndGetQuery (PG.Binary key, usage) `catches` sqlHandlers - return $ do - rows <- res - case rows of - [PG.Only a] -> Right a - _ -> Left PGBackendErrorExactlyOneRow + rows <- PG.query c incAndGetQuery (PG.Binary key, usage) `catches` sqlHandlers + case rows of + [PG.Only a] -> pure a + _ -> throwIO $ BackendError PGBackendErrorExactlyOneRow where incAndGetQuery = fromString $ - toString $ + unpack $ T.intercalate " " [ "INSERT INTO", @@ -107,18 +106,16 @@ "RETURNING usage" ] -pgBackendExpireIn :: Pool PG.Connection -> Text -> ByteString -> Integer -> IO (Either PGBackendError ()) +pgBackendExpireIn :: Pool PG.Connection -> Text -> ByteString -> Integer -> IO () pgBackendExpireIn p tableName key seconds = withResource p $ \c -> do - res <- try $ PG.execute c expireInQuery (seconds, PG.Binary key) `catches` sqlHandlers - return $ do - count <- res - if count /= 1 - then Left PGBackendErrorExactlyOneUpdate - else Right () + count <- PG.execute c expireInQuery (seconds, PG.Binary key) `catches` sqlHandlers + if count /= 1 + then throwIO $ BackendError PGBackendErrorExactlyOneUpdate + else pure () where expireInQuery = fromString $ - toString $ + unpack $ T.intercalate " " [ "UPDATE", @@ -152,7 +149,7 @@ removeExpired = fromString $ - toString $ + unpack $ T.intercalate " " [ "DELETE FROM", @@ -166,7 +163,7 @@ -- and table name to use for storage. The table will be created if it does not -- exist. A thread is also launched to periodically clean up expired rows from -- the table. -postgresBackend :: Pool PG.Connection -> Text -> IO (Backend ByteString PGBackendError) +postgresBackend :: Pool PG.Connection -> Text -> IO (Backend ByteString) postgresBackend p tableName = do initPostgresBackend p tableName pgBackendCleanup p tableName diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,7 +7,14 @@ threadDelay, ) import Control.Exception (bracket, throwIO) +import Control.Monad (replicateM, when) +import Data.ByteString (ByteString) +import Data.Either (isRight) import Data.Pool (Pool, createPool) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8') +import Data.Text.Encoding.Error (UnicodeException) +import qualified Data.Time.Units as U import qualified Database.PostgreSQL.Simple as PG import Database.PostgreSQL.Simple.URL (parseDatabaseUrl) import Network.HTTP.Client (Manager, defaultManagerSettings, httpLbs, newManager, parseRequest, responseStatus) @@ -18,7 +25,6 @@ import Network.Wai.RateLimit.Postgres (postgresBackend) import qualified Network.Wai.RateLimit.Strategy as R import System.Environment.Blank (getEnv) -import System.IO.Error (userError) import Test.Tasty (defaultMain) import Test.Tasty.HUnit (assertFailure, testCaseSteps) @@ -44,7 +50,8 @@ pool <- mkConnPool pgBackend <- postgresBackend pool "rate_limiter_1" let app _ respond = respond $ Wai.responseLBS status200 [] "Ok!" - strategy = R.fixedWindow pgBackend seconds limit (const $ return key) + s = U.fromMicroseconds $ 1_000_000 * seconds + strategy = R.fixedWindow pgBackend s limit (const $ return key) middleware = R.rateLimiting strategy return $ middleware app @@ -62,64 +69,65 @@ main :: IO () main = - defaultMain $ - testCaseSteps + defaultMain + $ testCaseSteps "Rate Limiting Tests" - $ \step -> - do - step "Limit excessive requests (1)" - bracket - (mkTestWaiApp 1 2 "key1" >>= launchApp) - tearDownApp - $ \_ -> do - mgr <- newManager defaultManagerSettings - rs <- replicateM 3 $ mkReq mgr - when (rs /= [200, 200, 429]) $ do - assertFailure "Not ratelimited!" + $ \step -> + do + step "Limit excessive requests (1)" + bracket + (mkTestWaiApp 1 2 "key1" >>= launchApp) + tearDownApp + $ \_ -> do + mgr <- newManager defaultManagerSettings + rs <- replicateM 3 $ mkReq mgr + when (rs /= [200, 200, 429]) $ do + assertFailure "Not ratelimited!" - step "Limit excessive requests (2)" - bracket - (mkTestWaiApp 1 3 "key2" >>= launchApp) - tearDownApp - $ \_ -> do - mgr <- newManager defaultManagerSettings - rs <- replicateM 10 $ mkReq mgr - when (rs /= replicate 3 200 ++ replicate 7 429) $ - assertFailure "Unexpected result!" + step "Limit excessive requests (2)" + bracket + (mkTestWaiApp 1 3 "key2" >>= launchApp) + tearDownApp + $ \_ -> do + mgr <- newManager defaultManagerSettings + rs <- replicateM 10 $ mkReq mgr + when (rs /= replicate 3 200 ++ replicate 7 429) $ + assertFailure "Unexpected result!" - step "Allow non-excessive requests" - bracket - (mkTestWaiApp 1 3 "key3" >>= launchApp) - tearDownApp - $ \_ -> do - mgr <- newManager defaultManagerSettings - rs <- replicateM 3 $ mkReq mgr - when (rs /= [200, 200, 200]) $ - assertFailure "Unexpected result!" + step "Allow non-excessive requests" + bracket + (mkTestWaiApp 1 3 "key3" >>= launchApp) + tearDownApp + $ \_ -> do + mgr <- newManager defaultManagerSettings + rs <- replicateM 3 $ mkReq mgr + when (rs /= [200, 200, 200]) $ + assertFailure "Unexpected result!" - step "Allow excessive requests, slow down and then be allowed" - bracket - (mkTestWaiApp 1 1 "key4" >>= launchApp) - tearDownApp - $ \_ -> do - mgr <- newManager defaultManagerSettings - rs <- replicateM 3 $ mkReq mgr - when (rs /= [200, 429, 429]) $ - assertFailure "Unexpected result!" - threadDelay 1_000_000 - rs2 <- replicateM 1 $ mkReq mgr - when (rs2 /= [200]) $ - assertFailure "Unexpected result!" + step "Allow excessive requests, slow down and then be allowed" + bracket + (mkTestWaiApp 1 1 "key4" >>= launchApp) + tearDownApp + $ \_ -> do + mgr <- newManager defaultManagerSettings + rs <- replicateM 3 $ mkReq mgr + when (rs /= [200, 429, 429]) $ + assertFailure "Unexpected result!" + threadDelay 1_000_000 + rs2 <- replicateM 1 $ mkReq mgr + when (rs2 /= [200]) $ + assertFailure "Unexpected result!" - step "Allow keys that are invalid as unicode strings" - let invalidUtf8String = "\187" :: ByteString - when (isRight (decodeUtf8Strict invalidUtf8String :: Either UnicodeException Text)) $ - assertFailure "`invalidUtf8String` appears to have a valid UTF8 string" - bracket - (mkTestWaiApp 1 3 invalidUtf8String >>= launchApp) - tearDownApp - $ \_ -> do - mgr <- newManager defaultManagerSettings - rs <- replicateM 3 $ mkReq mgr - when (rs /= [200, 200, 200]) $ - assertFailure $ "Unexpected result: " ++ show rs + step "Allow keys that are invalid as unicode strings" + let invalidUtf8String = "\187" :: ByteString + when (isRight (decodeUtf8' invalidUtf8String :: Either UnicodeException Text)) $ + assertFailure "`invalidUtf8String` appears to have a valid UTF8 string" + bracket + (mkTestWaiApp 1 3 invalidUtf8String >>= launchApp) + tearDownApp + $ \_ -> do + mgr <- newManager defaultManagerSettings + rs <- replicateM 3 $ mkReq mgr + when (rs /= [200, 200, 200]) $ + assertFailure $ + "Unexpected result: " ++ show rs diff --git a/wai-rate-limit-postgres.cabal b/wai-rate-limit-postgres.cabal --- a/wai-rate-limit-postgres.cabal +++ b/wai-rate-limit-postgres.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: wai-rate-limit-postgres -version: 0.5.0.0 +version: 0.6.0.0 category: Security, Web, Network synopsis: See README for more info description: @@ -17,21 +17,19 @@ CHANGELOG.md tested-with: GHC == 8.10.7 GHC == 9.0.2 + GHC == 9.2.3 source-repository head type: git location: https://github.com/donatello/wai-rate-limit-postgres.git common common-options - build-depends: base >= 4.12 && < 5 - , relude ^>= 1.0 - , wai-rate-limit ^>= 0.1.0.0 + build-depends: base >= 4.14 && < 5 + , bytestring >= 0.10 && < 0.12 + , wai-rate-limit >= 0.3.0.0 && < 1.0 , postgresql-simple ^>= 0.6 - , text ^>= 1.2.4 - , resource-pool ^>= 0.2.3.2 - - mixins: base hiding (Prelude) - , relude (Relude as Prelude) + , text >= 1.2.4 && < 2.1 + , resource-pool >= 0.2.3.2 && < 0.4 ghc-options: -Wall -Wcompat @@ -72,9 +70,10 @@ main-is: Spec.hs build-depends: wai-rate-limit-postgres , postgresql-simple-url - , resource-pool + , resource-pool < 0.3 , tasty , tasty-hunit + , time-units , http-client , http-types , warp