{-# LANGUAGE BangPatterns #-}
module LaunchDarkly.Server.Integrations.FileData
( dataSourceFactory
)
where
import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory, DataSource(..), DataSourceUpdates(..))
import qualified LaunchDarkly.Server.Features as F
import LaunchDarkly.Server.Client.Status
import LaunchDarkly.AesonCompat (KeyMap, mapWithKey)
import Data.Maybe (fromMaybe)
import qualified Data.ByteString.Lazy as BSL
import Data.HashSet (HashSet)
import Data.Text (Text)
import GHC.Generics (Generic)
import Data.Aeson (Value, FromJSON, decode)
import Data.Monoid (Monoid, mempty)
import Data.Semigroup (Semigroup)
import Data.IORef (newIORef, readIORef, writeIORef)
import GHC.Natural (Natural)
import Data.Generics.Product (getField)
import qualified Data.Yaml as Yaml
import Control.Applicative ((<|>))
data FileFlag = FileFlag
{ version :: Maybe Natural
, on :: Maybe Bool
, targets :: Maybe [F.Target]
, rules :: Maybe [F.Rule]
, fallthrough :: Maybe F.VariationOrRollout
, offVariation :: Maybe Integer
, variations :: ![Value]
} deriving (Generic, FromJSON, Show, Eq)
expandSimpleFlag :: Value -> FileFlag
expandSimpleFlag value =
FileFlag
{ version = Nothing
, on = Nothing
, targets = Nothing
, rules = Nothing
, fallthrough = Just (F.VariationOrRollout (Just 0) Nothing)
, offVariation = Just 0
, variations = [value]
}
fromFileFlag :: Text -> FileFlag -> F.Flag
fromFileFlag key fileFlag =
F.Flag{ F.key = key
, F.version = fromMaybe 1 $ getField @"version" fileFlag
, F.on = fromMaybe True $ on fileFlag
, F.trackEvents = False
, F.trackEventsFallthrough = False
, F.deleted = False
, F.prerequisites = []
, F.salt = ""
, F.targets = fromMaybe [] $ targets fileFlag
, F.rules = fromMaybe [] $ getField @"rules" fileFlag
, F.fallthrough = fromMaybe noFallthrough $ fallthrough fileFlag
, F.offVariation = offVariation fileFlag
, F.variations = variations fileFlag
, F.debugEventsUntilDate = Nothing
, F.clientSideAvailability = F.ClientSideAvailability False False False
}
noFallthrough :: F.VariationOrRollout
noFallthrough =
F.VariationOrRollout Nothing Nothing
data FileSegment = FileSegment
{ included :: Maybe (HashSet Text)
, excluded :: Maybe (HashSet Text)
, rules :: Maybe [F.SegmentRule]
, version :: Maybe Natural
} deriving (Generic, FromJSON, Show, Eq)
fromFileSegment :: Text -> FileSegment -> F.Segment
fromFileSegment key fileSegment =
F.Segment{ F.key = key
, F.version = fromMaybe 1 $ getField @"version" fileSegment
, F.included = fromMaybe mempty $ included fileSegment
, F.excluded = fromMaybe mempty $ excluded fileSegment
, F.salt = ""
, F.rules = fromMaybe [] $ getField @"rules" fileSegment
, F.deleted = False
}
data FileBody = FileBody
{ flags :: Maybe (KeyMap FileFlag)
, flagValues :: Maybe (KeyMap Value)
, segments :: Maybe (KeyMap FileSegment)
} deriving (Generic, Show, FromJSON)
instance Semigroup FileBody where
f1 <> f2 =
FileBody
{ flags = flags f1 <> flags f2
, flagValues = flagValues f1 <> flagValues f2
, segments = segments f1 <> segments f2
}
instance Monoid FileBody where
mempty =
FileBody
{ flags = mempty
, flagValues = mempty
, segments = mempty
}
mappend = (<>)
dataSourceFactory :: [FilePath] -> DataSourceFactory
dataSourceFactory sources _clientContext dataSourceUpdates = do
inited <- newIORef False
let dataSourceIsInitialized =
readIORef inited
dataSourceStart = do
FileBody mFlags mFlagValues mSegments <- mconcat <$> traverse loadFile sources
let mSimpleFlags = fmap (fmap expandSimpleFlag) mFlagValues
flags' = maybe mempty (mapWithKey fromFileFlag) (mFlags <> mSimpleFlags)
segments' = maybe mempty (mapWithKey fromFileSegment) mSegments
_ <- dataSourceUpdatesInit dataSourceUpdates flags' segments'
dataSourceUpdatesSetStatus dataSourceUpdates Initialized
writeIORef inited True
dataSourceStop = pure ()
pure $ DataSource{..}
loadFile :: FilePath -> IO FileBody
loadFile filePath = do
file <- BSL.readFile filePath
let mDecodedFile = decode file <|> Yaml.decodeThrow (BSL.toStrict file)
case mDecodedFile of
Just !fileBody ->
pure fileBody
Nothing ->
pure mempty