feature-flipper-postgres 0.1.0.1 → 0.1.1.1

raw patch · 9 files changed

+285/−60 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• feature-flipper-postgres.cabal +1/−1
• src/Control/Flipper/Adapters/Postgres.hs +4/−17
• src/Control/Flipper/Adapters/Postgres/DBAccess.hs +8/−0
• src/Control/Flipper/Adapters/Postgres/Internal/Query.hs +28/−0
• src/Control/Flipper/Adapters/Postgres/Models.hs +68/−3
• src/Control/Flipper/Adapters/Postgres/Query.hs +86/−15
• test/Control/Flipper/Postgres/QuerySpec.hs +39/−13
• test/Control/Flipper/PostgresSpec.hs +47/−10
• test/Helpers/Database.hs +4/−1

@@ -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

@@ -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

@@ -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

@@ -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])

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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;" []