diff --git a/feature-flipper-postgres.cabal b/feature-flipper-postgres.cabal --- a/feature-flipper-postgres.cabal +++ b/feature-flipper-postgres.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: feature-flipper-postgres -version: 0.1.0.1 +version: 0.1.1.1 synopsis: A minimally obtrusive feature flag library description: A minimally obtrusive feature flag library homepage: https://github.com/toddmohney/flipper-postgres#readme diff --git a/src/Control/Flipper/Adapters/Postgres.hs b/src/Control/Flipper/Adapters/Postgres.hs --- a/src/Control/Flipper/Adapters/Postgres.hs +++ b/src/Control/Flipper/Adapters/Postgres.hs @@ -15,7 +15,6 @@ import Database.Persist.Postgresql (ConnectionPool) import Control.Flipper.Adapters.Postgres.DBAccess (DBAccess, db) -import Control.Flipper.Adapters.Postgres.Models import qualified Control.Flipper.Adapters.Postgres.Query as Q import Control.Flipper.Types (FeatureName, Features (..), @@ -37,21 +36,16 @@ ) instance (MonadIO m) => HasFeatureFlags (FlipperT m) where - getFeatures = ask >>= \Config{..} -> - modelsToFeatures <$> Q.getFeatures appDB + getFeatures = ask >>= \Config{..} -> Q.getFeatures appDB - getFeature name = ask >>= \Config{..} -> do - mFeature <- Q.getFeatureByName name appDB - case mFeature of - Nothing -> return Nothing - (Just (Entity _ f)) -> return $ Just (featureEnabled f) + getFeature name = ask >>= \Config{..} -> Q.getFeatureByName name appDB instance (MonadIO m) => ModifiesFeatureFlags (FlipperT m) where updateFeatures features = void $ Map.traverseWithKey updateFeature (unFeatures features) - updateFeature fName isEnabled = ask >>= \Config{..} -> - Q.upsertFeature fName isEnabled appDB + updateFeature _ feature = ask >>= \Config{..} -> + Q.upsertFeature feature appDB {- | Evaluates a feature-switched computation, returning the final value @@ -61,13 +55,6 @@ runFlipperT pool f = let cfg = Config pool (db pool) in runReaderT (unFlipper f) cfg - -modelsToFeatures :: [Entity Feature] -> Features -modelsToFeatures fs = Features $ Map.fromList $ map mkFeature' fs - where - mkFeature' :: Entity Feature -> (FeatureName, Bool) - mkFeature' (Entity _ feature) = - (featureName feature, featureEnabled feature) data Config = forall m. (Monad m) => Config { appDBConn :: ConnectionPool diff --git a/src/Control/Flipper/Adapters/Postgres/DBAccess.hs b/src/Control/Flipper/Adapters/Postgres/DBAccess.hs --- a/src/Control/Flipper/Adapters/Postgres/DBAccess.hs +++ b/src/Control/Flipper/Adapters/Postgres/DBAccess.hs @@ -17,9 +17,13 @@ -} data DBAccess m = DBAccess { runDb :: forall a . m a -> IO a , selectFeatures :: m [Entity Feature] + , selectActorsByFeatureId :: FeatureId -> m [Entity Actor] , findFeature :: T.FeatureName -> m (Maybe (Entity Feature)) + , insertActor :: Actor -> m (Key Actor) + , deleteActor :: FeatureId -> T.ActorId -> m () , insertFeature :: Feature -> m (Key Feature) , updateFeature :: FeatureId -> Feature -> m () + , countActors :: m Int , countFeatures :: m Int } @@ -29,9 +33,13 @@ db :: ConnectionPool -> DBAccess (SqlPersistT IO) db pool = DBAccess { runDb = runDb' pool , selectFeatures = Q.selectFeatures + , selectActorsByFeatureId = Q.selectActorsByFeatureId , findFeature = Q.findFeature + , insertActor = Q.insertActor + , deleteActor = Q.deleteActor , insertFeature = Q.insertFeature , updateFeature = Q.updateFeature + , countActors = Q.countActors , countFeatures = Q.countFeatures } where diff --git a/src/Control/Flipper/Adapters/Postgres/Internal/Query.hs b/src/Control/Flipper/Adapters/Postgres/Internal/Query.hs --- a/src/Control/Flipper/Adapters/Postgres/Internal/Query.hs +++ b/src/Control/Flipper/Adapters/Postgres/Internal/Query.hs @@ -1,8 +1,12 @@ module Control.Flipper.Adapters.Postgres.Internal.Query ( selectFeatures + , selectActorsByFeatureId , findFeature + , insertActor + , deleteActor , insertFeature , updateFeature + , countActors , countFeatures ) where @@ -16,12 +20,30 @@ selectFeatures = selectList [] [] {- | +Selects all actors for a given feature records +-} +selectActorsByFeatureId :: FeatureId -> SqlPersistT IO [Entity Actor] +selectActorsByFeatureId fId = selectList [ActorFeatureId ==. fId] [] + +{- | Selects a feature record by its unique name -} findFeature :: T.FeatureName -> SqlPersistT IO (Maybe (Entity Feature)) findFeature fName = getBy (UniqueFeatureName fName) {- | +Inserts a new actor record. +-} +insertActor :: Actor -> SqlPersistT IO (Key Actor) +insertActor = insert + +{- | +Deletes an actor record. +-} +deleteActor :: FeatureId -> T.ActorId -> SqlPersistT IO () +deleteActor fId aId = deleteBy (UniqueActorIdFeatureId aId fId) + +{- | Inserts a new feature record. -} insertFeature :: Feature -> SqlPersistT IO (Key Feature) @@ -38,3 +60,9 @@ -} countFeatures :: SqlPersistT IO Int countFeatures = count ([] :: [Filter Feature]) + +{- | +Returns a count of all feature records +-} +countActors :: SqlPersistT IO Int +countActors = count ([] :: [Filter Actor]) diff --git a/src/Control/Flipper/Adapters/Postgres/Models.hs b/src/Control/Flipper/Adapters/Postgres/Models.hs --- a/src/Control/Flipper/Adapters/Postgres/Models.hs +++ b/src/Control/Flipper/Adapters/Postgres/Models.hs @@ -18,10 +18,12 @@ , module Database.Persist.Postgresql ) where +import qualified Data.Map.Strict as Map import Data.Monoid ((<>)) +import Data.Set (Set) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as T import Data.Time (UTCTime (..), getCurrentTime) import Database.Persist.Postgresql import Database.Persist.TH @@ -29,9 +31,18 @@ import qualified Control.Flipper.Types as F share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| - Feature sql=feature_flipper_features + Actor sql=flipper_actors + actorId F.ActorId sqltype=bytea + featureId FeatureId sqltype=bigint + updated UTCTime default=now() + created UTCTime default=now() + UniqueActorIdFeatureId actorId featureId + deriving Show Eq + + Feature sql=flipper_features name F.FeatureName sqltype=text enabled Bool sqltype=boolean default=false + enabledPercentage F.Percentage sqltype=int default=0 updated UTCTime default=now() created UTCTime default=now() UniqueFeatureName name @@ -39,10 +50,22 @@ |] instance PersistField F.FeatureName where - toPersistValue = PersistDbSpecific . T.encodeUtf8 . F.unFeatureName + toPersistValue = PersistText . F.unFeatureName fromPersistValue (PersistText name) = Right (F.FeatureName name) fromPersistValue name = Left ("Not PersistText " <> T.pack (show name)) +instance PersistField F.ActorId where + toPersistValue (F.ActorId actorId) = PersistByteString actorId + fromPersistValue (PersistByteString actorId) = Right (F.ActorId actorId) + fromPersistValue e = Left ("Not PersistByteString " <> T.pack (show e)) + +instance PersistField F.Percentage where + toPersistValue (F.Percentage pct) = PersistInt64 (fromIntegral pct) + fromPersistValue (PersistInt64 pct) = Right (F.Percentage (fromIntegral pct)) + fromPersistValue e = Left ("Not PersistInt64 " <> T.pack (show e)) + +type FeatureWithActorIds = (Feature, Set F.ActorId) + {- | Convienience constructor -} @@ -52,9 +75,51 @@ return Feature { featureName = fName , featureEnabled = isEnabled + , featureEnabledPercentage = 0 , featureUpdated = now , featureCreated = now } + +modelsToFeatures :: [Entity Feature] -> F.Features +modelsToFeatures fs = F.Features $ Map.fromList $ map (toFeatureTuple . modelToFeature . entityVal) fs + +modelToFeature :: Feature -> F.Feature +modelToFeature feature = F.Feature + { F.featureName = featureName feature + , F.isEnabled = featureEnabled feature + , F.enabledActors = S.empty + , F.enabledPercentage = featureEnabledPercentage feature + } + +actorIdToModel :: F.ActorId -> FeatureId -> IO Actor +actorIdToModel a f = do + now <- getCurrentTime + return Actor + { actorActorId = a + , actorFeatureId = f + , actorUpdated = now + , actorCreated = now + } + +featureToModel :: F.Feature -> IO FeatureWithActorIds +featureToModel f = do + now <- getCurrentTime + return (feature now, actorIds) + where + actorIds :: Set F.ActorId + actorIds = F.enabledActors f + + feature :: UTCTime -> Feature + feature now = Feature + { featureName = F.featureName f + , featureEnabled = F.isEnabled f + , featureEnabledPercentage = F.enabledPercentage f + , featureUpdated = now + , featureCreated = now + } + +toFeatureTuple :: F.Feature -> (F.FeatureName, F.Feature) +toFeatureTuple f = (F.featureName f, f) {- | Performs non-destructive database schema migrations. diff --git a/src/Control/Flipper/Adapters/Postgres/Query.hs b/src/Control/Flipper/Adapters/Postgres/Query.hs --- a/src/Control/Flipper/Adapters/Postgres/Query.hs +++ b/src/Control/Flipper/Adapters/Postgres/Query.hs @@ -4,13 +4,15 @@ ( getFeatures , getFeatureByName , addFeature - , replaceFeature , upsertFeature + , actorCount , featureCount , M.mkFeature ) where -import Control.Monad (void) +import Control.Monad (forM_, void) +import Data.Set (Set) +import qualified Data.Set as S import Data.Time.Clock (getCurrentTime) import Control.Flipper.Adapters.Postgres.DBAccess as DB @@ -20,51 +22,120 @@ {- | Selects all feature records +Returns domain model -} getFeatures :: (MonadIO app, Monad m) + => DBAccess m -> app T.Features +getFeatures dbAccess = modelsToFeatures <$> getFeatures' dbAccess + +{- | +Selects all feature records +Returns database entities +-} +getFeatures' :: (MonadIO app, Monad m) => DBAccess m -> app [Entity Feature] -getFeatures DBAccess{..} = liftIO $ runDb selectFeatures +getFeatures' DBAccess{..} = liftIO $ runDb selectFeatures {- | Selects a feature record by its unique name +Returns a domain model -} getFeatureByName :: (MonadIO app, Monad m) + => T.FeatureName -> DBAccess m -> app (Maybe T.Feature) +getFeatureByName fName dbAccess@DBAccess{..} = do + mFeatureEnt <- getFeatureByName' fName dbAccess + case mFeatureEnt of + Nothing -> return Nothing + (Just (Entity fId feature)) -> do + -- use Esqueleto to join this relation + actors <- liftIO $ runDb (selectActorsByFeatureId fId) + let f = (modelToFeature feature) { T.enabledActors = S.fromList (map (actorActorId . entityVal) actors) } + return . Just $ f + +{- | +Selects a feature record by its unique name +Returns a database entity +-} +getFeatureByName' :: (MonadIO app, Monad m) => T.FeatureName -> DBAccess m -> app (Maybe (Entity Feature)) -getFeatureByName fName DBAccess{..} = liftIO $ runDb (findFeature fName) +getFeatureByName' fName DBAccess{..} = liftIO $ runDb (findFeature fName) {- | Inserts a new feature record if one with a matching name does not already exist. Updates an existing feature record if one with a matching name already exists. -} upsertFeature :: (MonadIO app, Monad m) - => T.FeatureName -> Bool -> DBAccess m -> app () -upsertFeature fName isEnabled dbAccess = do - mFeature <- getFeatureByName fName dbAccess + => T.Feature -> DBAccess m -> app () +upsertFeature feature dbAccess = do + mFeature <- getFeatureByName' (T.featureName feature) dbAccess case mFeature of Nothing -> - liftIO (mkFeature fName isEnabled) >>= void . flip addFeature dbAccess - (Just (Entity fId f)) -> - replaceFeature fId (f { featureEnabled = isEnabled }) dbAccess + liftIO (featureToModel feature) >>= void . flip addFeature' dbAccess + (Just (Entity fId _)) -> do + updatedFeature <- liftIO $ featureToModel feature + replaceFeature fId updatedFeature dbAccess {- | -Inserts a new feature record. +Inserts a new feature record and all associated actors. -} addFeature :: (MonadIO app, Monad m) - => Feature -> DBAccess m -> app (Key Feature) -addFeature feature DBAccess{..} = liftIO $ runDb (insertFeature feature) + => T.Feature -> DBAccess m -> app (Key Feature) +addFeature feature dbAccess = do + model <- liftIO $ featureToModel feature + addFeature' model dbAccess {- | +Inserts a new feature record and all associated actors. +-} +addFeature' :: (MonadIO app, Monad m) + => FeatureWithActorIds -> DBAccess m -> app (Key Feature) +addFeature' (feature, actorIds) dbAccess@DBAccess{..} = do + key <- liftIO $ runDb (insertFeature feature) + addActors actorIds key dbAccess + return key + +addActors :: (MonadIO app, Monad m) + => Set T.ActorId -> FeatureId -> DBAccess m -> app () +addActors actorIds fId DBAccess{..} = + liftIO $ forM_ actorIds $ \aId -> + actorIdToModel aId fId >>= runDb . insertActor + +deleteActors :: (MonadIO app, Monad m) + => Set T.ActorId -> FeatureId -> DBAccess m -> app () +deleteActors actorIds fId DBAccess{..} = + liftIO $ forM_ actorIds $ runDb . deleteActor fId + +{- | Updates an existing feature record. -} replaceFeature :: (MonadIO app, Monad m) - => FeatureId -> Feature -> DBAccess m -> app () -replaceFeature fId feature DBAccess{..} = do + => FeatureId -> FeatureWithActorIds -> DBAccess m -> app () +replaceFeature fId (feature, newActorIds) dbAccess@DBAccess{..} = do now <- liftIO getCurrentTime + oldActorIds <- (S.fromList . map (actorActorId . entityVal)) <$> liftIO (runDb (selectActorsByFeatureId fId)) + + let (toAdd, toDelete) = actorDiff oldActorIds newActorIds + addActors toAdd fId dbAccess + deleteActors toDelete fId dbAccess + liftIO $ runDb (updateFeature fId (feature { featureUpdated = now })) +actorDiff :: Set T.ActorId -> Set T.ActorId -> (Set T.ActorId, Set T.ActorId) +actorDiff oldActorIds newActorIds = + let actorIdsToAdd = S.difference newActorIds oldActorIds + actorIdsToDelete = S.difference oldActorIds newActorIds + in (actorIdsToAdd, actorIdsToDelete) + {- | Returns a count of all feature records -} featureCount :: (MonadIO app, Monad m) => DBAccess m -> app Int featureCount DBAccess{..} = liftIO $ runDb countFeatures + +{- | +Returns a count of all actor records +-} +actorCount :: (MonadIO app, Monad m) + => DBAccess m -> app Int +actorCount DBAccess{..} = liftIO $ runDb countActors diff --git a/test/Control/Flipper/Postgres/QuerySpec.hs b/test/Control/Flipper/Postgres/QuerySpec.hs --- a/test/Control/Flipper/Postgres/QuerySpec.hs +++ b/test/Control/Flipper/Postgres/QuerySpec.hs @@ -1,33 +1,59 @@ module Control.Flipper.Postgres.QuerySpec (main, spec) where -import Control.Monad (void) +import Control.Monad (void) +import qualified Data.Set as S import Test.Hspec import Control.Flipper.Adapters.Postgres -import Control.Flipper.Adapters.Postgres.Models as M -import qualified Control.Flipper.Adapters.Postgres.Query as Q -import qualified Control.Flipper.Types as T -import qualified Helpers.Config as Cfg + ( ActorId(..) + , Config(..) + , Feature(..) + ) +import qualified Control.Flipper.Adapters.Postgres.Query as Q +import qualified Control.Flipper.Types as T +import qualified Helpers.Config as Cfg main :: IO () main = hspec spec spec :: Spec spec = around Cfg.withConfig $ do + describe "addFeature" $ do + it "creates a new Feature and all associated Actors" $ \(Config _ db) -> do + let actors = S.fromList [ActorId "thing:123", ActorId "blah:456", ActorId "nah:789"] + let feature = (T.mkFeature "my-feature") { enabledActors = actors } + void $ Q.upsertFeature feature db + Q.featureCount db `shouldReturn` 1 + Q.actorCount db `shouldReturn` 3 + + it "handles duplicate actors" $ \(Config _ db) -> do + let actors = S.fromList [ActorId "thing:123", ActorId "blah:456", ActorId "nah:789"] + let feature = (T.mkFeature "my-feature") { enabledActors = actors } + void $ Q.upsertFeature feature db + + + let actors' = S.fromList [ActorId "blah:456", ActorId "nah:789", ActorId "ack:000", ActorId "ack:001"] + let feature' = (T.mkFeature "my-feature") { enabledActors = actors' } + void $ Q.upsertFeature feature' db + Q.featureCount db `shouldReturn` 1 + Q.actorCount db `shouldReturn` 4 + describe "upsertFeature" $ do it "creates a new feature when no feature by the given name exists" $ \(Config _ db) -> do let name = (T.FeatureName "experimental-feature") - Q.upsertFeature name True db - (Just (Entity _ feature)) <- Q.getFeatureByName name db - featureName feature `shouldBe` name - featureEnabled feature `shouldBe` True + let feature = (T.mkFeature name) { isEnabled = True } + Q.upsertFeature feature db + (Just f) <- Q.getFeatureByName name db + T.featureName f `shouldBe` name + T.isEnabled f `shouldBe` True it "updates an existing feature when a feature by the given name exists" $ \(Config _ db) -> do let name = (T.FeatureName "experimental-feature") - f <- M.mkFeature name True + let f = (T.mkFeature name) { isEnabled = True } void $ Q.addFeature f db Q.featureCount db `shouldReturn` 1 - Q.upsertFeature name False db - (Just (Entity _ feature)) <- Q.getFeatureByName name db - featureEnabled feature `shouldBe` False + let f' = f { isEnabled = False } + Q.upsertFeature f' db + (Just feature) <- Q.getFeatureByName name db + T.isEnabled feature `shouldBe` False diff --git a/test/Control/Flipper/PostgresSpec.hs b/test/Control/Flipper/PostgresSpec.hs --- a/test/Control/Flipper/PostgresSpec.hs +++ b/test/Control/Flipper/PostgresSpec.hs @@ -5,7 +5,9 @@ import Control.Monad (void) import Control.Monad.Reader import Control.Monad.State +import qualified Data.ByteString.Char8 as C8 import Data.Map.Strict as Map +import qualified Data.Set as Set import Test.Hspec import Control.Flipper.Adapters.Postgres as FP @@ -47,8 +49,8 @@ st `shouldBe` MyState 0 describe "a persisted feature" $ do - it "runs features when it is enabled" $ \(Config pool dbAccess) -> do - f <- Q.mkFeature (FP.FeatureName "enabled-feature") True + it "runs a feature when it is enabled" $ \(Config pool dbAccess) -> do + let f = (FP.mkFeature "enabled-feature") { isEnabled = True } void $ Q.addFeature f dbAccess (_, st) <- runMyContext pool (MyState 0) $ do @@ -56,8 +58,8 @@ st `shouldBe` MyState 1 - it "does not run features it is are disabled" $ \(Config pool dbAccess) -> do - f <- Q.mkFeature (FP.FeatureName "disabled-feature") False + it "does not run disabled features" $ \(Config pool dbAccess) -> do + let f = (FP.mkFeature "disabled-feature") { isEnabled = False } void $ Q.addFeature f dbAccess (_, st) <- runMyContext pool (MyState 0) $ do @@ -66,29 +68,64 @@ st `shouldBe` MyState 0 describe "modifying feature flags" $ do - describe "new feature flags" $ do + describe "adding new feature flags" $ do it "creates new records" $ \(Config pool dbAccess) -> do featureCount dbAccess `shouldReturn` 0 (_, _) <- runMyContext pool (MyState 0) $ do - let fs = Features $ Map.fromList [ ("my-new-feature", True), ("some-other-feature", True) ] + let feature1 = (FP.mkFeature "my-new-feature") { isEnabled = True } + let feature2 = (FP.mkFeature "some-other-feature") { isEnabled = True } + let fs = Features $ Map.fromList [ (featureName feature1, feature1), (featureName feature2, feature2) ] updateFeatures fs featureCount dbAccess `shouldReturn` 2 - it "updates existing records" $ \(Config pool dbAccess) -> do + it "updating existing feature records" $ \(Config pool dbAccess) -> do featureCount dbAccess `shouldReturn` 0 void $ runMyContext pool (MyState 0) $ do - let fs = Features $ Map.fromList [ ("my-new-feature", True), ("some-other-feature", True) ] + let feature1 = (FP.mkFeature "my-new-feature") { isEnabled = True } + let feature2 = (FP.mkFeature "some-other-feature") { isEnabled = True } + let featureList = [ (featureName feature1, feature1), (featureName feature2, feature2) ] + let fs = Features $ Map.fromList featureList updateFeatures fs liftIO $ featureCount dbAccess `shouldReturn` 2 - let fs' = Features $ Map.fromList [ ("my-new-feature", False), ("some-other-feature", False), ("hi-there", False) ] + let feature1' = (FP.mkFeature "my-new-feature") { isEnabled = False } + let feature2' = (FP.mkFeature "some-other-feature") { isEnabled = False } + let feature3' = (FP.mkFeature "hi-there") { isEnabled = False } + let featureList' = [ (featureName feature1', feature1'), (featureName feature2', feature2'), (featureName feature3', feature3') ] + let fs' = Features $ Map.fromList featureList' updateFeatures fs' liftIO $ featureCount dbAccess `shouldReturn` 3 fs'' <- FP.getFeatures - liftIO $ all (== False) (Map.elems (unFeatures fs'')) `shouldBe` True + liftIO $ all (\f -> isEnabled f == False) (Map.elems (unFeatures fs'')) `shouldBe` True + describe "enabling a feature for a specific actor" $ do + it "runs a feature for enabled users" $ \(Config pool _) -> do + let actor1 = User 1 + let actor2 = User 2 + -- setup the features + runFlipperT pool $ do + -- here, we only enable the feature for actor1 + let feature = (FP.mkFeature "vrry-special-feature") { isEnabled = False, enabledActors = Set.singleton (actorId actor1) } + let fs = Features $ Map.singleton (featureName feature) feature + updateFeatures fs + + -- run some computation with feature flippers + (_, st) <- runMyContext pool (MyState 0) $ do + whenEnabledFor "vrry-special-feature" actor1 $ + (void $ put (MyState 1)) + + whenEnabledFor "vrry-special-feature" actor2 $ + (void $ put (MyState 2)) + + st `shouldBe` MyState 1 + +data User = User { userId :: Int } + deriving (Show, Eq) + +instance HasActorId User where + actorId = ActorId . C8.pack . show . userId diff --git a/test/Helpers/Database.hs b/test/Helpers/Database.hs --- a/test/Helpers/Database.hs +++ b/test/Helpers/Database.hs @@ -62,7 +62,10 @@ truncateDatabase :: ConnectionPool -> IO () truncateDatabase pool = do + runSqlPool truncateActorsQuery pool runSqlPool truncateFeaturesQuery pool where truncateFeaturesQuery = - rawExecute "TRUNCATE TABLE feature_flipper_features RESTART IDENTITY;" [] + rawExecute "TRUNCATE TABLE flipper_features RESTART IDENTITY CASCADE;" [] + truncateActorsQuery = + rawExecute "TRUNCATE TABLE flipper_actors RESTART IDENTITY CASCADE;" []