Merge pull request #14 from geocode-city/basic-rate-limiting

Basic rate limiting

geocode-city-api.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 525eaceaf2e2d5cc83f923332a87f464440a973b44bfca60b8e8cce1368f11e3
+-- hash: 5d0596bb832674fa5ce623837a77f59bb8ffde9e470b037e2efa79949410c210
 
 name:           geocode-city-api
 version:        0.1.0.0
@@ -32,8 +32,10 @@ library
       Database.Pool
       Database.Queries
       Effects
+      Effects.Cache
       Effects.Database
       Effects.Log
+      Effects.Time
       Import
       Server.Auth
       Server.Handlers
@@ -52,6 +54,7 @@ library
     , containers
     , envy
     , fused-effects >=1.1.1.0 && <1.2
+    , hedis
     , http-api-data
     , http-types
     , lens
@@ -86,6 +89,7 @@ executable geocode-city-api-exe
     , envy
     , fused-effects >=1.1.1.0 && <1.2
     , geocode-city-api
+    , hedis
     , http-api-data
     , http-types
     , lens
@@ -125,6 +129,7 @@ test-suite geocode-city-api-test
     , envy
     , fused-effects >=1.1.1.0 && <1.2
     , geocode-city-api
+    , hedis
     , hspec
     , hspec-wai
     , hspec-wai-json

migrations/202101231600_api_quotas.sql

@@ -0,0 +1,2 @@
+alter table account.api_key
+  add column if not exists monthly_quota bigint default 100000;

package.yaml

@@ -42,6 +42,7 @@ dependencies:
 - resource-pool ^>= 0.2.3.2
 - containers
 - lens
+- hedis
 
 ghc-options:
 - -Wall

src/Config.hs

@@ -13,13 +13,20 @@ import System.Envy
     defOption,
     gFromEnvCustom,
   )
+import qualified Data.Pool as P
+import qualified Database.PostgreSQL.Simple as PG
+import qualified Database.Redis as R
 
 data Environment
   = Development
   | Test
   | Production
   deriving stock (Eq, Show, Enum, Read)
 
+data AnonAccess
+  = AlwaysDenyAnon
+  | AlwaysAllowAnon
+  deriving stock (Eq, Show)
 instance Var Environment where
   toVar = show
   fromVar = readMaybe
@@ -28,24 +35,39 @@ newtype DatabaseUrl = DatabaseUrl Text
   deriving newtype (Eq, Show)
   deriving (Var) via Text
 
+newtype RedisUrl = RedisUrl String
+  deriving newtype (Eq, Show)
+  deriving (Var) via String
 -- | Configuration as it comes from the environment; flat, static.
 data AppConfig = AppConfig
   { appPort :: !Int,
     appDeployEnv :: !Environment,
-    appDatabaseUrl :: !DatabaseUrl
+    appDatabaseUrl :: !DatabaseUrl,
+    appRedisUrl    :: !RedisUrl
   }
   deriving stock (Eq, Show, Generic)
 
 instance FromEnv AppConfig where
   -- drop the `app*` prefix that e.g. Heroku will add:
   fromEnv = gFromEnvCustom defOption {dropPrefixCount = 3}
 
+-- opaque "env" to carry/specify runtime dependencies.
+data AppContext = AppContext
+  { ctxRedisConnection :: !R.Connection,
+    ctxDatabasePool :: P.Pool PG.Connection,
+    ctxAnonAccess :: !AnonAccess
+  }
+
+-- | Default app config. Override with environment variables.
 defaultConfig :: AppConfig
 defaultConfig =
   AppConfig
     { appPort = 3000,
       appDeployEnv = Development,
-      appDatabaseUrl = DatabaseUrl "postgresql://localhost/geocode_city_dev?user=luis"
+      appDatabaseUrl = DatabaseUrl "postgresql://localhost/geocode_city_dev?user=luis",
+      -- the underlying lib can parse the right stuff here:
+      -- https://hackage.haskell.org/package/hedis-0.14.1/docs/Database-Redis.html#v:parseConnectInfo
+      appRedisUrl = RedisUrl "redis://"
     }
 
 -- | Log levels

src/Database/Migrations.hs

@@ -5,8 +5,6 @@ import Database.PostgreSQL.Simple (connectPostgreSQL, withTransaction)
 import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), MigrationContext (..), MigrationResult (..), runMigration)
 import Import
 
--- TODO(luis) we may want to take a Bool parameter to send
--- in `MigrationContext`: right now it defaults to verbose.
 runMigrations' :: Bool -> FilePath -> DatabaseUrl -> IO (Either String String)
 runMigrations' isVerbose migrationsDir (DatabaseUrl conStr) = do
   con <- connectPostgreSQL $ encodeUtf8 conStr

src/Database/Queries.hs

@@ -56,11 +56,12 @@ latestUpdate = do
   updatedAts <- query_ "select max(modification) from raw.geonames"
   pure $ fromOnly =<< listToMaybe updatedAts
 
--- | Given an API Key, find out if it exists and is enabled.
-isKeyEnabled :: Has Database sig m => Text -> m Bool
-isKeyEnabled key = do
-  exists <- query "select is_enabled from account.api_key where key = ?" (Only key)
-  pure $ maybe False fromOnly (listToMaybe exists)
+-- | Given an API Key, find out if it exists and is enabled;
+-- return status and current quota.
+findApiKey :: Has Database sig m => Text -> m (Bool, Maybe Integer)
+findApiKey key = do
+  exists <- query "select is_enabled, monthly_quota from account.api_key where key = ?" (Only key)
+  pure $ fromMaybe (False, Just 0) (listToMaybe exists)
 
 
 -- | Fast query for name autocomplete: biased towards more populous cities,

src/Effects.hs

@@ -1,9 +1,15 @@
 module Effects
   ( module Effects.Log
   , module Effects.Database
+  , module Effects.Time
+  , module Effects.Cache
   )
 where
 
 import Effects.Log
 
 import Effects.Database
+--
+import Effects.Cache
+--
+import Effects.Time

src/Effects/Cache.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Effects.Cache where
+
+import Control.Algebra
+import Control.Carrier.Error.Either (ErrorC, Throw, runError)
+import Control.Carrier.Reader
+import Control.Carrier.Throw.Either (throwError)
+import qualified Database.Redis as R
+import Import
+
+---
+
+data Cache (m :: Type -> Type) k where
+  HllAdd :: ByteString -> [ByteString] -> Cache m Integer
+  HllCount :: [ByteString] -> Cache m Integer
+
+hllAdd :: (Has Cache sig m) => ByteString -> [ByteString] -> m Integer
+hllAdd key values = send $ HllAdd key values
+
+hllCount :: (Has Cache sig m) => [ByteString] -> m Integer
+hllCount = send . HllCount
+
+newtype CacheIOC m a = CacheIOC {runCacheIO :: ReaderC R.Connection m a}
+  deriving (Applicative, Functor, Monad, MonadIO)
+
+newtype CacheError = CacheError R.Reply
+  deriving (Eq, Show)
+
+runCacheWithConnection :: R.Connection -> CacheIOC m hs -> m hs
+runCacheWithConnection conn = runReader conn . runCacheIO
+
+instance
+  (Has (Throw CacheError) sig m, MonadIO m, Algebra sig m) =>
+  Algebra (Cache :+: sig) (CacheIOC m)
+  where
+  alg hdl sig ctx = CacheIOC $ case sig of
+    L (HllAdd key values) -> do
+      conn <- ask
+      added <- liftIO $
+        R.runRedis conn $ do
+          R.pfadd key values
+      (<$ ctx) <$> either (throwError . CacheError) pure added
+    L (HllCount keys) -> do
+      conn <- ask
+      count <- liftIO $
+        R.runRedis conn $ do
+          R.pfcount keys
+      (<$ ctx) <$> either (throwError . CacheError) pure count
+    R other -> alg (runCacheIO . hdl) (R other) ctx
+
+runCacheEither :: ErrorC CacheError m a -> m (Either CacheError a)
+runCacheEither = runError @CacheError

src/Effects/Time.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Effects.Time where
+
+import Control.Algebra
+import Data.Time (UTCTime, getCurrentTime)
+import Import
+
+data Time (m :: Type -> Type) k where
+  Now :: Time m UTCTime
+
+now :: (Has Time sig m) => m UTCTime
+now = send Now
+
+newtype TimeIOC m a = TimeIOC {runTimeIO :: m a}
+  deriving (Applicative, Functor, Monad, MonadIO)
+
+instance
+  (MonadIO m, Algebra sig m) =>
+  Algebra (Time :+: sig) (TimeIOC m)
+  where
+  alg hdl sig ctx = case sig of
+    L Now -> (<$ ctx) <$> liftIO getCurrentTime
+    R other -> TimeIOC $ alg (runTimeIO . hdl) other ctx