diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,3 @@
+# 0.1.0.0
+
+- Initial release.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,29 @@
+BSD 3-Clause License
+
+Copyright (c) 2020, Jasper Woudenberg
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+2. 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.
+
+3. Neither the name of the copyright holder nor the names of its
+ 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 HOLDER 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,3 @@
+# `wai-feature-flags`
+
+Feature flag support for WAI applications.
diff --git a/example-app/Main.hs b/example-app/Main.hs
new file mode 100644
--- /dev/null
+++ b/example-app/Main.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main
+ ( main,
+ )
+where
+
+import Data.Foldable (asum)
+import GHC.Generics (Generic)
+import qualified Network.FeatureFlags as FeatureFlags
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+
+main :: IO ()
+main = do
+ store <- FeatureFlags.memoryStore
+ featureFlagsAdmin <- FeatureFlags.mkApplication store
+ Warp.run 8080 (application store featureFlagsAdmin)
+
+application :: FeatureFlags.Store Flags -> Wai.Application -> Wai.Application
+application store featureFlagsAdmin req respond = do
+ flags <- FeatureFlags.fetch store
+ case (Wai.requestMethod req, Wai.pathInfo req) of
+ -- Mount feature flags page at /admin/flags.
+ (_, "admin" : "flags" : rest) ->
+ featureFlagsAdmin
+ req {Wai.pathInfo = rest}
+ respond
+ ("GET", ["window"]) ->
+ respond $
+ Wai.responseLBS
+ (toEnum 200)
+ []
+ (if openWindow flags then "open" else "closed")
+ ("GET", ["pigeons"]) ->
+ respond $
+ Wai.responseLBS
+ (toEnum 200)
+ []
+ (if feedPigeons flags then "fed" else "hungry")
+ _ -> respond (Wai.responseLBS (toEnum 404) [] "")
+
+data Flags
+ = Flags
+ { openWindow :: Bool,
+ feedPigeons :: Bool
+ }
+ deriving (Generic)
+
+instance FeatureFlags.Flags Flags
diff --git a/frontend/index.html b/frontend/index.html
new file mode 100644
--- /dev/null
+++ b/frontend/index.html
@@ -0,0 +1,10583 @@
+
+
+
+
+ Main
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/Network/FeatureFlags.hs b/src/Network/FeatureFlags.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/FeatureFlags.hs
@@ -0,0 +1,276 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Use feature flags in WAI applications.
+--
+-- A feature flag is a way to toggle functionality on or off without having to
+-- redeploy the application. Feature flags have many possible uses, one is
+-- making it safer to release new functionality by providing a way to turn it
+-- off immediately if it misbehaves.
+--
+-- An application using this library first needs to define which feature flags
+-- is supports. This is done by creating a record type containing only boolean
+-- fields and adding a 'Flags' instance to it.
+--
+-- > data Features
+-- > = Features
+-- > { openWindow :: Bool,
+-- > feedPigeons :: Bool
+-- > }
+-- > deriving (Generic)
+-- >
+-- > instance Flags Features
+--
+-- Then we need a place to persist flag data. This library provides a
+-- 'memoryStore' but it doesn't remember flag states across restarts. For
+-- production applications it's probably best to implement a 'Store' that reads
+-- and writes flag data to the database or key,value store backing your project.
+--
+-- 'mkApplication' provides a frontend from which each feature flag can be
+-- fully enabled, fully disabled, or enabled for a specific percentage of
+-- traffic. It is compatible with @Wai@-based web frameworks like @spock@,
+-- @scotty@, and @servant@. Setup instructions will be different for each. If
+-- you're having trouble integrating this in your choice of web framework please
+-- feel free to [open an issue](https://github.com/jwoudenberg/wai-feature-flags/issues).
+--
+-- Now you're all set up. You can use 'fetch' to read your feature flags from
+-- your store and can use their values in conditionals. For a full example check
+-- out this [sample application](https://github.com/jwoudenberg/wai-feature-flags/blob/trunk/example-app/Main.hs).
+module Network.FeatureFlags
+ ( -- * Flags
+ Flags,
+ fetch,
+
+ -- * Store
+ Store (..),
+ memoryStore,
+
+ -- * Feature flag frontend
+ mkApplication,
+ )
+where
+
+import qualified Data.Aeson as Aeson
+import Data.Bifunctor (first)
+import qualified Data.ByteString as B
+import qualified Data.HashMap.Strict as Map
+import qualified Data.IORef as IORef
+import Data.Kind (Type)
+import qualified Data.Maybe as Maybe
+import Data.Proxy (Proxy (Proxy))
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Read as Read
+import qualified Data.Word as Word
+import qualified Debug.Trace as Debug
+import GHC.Generics
+import GHC.TypeLits (ErrorMessage (..), KnownSymbol, TypeError, symbolVal)
+import qualified Network.Wai as Wai
+import qualified Paths_wai_feature_flags as Paths
+import System.Random (StdGen, getStdRandom, randomR)
+
+-- FRONTEND
+
+-- | Create a WAI application that serves a frontend for modifying feature flag
+-- states. How you embed this into your real application depends on the web
+-- framework you're using.
+mkApplication :: Flags flags => Store flags -> IO Wai.Application
+mkApplication store =
+ application store <$> Paths.getDataFileName "frontend/index.html"
+
+application :: Flags flags => Store flags -> FilePath -> Wai.Application
+application store frontend req respond = do
+ case (Wai.requestMethod req, Wai.pathInfo req) of
+ ("GET", []) ->
+ respond $
+ Wai.responseFile
+ (toEnum 200)
+ [("Content-Type", "text/html; charset=UTF-8")]
+ frontend
+ Nothing
+ ("GET", ["flags"]) -> do
+ configs <- readFlagConfigs (flags store) store
+ respond $
+ Wai.responseLBS
+ (toEnum 200)
+ [("Content-Type", "application/json")]
+ (Aeson.encode configs)
+ ("PUT", ["flags", flagName]) -> do
+ body <- Wai.lazyRequestBody req
+ case Aeson.decode body of
+ Nothing ->
+ respond (Wai.responseLBS (toEnum 400) [] "")
+ Just percent -> do
+ setFlag flagName percent store
+ respond (Wai.responseLBS (toEnum 200) [] "")
+ _ -> respond (Wai.responseLBS (toEnum 404) [] "")
+
+setFlag :: T.Text -> Percent -> Store flags -> IO ()
+setFlag flag (Percent percentage) store =
+ writeKey
+ store
+ (TE.encodeUtf8 flag)
+ (TE.encodeUtf8 (T.pack (show (min 100 percentage))))
+
+readFlagConfigs :: [T.Text] -> Store flags -> IO (Map.HashMap T.Text Percent)
+readFlagConfigs keys store = do
+ let defaults = zip keys (repeat (Percent 0))
+ stored <- Maybe.catMaybes . map decodeFlagConfig <$> readKeys store
+ pure $ Map.fromList $ defaults <> stored
+
+decodeFlagConfig :: (B.ByteString, B.ByteString) -> Maybe (T.Text, Percent)
+decodeFlagConfig (flag, config) = do
+ flag <- either (const Nothing) Just $ TE.decodeUtf8' flag
+ enabledString <- either (const Nothing) Just $ TE.decodeUtf8' config
+ (enabledInt, _) <- either (const Nothing) Just $ Read.decimal enabledString
+ pure (flag, percent enabledInt)
+
+-- STORES
+
+-- | A type describing a store in which feature flag data can be saved. You are
+-- recommended to define your own stores using a persistence mechanism of your
+-- choice.
+data Store flags
+ = Store
+ { -- | Read all key,value pairs from the store.
+ readKeys :: IO [(B.ByteString, B.ByteString)],
+ -- | Save a key,value pair to the store. Create the key,value pair if it
+ -- does not exist yet and overwrite it otherwise.
+ writeKey :: B.ByteString -> B.ByteString -> IO ()
+ }
+
+-- | An in-memory store that does not persist feature flag data across
+-- application restarts. Suitable for experimentation but not recommended for
+-- production use.
+memoryStore :: IO (Store flags)
+memoryStore = do
+ ref <- IORef.newIORef Map.empty
+ pure
+ Store
+ { readKeys = Map.toList <$> IORef.readIORef ref,
+ writeKey = \key value ->
+ IORef.atomicModifyIORef' ref (\xs -> (Map.insert key value xs, ()))
+ }
+
+-- | Read feature flag states out of the store. The states of flags enabled for
+-- part of the traffic will be determined by die-roll.
+--
+-- The default state for new flags and flags we cannot find values for in the
+-- store is off. This library offers no way to set other defaults to keep it as
+-- simple as possibe. You are encouraged to phrase your flag names in such a
+-- way that off corresponds to what you'd like the default value to be, i.e.
+-- @enableExperimentalDoodad@ is likely safer than @disableExperimentalDoodad@.
+fetch :: forall flags. Flags flags => Store flags -> IO flags
+fetch store = do
+ let keys = flags (Proxy :: Proxy flags)
+ configs <- readFlagConfigs keys store
+ getStdRandom (generate configs)
+
+-- PERCENT
+
+newtype Percent = Percent Word.Word deriving (Aeson.ToJSON, Aeson.FromJSON)
+
+percent :: Word.Word -> Percent
+percent = Percent . min 100
+
+-- FLAGS
+
+-- | The feature flags you define are described by a type you create yourself.
+-- It needs to be a record though, with every field a boolean. Then we add a
+-- `Flags` instance to it so this library is able to work with the type.
+--
+-- > data Features
+-- > = Features
+-- > { openWindow :: Bool,
+-- > feedPigeons :: Bool
+-- > }
+-- > deriving (Generic)
+-- >
+-- > instance Flags Features
+class Flags flags where
+ generate :: Map.HashMap T.Text Percent -> StdGen -> (flags, StdGen)
+
+ flags :: proxy flags -> [T.Text]
+
+ default generate :: (Generic flags, GFlags (Rep flags)) => Map.HashMap T.Text Percent -> StdGen -> (flags, StdGen)
+ generate configs gen = first GHC.Generics.to $ ggenerate configs gen
+
+ default flags :: (Generic flags, GFlags (Rep flags)) => proxy flags -> [T.Text]
+ flags _ = gflags (Proxy :: Proxy (Rep flags))
+
+class GFlags flags where
+ ggenerate :: Map.HashMap T.Text Percent -> StdGen -> (flags g, StdGen)
+
+ gflags :: proxy flags -> [T.Text]
+
+instance GFlags fields => GFlags (D1 m (C1 ('MetaCons s f 'True) fields)) where
+ ggenerate configs gen = first (M1 . M1) $ ggenerate configs gen
+
+ gflags _ = gflags (Proxy :: Proxy fields)
+
+instance (GFlags l, GFlags r) => GFlags (l :*: r) where
+ ggenerate configs gen =
+ let (lval, gen') = ggenerate configs gen
+ (rval, gen'') = ggenerate configs gen'
+ in (lval :*: rval, gen'')
+
+ gflags _ = gflags (Proxy :: Proxy l) <> gflags (Proxy :: Proxy r)
+
+instance
+ ( KnownSymbol fieldName,
+ FromBool (IsBool bool) bool
+ ) =>
+ GFlags (S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool))
+ where
+ ggenerate configs gen =
+ first (M1 . K1 . fromBool (Proxy :: Proxy (IsBool bool))) $
+ case Map.lookup (T.pack $ symbolVal (Proxy :: Proxy fieldName)) configs of
+ Nothing -> (False, gen)
+ Just (Percent 0) -> (False, gen)
+ Just (Percent 100) -> (True, gen)
+ Just config -> roll gen config
+
+ gflags _ = [T.pack $ symbolVal (Proxy :: Proxy fieldName)]
+
+type family IsBool (b :: Type) :: Bool where
+ IsBool Bool = 'True
+ IsBool _ = 'False
+
+class FromBool (b :: Bool) a where
+ fromBool :: Proxy b -> Bool -> a
+
+instance FromBool 'True Bool where
+ fromBool _ = id
+
+instance TypeError InvalidFlagsTypeMessage => FromBool 'False a where
+ fromBool = error "unreachable"
+
+instance TypeError InvalidFlagsTypeMessage => GFlags (D1 m (C1 ('MetaCons s f 'False) a)) where
+ ggenerate = error "unreachable"
+
+ gflags = error "unreachable"
+
+type InvalidFlagsTypeMessage =
+ 'Text "Not a valid flags type."
+ :$$: 'Text "A flags type needs to be a record with boolean fields."
+ :$$: 'Text "For example:"
+ :$$: 'Text " data Flags ="
+ :$$: 'Text " Flags { showErrorPage :: Bool"
+ :$$: 'Text " , throttleRequests :: Bool }"
+
+roll :: StdGen -> Percent -> (Bool, StdGen)
+roll gen (Percent trueChance) =
+ let (randomPercentage, gen') = randomR (1, 100) gen
+ in (trueChance >= randomPercentage, gen')
diff --git a/wai-feature-flags.cabal b/wai-feature-flags.cabal
new file mode 100644
--- /dev/null
+++ b/wai-feature-flags.cabal
@@ -0,0 +1,60 @@
+cabal-version: 1.18
+
+-- This file has been generated from package.yaml by hpack version 0.33.0.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 184959f4466db0edd22a62ebbfe0a7cd9dff71d3499da077fb28b6c3f877e384
+
+name: wai-feature-flags
+version: 0.1.0.0
+synopsis: Feature flag support for WAI applications.
+description: Please see the README at .
+category: Web
+homepage: https://github.com/jwoudenberg/wai-feature-flags#readme
+bug-reports: https://github.com/jwoudenberg/wai-feature-flags/issues
+author: Jasper Woudenberg
+maintainer: mail@jasperwoudenberg.com
+copyright: 2020 Jasper Woudenberg
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+extra-doc-files:
+ README.md
+ CHANGELOG.md
+data-files:
+ frontend/index.html
+
+source-repository head
+ type: git
+ location: https://github.com/jwoudenberg/wai-feature-flags
+
+library
+ exposed-modules:
+ Network.FeatureFlags
+ other-modules:
+ Paths_wai_feature_flags
+ hs-source-dirs:
+ src
+ build-depends:
+ aeson >=1.2.4.0 && <1.6
+ , base >=4.10.1.0 && <5
+ , bytestring >=0.10.8.2 && <0.12
+ , random >=1.1 && <1.3
+ , text >=1.2.3.0 && <1.3
+ , unordered-containers >=0.2.9.0 && <0.3
+ , wai >=3.2.2.1 && <3.3
+ default-language: Haskell2010
+
+executable example-app
+ main-is: Main.hs
+ other-modules:
+ Paths_wai_feature_flags
+ hs-source-dirs:
+ example-app
+ build-depends:
+ base
+ , wai
+ , wai-feature-flags
+ , warp >=3.3.5 && <3.4
+ default-language: Haskell2010