packages feed

feature-flipper-postgres (empty) → 0.1.0.0

raw patch · 14 files changed

+615/−0 lines, 14 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, feature-flipper, feature-flipper-postgres, hspec, monad-logger, mtl, persistent, persistent-postgresql, persistent-template, text, time

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Todd Mohney (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Todd Mohney nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# feature-flipper-postgres
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ feature-flipper-postgres.cabal view
@@ -0,0 +1,77 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name:                feature-flipper-postgres+version:             0.1.0.0+synopsis:            A minimally obtrusive feature flag library+description:         A minimally obtrusive feature flag library+homepage:            https://github.com/toddmohney/feature-flipper-postgres#readme+bug-reports:         https://github.com/toddmohney/feature-flipper-postgres/issues+license:             MIT+license-file:        LICENSE+author:              Todd Mohney+maintainer:          toddmohney@gmail.com+copyright:           2017 Todd Mohney+category:            Web+build-type:          Simple+cabal-version:       >= 1.10++extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/toddmohney/feature-flipper-postgres++library+  hs-source-dirs:+      src+  default-extensions: OverloadedStrings+  ghc-options: -Wall -fwarn-unused-matches -fwarn-unused-binds -fwarn-unused-imports+  exposed-modules:+      Control.Flipper.Adapters.Postgres+      Control.Flipper.Adapters.Postgres.DBAccess+      Control.Flipper.Adapters.Postgres.Internal.Query+      Control.Flipper.Adapters.Postgres.Models+      Control.Flipper.Adapters.Postgres.Query+  other-modules:+      Paths_feature_flipper_postgres+  build-depends:+      base >=4.7 && <5+    , bytestring+    , containers+    , feature-flipper+    , monad-logger+    , mtl+    , persistent+    , persistent-postgresql+    , persistent-template+    , text+    , time+  default-language: Haskell2010++test-suite feature-flipper-postgres-test+  type: exitcode-stdio-1.0+  hs-source-dirs:+      test+  default-extensions: OverloadedStrings RecordWildCards+  main-is: Spec.hs+  build-depends:+      base+    , bytestring+    , containers+    , hspec+    , monad-logger+    , mtl+    , persistent+    , persistent-postgresql+    , feature-flipper+    , feature-flipper-postgres+  other-modules:+      Control.Flipper.Postgres.QuerySpec+      Control.Flipper.PostgresSpec+      Helpers.Config+      Helpers.Database+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  default-language: Haskell2010
+ src/Control/Flipper/Adapters/Postgres.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards            #-}++module Control.Flipper.Adapters.Postgres+    ( Config(..)+    , FlipperT(..)+    , runFlipperT+    , module Control.Flipper+    ) where+import           Control.Monad.IO.Class                     (MonadIO)+import           Control.Monad.Reader+import           Control.Monad.Trans                        (MonadTrans)+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+import qualified Control.Flipper.Adapters.Postgres.Query    as Q+import           Control.Flipper.Types                      (FeatureName,+                                                             Features (..),+                                                             HasFeatureFlags (..),+                                                             ModifiesFeatureFlags (..))++import           Control.Flipper++{- |+The 'FlipperT' transformer for postgres-persisted feature switchable computation.+-}+newtype FlipperT m a = FlipperT { unFlipper :: ReaderT Config m a }+    deriving ( Functor+             , Applicative+             , Monad+             , MonadIO+             , MonadReader Config+             , MonadTrans+             )++instance (MonadIO m) => HasFeatureFlags (FlipperT m) where+    getFeatures = ask >>= \Config{..} ->+        modelsToFeatures <$> 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)++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++{- |+Evaluates a feature-switched computation, returning the final value+-}+runFlipperT :: (MonadIO m)+            => ConnectionPool -> FlipperT m a -> m a+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+    , appDB     :: DBAccess m+    }
+ src/Control/Flipper/Adapters/Postgres/DBAccess.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types                #-}++module Control.Flipper.Adapters.Postgres.DBAccess+    ( DBAccess(..)+    , db+    ) where++import           Control.Monad.IO.Class                           (liftIO)++import qualified Control.Flipper.Adapters.Postgres.Internal.Query as Q+import           Control.Flipper.Adapters.Postgres.Models+import qualified Control.Flipper.Types                            as T++{- |+Database query interface+-}+data DBAccess m = DBAccess { runDb          :: forall a . m a -> IO a+                           , selectFeatures :: m [Entity Feature]+                           , findFeature    :: T.FeatureName -> m (Maybe (Entity Feature))+                           , insertFeature  :: Feature -> m (Key Feature)+                           , updateFeature  :: FeatureId -> Feature -> m ()+                           , countFeatures  :: m Int+                           }++{- |+Creates a DBAccess backed by a SqlPersistT context+-}+db :: ConnectionPool -> DBAccess (SqlPersistT IO)+db pool = DBAccess { runDb = runDb' pool+                   , selectFeatures = Q.selectFeatures+                   , findFeature    = Q.findFeature+                   , insertFeature  = Q.insertFeature+                   , updateFeature  = Q.updateFeature+                   , countFeatures  = Q.countFeatures+                   }+  where+    runDb' :: ConnectionPool -> SqlPersistT IO a -> IO a+    runDb' conn query = liftIO (runSqlPool query conn)+
+ src/Control/Flipper/Adapters/Postgres/Internal/Query.hs view
@@ -0,0 +1,40 @@+module Control.Flipper.Adapters.Postgres.Internal.Query+    ( selectFeatures+    , findFeature+    , insertFeature+    , updateFeature+    , countFeatures+    ) where++import           Control.Flipper.Adapters.Postgres.Models as M+import qualified Control.Flipper.Types                    as T++{- |+Selects all feature records+-}+selectFeatures :: SqlPersistT IO [Entity Feature]+selectFeatures = selectList [] []++{- |+Selects a feature record by its unique name+-}+findFeature :: T.FeatureName -> SqlPersistT IO (Maybe (Entity Feature))+findFeature fName = getBy (UniqueFeatureName fName)++{- |+Inserts a new feature record.+-}+insertFeature :: Feature -> SqlPersistT IO (Key Feature)+insertFeature = insert++{- |+Updates an existing feature record.+-}+updateFeature :: M.FeatureId -> M.Feature -> SqlPersistT IO ()+updateFeature = replace++{- |+Returns a count of all feature records+-}+countFeatures :: SqlPersistT IO Int+countFeatures = count ([] :: [Filter Feature])
+ src/Control/Flipper/Adapters/Postgres/Models.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedLists            #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++module Control.Flipper.Adapters.Postgres.Models+    ( module Control.Flipper.Adapters.Postgres.Models+    , module Database.Persist.Postgresql+    ) where++import           Data.Monoid                 ((<>))+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++import qualified Control.Flipper.Types       as F++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+    Feature sql=feature_flipper_features+        name F.FeatureName sqltype=text+        enabled Bool sqltype=boolean default=false+        updated UTCTime default=now()+        created UTCTime default=now()+        UniqueFeatureName name+        deriving Show Eq+|]++instance PersistField F.FeatureName where+  toPersistValue = PersistDbSpecific . T.encodeUtf8 . F.unFeatureName+  fromPersistValue (PersistText name) = Right (F.FeatureName name)+  fromPersistValue name = Left ("Not PersistText " <> T.pack (show name))++{- |+Convienience constructor+-}+mkFeature :: F.FeatureName -> Bool -> IO Feature+mkFeature fName isEnabled = do+    now <- getCurrentTime+    return Feature+        { featureName = fName+        , featureEnabled = isEnabled+        , featureUpdated = now+        , featureCreated = now+        }++{- |+Performs non-destructive database schema migrations.+-}+runMigrations :: ConnectionPool -> IO [Text]+runMigrations = runSqlPool (runMigrationSilent migrateAll)
+ src/Control/Flipper/Adapters/Postgres/Query.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE RecordWildCards #-}++module Control.Flipper.Adapters.Postgres.Query+    ( getFeatures+    , getFeatureByName+    , addFeature+    , replaceFeature+    , upsertFeature+    , featureCount+    , M.mkFeature+    ) where++import           Control.Monad                              (void)+import           Data.Time.Clock                            (getCurrentTime)++import           Control.Flipper.Adapters.Postgres.DBAccess as DB+import           Control.Flipper.Adapters.Postgres.Models   as M+import qualified Control.Flipper.Types                      as T+import           Control.Monad.IO.Class                     (MonadIO, liftIO)++{- |+Selects all feature records+-}+getFeatures :: (MonadIO app, Monad m)+            => DBAccess m -> app [Entity Feature]+getFeatures DBAccess{..} = liftIO $ runDb selectFeatures++{- |+Selects a feature record by its unique name+-}+getFeatureByName :: (MonadIO app, Monad m)+                 => T.FeatureName -> DBAccess m -> app (Maybe (Entity Feature))+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+    case mFeature of+        Nothing ->+            liftIO (mkFeature fName isEnabled) >>= void . flip addFeature dbAccess+        (Just (Entity fId f)) ->+            replaceFeature fId (f { featureEnabled = isEnabled }) dbAccess++{- |+Inserts a new feature record.+-}+addFeature :: (MonadIO app, Monad m)+           => Feature -> DBAccess m -> app (Key Feature)+addFeature feature DBAccess{..} = liftIO $ runDb (insertFeature feature)++{- |+Updates an existing feature record.+-}+replaceFeature :: (MonadIO app, Monad m)+               => FeatureId -> Feature -> DBAccess m -> app ()+replaceFeature fId feature DBAccess{..} = do+    now <- liftIO getCurrentTime+    liftIO $ runDb (updateFeature fId (feature { featureUpdated = now }))++{- |+Returns a count of all feature records+-}+featureCount :: (MonadIO app, Monad m)+             => DBAccess m -> app Int+featureCount DBAccess{..} = liftIO $ runDb countFeatures
+ test/Control/Flipper/Postgres/QuerySpec.hs view
@@ -0,0 +1,33 @@+module Control.Flipper.Postgres.QuerySpec (main, spec) where++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++main :: IO ()+main = hspec spec++spec :: Spec+spec = around Cfg.withConfig $ do+    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++        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+            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
+ test/Control/Flipper/PostgresSpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Control.Flipper.PostgresSpec (main, spec) where++import           Control.Monad                            (void)+import           Control.Monad.Reader+import           Control.Monad.State+import           Data.Map.Strict                          as Map+import           Test.Hspec++import           Control.Flipper.Adapters.Postgres        as FP+import           Control.Flipper.Adapters.Postgres.Models (ConnectionPool)+import           Control.Flipper.Adapters.Postgres.Query  as Q+import qualified Helpers.Config                           as Cfg++main :: IO ()+main = hspec spec++newtype MyContext m a = MyContext { unContext :: StateT MyState (FlipperT m) a }+    deriving ( Functor+             , Applicative+             , Monad+             , MonadIO+             , MonadState MyState+             , MonadReader Config+             , HasFeatureFlags+             , ModifiesFeatureFlags+             )++newtype MyState = MyState Int+    deriving (Show, Eq)++runMyContext :: (MonadIO m)+             => ConnectionPool -> MyState -> MyContext m a -> m (a, MyState)+runMyContext pool initialState f =+    let flipperT = runStateT (unContext f) initialState+    in runFlipperT pool flipperT++spec :: Spec+spec = around Cfg.withConfig $ do+    describe "control flow with feature flags" $ do+        describe "a non-existant feature" $ do+            it "is disabled by default" $ \(Config pool _) -> do+                (_, st) <- runMyContext pool (MyState 0) $ do+                    whenEnabled "non-existant feature" (void $ put (MyState 1))++                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+                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+                void $ Q.addFeature f dbAccess++                (_, st) <- runMyContext pool (MyState 0) $ do+                    whenEnabled "disabled-feature" (void $ put (MyState 1))++                st `shouldBe` MyState 0++    describe "modifying feature flags" $ do+        describe "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) ]+                    updateFeatures fs++                featureCount dbAccess `shouldReturn` 2++            it "updates existing 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) ]+                    updateFeatures fs+                    liftIO $ featureCount dbAccess `shouldReturn` 2++                    let fs' = Features $ Map.fromList [ ("my-new-feature", False), ("some-other-feature", False), ("hi-there", False) ]+                    updateFeatures fs'+                    liftIO $ featureCount dbAccess `shouldReturn` 3++                    fs'' <- FP.getFeatures+                    liftIO $ all (== False) (Map.elems (unFeatures fs'')) `shouldBe` True++
+ test/Helpers/Config.hs view
@@ -0,0 +1,21 @@+module Helpers.Config+    ( withConfig+    ) where++import           Control.Flipper.Adapters.Postgres+import qualified Control.Flipper.Adapters.Postgres.DBAccess as DBA+import qualified Helpers.Database                           as DB++withConfig :: (Config -> IO ()) -> IO ()+withConfig action = do+    cfg@(Config conn _) <- loadConfig+    DB.setupTestDatabase conn+    action cfg++loadConfig :: IO Config+loadConfig = do+    conn <- DB.makePool+    return Config+        { appDBConn = conn+        , appDB = DBA.db conn+        }
+ test/Helpers/Database.hs view
@@ -0,0 +1,68 @@+module Helpers.Database+    ( makePool+    , setupTestDatabase+    ) where++import           Control.Monad.Logger                     (runNoLoggingT)+import           Data.ByteString.Char8                    (pack)+import           Database.Persist.Postgresql              (ConnectionPool,+                                                           ConnectionString,+                                                           createPostgresqlPool,+                                                           rawExecute,+                                                           runSqlPool)+import           System.Environment                       (getEnv, lookupEnv)++import           Control.Flipper.Adapters.Postgres.Models (runMigrations)++data DbConnectionString =+  DbConnectionString { dbname   :: String+                     , user     :: Maybe String+                     , password :: Maybe String+                     , host     :: Maybe String+                     , port     :: Maybe Int+                     } deriving (Show)++makePool :: IO ConnectionPool+makePool = do+  connStr <- dbConnectionString+  poolSize <- read <$> getEnv "DB_POOL_SIZE"+  runNoLoggingT $ createPostgresqlPool connStr poolSize++dbConnectionString :: IO ConnectionString+dbConnectionString =+  (pack . toStr) <$> buildDBConnectionFromEnv++toStr :: DbConnectionString -> String+toStr cStr =+  unwords+    [ "dbname=" ++ dbname cStr+    , maybe ""               (\x -> "user=" ++ x)      (user cStr)+    , maybe ""               (\x -> "password=" ++ x)  (password cStr)+    , maybe "host=localhost" (\x -> "host=" ++ x)      (host cStr)+    , maybe "port=5432"      (\x -> "port=" ++ show x) (port cStr)+    ]++buildDBConnectionFromEnv :: IO DbConnectionString+buildDBConnectionFromEnv =+  DbConnectionString+  <$> getEnv    "DB_NAME"+  <*> lookupEnv "DB_USER"+  <*> lookupEnv "DB_PASS"+  <*> lookupEnv "DB_HOST"+  <*> (parsePort <$> lookupEnv "DB_PORT")++parsePort :: Maybe String -> Maybe Int+parsePort Nothing  = Nothing+parsePort (Just p) = Just (read p)++setupTestDatabase :: ConnectionPool -> IO ()+setupTestDatabase pool = do+    _ <- runMigrations pool+    truncateDatabase pool++truncateDatabase :: ConnectionPool -> IO ()+truncateDatabase pool = do+    runSqlPool truncateFeaturesQuery pool+    where+        truncateFeaturesQuery =+            rawExecute "TRUNCATE TABLE feature_flipper_features RESTART IDENTITY;" []
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}