Create better domain/data layer separation

Author: toddmohney

src/Control/Flipper/Adapters/Postgres.hs

@@ -15,7 +15,6 @@ import qualified Data.Map.Strict                            as Map
 import           Database.Persist.Postgresql                (ConnectionPool)
 
 import           Control.Flipper.Adapters.Postgres.DBAccess (DBAccess, db)
-import           Control.Flipper.Adapters.Postgres.Models   (Entity(..), modelsToFeatures, modelToFeature)
 import qualified Control.Flipper.Adapters.Postgres.Query    as Q
 import           Control.Flipper.Types                      (FeatureName,
                                                              Features (..),
@@ -37,21 +36,16 @@ newtype FlipperT m a = FlipperT { unFlipper :: ReaderT Config m a }
              )
 
 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 _ feature)) -> return $ Just (modelToFeature feature)
+    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 feature = ask >>= \Config{..} ->
-        Q.upsertFeature fName feature appDB
+    updateFeature _ feature = ask >>= \Config{..} ->
+        Q.upsertFeature feature appDB
 
 {- |
 Evaluates a feature-switched computation, returning the final value

src/Control/Flipper/Adapters/Postgres/Models.hs

@@ -18,13 +18,11 @@ module Control.Flipper.Adapters.Postgres.Models
     , module Database.Persist.Postgresql
     ) where
 
-import qualified Data.ByteString.Char8       as C8
 import qualified Data.Map.Strict                            as Map
 import           Data.Monoid                 ((<>))
 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
@@ -49,7 +47,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 |]
 
 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))
 
@@ -59,9 +57,9 @@ instance PersistField F.ActorId where
   fromPersistValue e = Left ("Not PersistByteString " <> T.pack (show e))
 
 instance PersistField F.Percentage where
-  toPersistValue (F.Percentage pct) = PersistDbSpecific . C8.pack $ show pct
+  toPersistValue (F.Percentage pct) = PersistInt64 (fromIntegral pct)
   fromPersistValue (PersistInt64 pct) = Right (F.Percentage (fromIntegral pct))
-  fromPersistValue e = Left ("Not PersistDbSpecific " <> T.pack (show e))
+  fromPersistValue e = Left ("Not PersistInt64 " <> T.pack (show e))
 
 {- |
 Convienience constructor

src/Control/Flipper/Adapters/Postgres/Query.hs

@@ -20,38 +20,69 @@ import           Control.Monad.IO.Class                     (MonadIO, liftIO)
 
 {- |
 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 = do
+    mFeatureEnt <- getFeatureByName' fName dbAccess
+    case mFeatureEnt of
+        Nothing -> return Nothing
+        (Just (Entity _ feature)) -> return . Just . modelToFeature $ feature
+
+{- |
+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 -> T.Feature -> DBAccess m -> app ()
-upsertFeature fName feature 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 (featureToModel feature) >>= void . flip addFeature dbAccess
+            liftIO (featureToModel feature) >>= void . flip addFeature' dbAccess
         (Just (Entity fId f)) ->
             replaceFeature fId (f { featureEnabled = T.isEnabled feature }) dbAccess
 
 {- |
 Inserts a new feature record.
 -}
 addFeature :: (MonadIO app, Monad m)
+           => T.Feature -> DBAccess m -> app (Key Feature)
+addFeature feature dbAccess = do
+    model <- liftIO $ featureToModel feature
+    addFeature' model dbAccess
+
+{- |
+Inserts a new feature record.
+-}
+addFeature' :: (MonadIO app, Monad m)
            => Feature -> DBAccess m -> app (Key Feature)
-addFeature feature DBAccess{..} = liftIO $ runDb (insertFeature feature)
+addFeature' feature DBAccess{..} = liftIO $ runDb (insertFeature feature)
 
 {- |
 Updates an existing feature record.

test/Control/Flipper/Postgres/QuerySpec.hs

@@ -4,7 +4,6 @@ import           Control.Monad                            (void)
 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
@@ -18,18 +17,18 @@ spec = around Cfg.withConfig $ do
         it "creates a new feature when no feature by the given name exists" $ \(Config _ db) -> do
             let name = (T.FeatureName "experimental-feature")
             let feature = (T.mkFeature name) { isEnabled = True }
-            Q.upsertFeature name feature db
-            (Just (Entity _ f)) <- Q.getFeatureByName name db
-            M.featureName f `shouldBe` name
-            M.featureEnabled f `shouldBe` 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
 
-            let f' = (modelToFeature f) { isEnabled = False }
-            Q.upsertFeature name f' db
-            (Just (Entity _ feature)) <- Q.getFeatureByName name db
-            M.featureEnabled feature `shouldBe` False
+            let f' = f { isEnabled = False }
+            Q.upsertFeature f' db
+            (Just feature) <- Q.getFeatureByName name db
+            T.isEnabled feature `shouldBe` False

test/Control/Flipper/PostgresSpec.hs

@@ -47,17 +47,17 @@ spec = around Cfg.withConfig $ do
                 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
                     whenEnabled "enabled-feature" (void $ put (MyState 1))
 
                 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
@@ -100,4 +100,6 @@ spec = around Cfg.withConfig $ do
                     fs'' <- FP.getFeatures
                     liftIO $ all (\f -> isEnabled f == False) (Map.elems (unFeatures fs'')) `shouldBe` True
 
-
+    describe "enabling a feature on a per-user basis" $ do
+        it "runs a feature for enabled users" $ \(Config _ _) -> do
+            pending