diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# feature-flipper-postgres diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/feature-flipper-postgres.cabal b/feature-flipper-postgres.cabal new file mode 100644 --- /dev/null +++ b/feature-flipper-postgres.cabal @@ -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 diff --git a/src/Control/Flipper/Adapters/Postgres.hs b/src/Control/Flipper/Adapters/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Control/Flipper/Adapters/Postgres.hs @@ -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 + } diff --git a/src/Control/Flipper/Adapters/Postgres/DBAccess.hs b/src/Control/Flipper/Adapters/Postgres/DBAccess.hs new file mode 100644 --- /dev/null +++ b/src/Control/Flipper/Adapters/Postgres/DBAccess.hs @@ -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) + diff --git a/src/Control/Flipper/Adapters/Postgres/Internal/Query.hs b/src/Control/Flipper/Adapters/Postgres/Internal/Query.hs new file mode 100644 --- /dev/null +++ b/src/Control/Flipper/Adapters/Postgres/Internal/Query.hs @@ -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]) diff --git a/src/Control/Flipper/Adapters/Postgres/Models.hs b/src/Control/Flipper/Adapters/Postgres/Models.hs new file mode 100644 --- /dev/null +++ b/src/Control/Flipper/Adapters/Postgres/Models.hs @@ -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) diff --git a/src/Control/Flipper/Adapters/Postgres/Query.hs b/src/Control/Flipper/Adapters/Postgres/Query.hs new file mode 100644 --- /dev/null +++ b/src/Control/Flipper/Adapters/Postgres/Query.hs @@ -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 diff --git a/test/Control/Flipper/Postgres/QuerySpec.hs b/test/Control/Flipper/Postgres/QuerySpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Flipper/Postgres/QuerySpec.hs @@ -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 diff --git a/test/Control/Flipper/PostgresSpec.hs b/test/Control/Flipper/PostgresSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Flipper/PostgresSpec.hs @@ -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 + + diff --git a/test/Helpers/Config.hs b/test/Helpers/Config.hs new file mode 100644 --- /dev/null +++ b/test/Helpers/Config.hs @@ -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 + } diff --git a/test/Helpers/Database.hs b/test/Helpers/Database.hs new file mode 100644 --- /dev/null +++ b/test/Helpers/Database.hs @@ -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;" [] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}