Commit b6f6c230 authored by MrMan's avatar MrMan

Add TaskStoreConfig to AppConfig

parent e092cfa7
......@@ -3,27 +3,38 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE InstanceSigs #-}
module Config where
import Data.Monoid
import Control.Exception (Exception, try, throw)
import Filesystem.Path as FP
import Filesystem.Path.CurrentOS as FPCOS
import Control.Applicative ((<|>))
import Control.Monad (join, when)
import Data.Maybe (fromMaybe, isJust)
import Data.Aeson (FromJSON(parseJSON), toJSON, eitherDecode)
import Data.Aeson.Types (parseEither)
import Data.Bifunctor (bimap, first, second)
import Data.ByteString.Lazy as DBL
import Data.Functor.Identity
import Data.Text.IO as DTI
import Data.Text as DT
import GHC.Generics
import Text.Parsec.Error (ParseError)
import Text.Read (readMaybe)
import Text.Toml (parseTomlDoc)
import Data.Monoid
import Control.Exception (Exception, try, throw)
import qualified Filesystem.Path as FP
import qualified Filesystem.Path.CurrentOS as FPCOS
import Control.Applicative ((<|>))
import Control.Monad (join, when)
import Data.Maybe (fromMaybe, isJust)
import Data.Aeson (FromJSON(parseJSON), toJSON, eitherDecode)
import Data.Aeson.Types (parseEither)
import Data.Bifunctor (bimap, first, second)
import Data.ByteString.Lazy as DBL
import Data.Functor.Identity
import Data.Text.IO as DTI
import Data.Text as DT
import GHC.Generics
import Text.Parsec.Error (ParseError)
import Text.Read (readMaybe)
import Text.Toml (parseTomlDoc)
defaultHost :: Host
defaultHost = "localhost"
defaultPort :: Port
defaultPort = 5000
defaultTaskStoreFilePath :: FilePath
defaultTaskStoreFilePath = ":memory:"
type Host = String
type Port = Integer
......@@ -40,8 +51,9 @@ deriving instance Exception ConfigurationError
-- | Parametric polymorphism over type f (e.g. `Identity` or `Maybe`)
data AppConfig f = AppConfig
{ host :: f Host
, port :: f Port
{ host :: f Host
, port :: f Port
, taskStoreConfig :: f (TaskStoreConfig f)
}
type CompleteAppConfig = AppConfig Identity
......@@ -56,28 +68,52 @@ deriving instance Eq PartialAppConfig
deriving instance Show PartialAppConfig
deriving instance FromJSON PartialAppConfig
defaultHost :: Host
defaultHost = "localhost"
defaultPort :: Port
defaultPort = 5000
instance Semigroup CompleteAppConfig where
a <> b = b
instance Monoid CompleteAppConfig where
mempty = AppConfig (Identity defaultHost) (Identity defaultPort)
mempty = AppConfig (Identity defaultHost) (Identity defaultPort) (Identity mempty)
instance Semigroup PartialAppConfig where
a <> b = AppConfig { host=resolveMaybes host
, port=resolveMaybes port
, taskStoreConfig=resolveMaybes taskStoreConfig
}
where
resolveMaybes :: (PartialAppConfig -> Maybe a) -> Maybe a
resolveMaybes getter = maybe (getter a) Just (getter b)
instance Monoid PartialAppConfig where
mempty = AppConfig Nothing Nothing
mempty = AppConfig Nothing Nothing Nothing
data TaskStoreConfig f = TaskStoreConfig { tscDBFilePath :: f FilePath }
type CompleteTaskStoreConfig = TaskStoreConfig Identity
deriving instance Generic CompleteTaskStoreConfig
deriving instance Eq CompleteTaskStoreConfig
deriving instance Show CompleteTaskStoreConfig
deriving instance FromJSON CompleteTaskStoreConfig
type PartialTaskStoreConfig = TaskStoreConfig Maybe
deriving instance Generic PartialTaskStoreConfig
deriving instance Eq PartialTaskStoreConfig
deriving instance Show PartialTaskStoreConfig
deriving instance FromJSON PartialTaskStoreConfig
instance Semigroup CompleteTaskStoreConfig where
a <> b = b
instance Monoid CompleteTaskStoreConfig where
mempty = TaskStoreConfig (Identity defaultTaskStoreFilePath)
instance Semigroup PartialTaskStoreConfig where
a <> b = TaskStoreConfig { tscDBFilePath=resolveMaybes tscDBFilePath }
where
resolveMaybes :: (PartialTaskStoreConfig -> Maybe a) -> Maybe a
resolveMaybes getter = maybe (getter a) Just (getter b)
instance Monoid PartialTaskStoreConfig where
mempty = TaskStoreConfig Nothing
----------
-- JSON --
......@@ -123,6 +159,7 @@ class FromENV cfg where
instance FromENV PartialAppConfig where
fromENV pEnv = AppConfig { host=prop "TODO_HOST"
, port=readMaybe =<< prop "TODO_PORT"
, taskStoreConfig=Just $ fromENV pEnv
}
where
env :: [(String, String)]
......@@ -131,10 +168,32 @@ instance FromENV PartialAppConfig where
prop :: String -> Maybe String
prop = flip lookup env
mergeInPartial :: CompleteAppConfig -> PartialAppConfig -> CompleteAppConfig
mergeInPartial c p = AppConfig { host = maybe (host c) Identity (host p)
, port = maybe (port c) Identity (port p)
}
instance FromENV PartialTaskStoreConfig where
fromENV pEnv = TaskStoreConfig { tscDBFilePath=prop "TASK_STORE_FILE_PATH" }
where
env :: [(String, String)]
env = getProcessEnv pEnv
prop :: String -> Maybe String
prop = flip lookup env
-- | The class of configurations that can absorb partials of themselves to maintain a whole
class AbsorbPartial complete partial where
absorbPartial :: complete -> partial -> complete
instance AbsorbPartial CompleteAppConfig PartialAppConfig where
absorbPartial :: CompleteAppConfig -> PartialAppConfig -> CompleteAppConfig
absorbPartial c p = AppConfig { host = maybe (host c) Identity (host p)
, port = maybe (port c) Identity (port p)
, taskStoreConfig = Identity $ absorbPartial tsc maybeTSC
}
where
tsc = runIdentity $ taskStoreConfig c
maybeTSC = maybe mempty id $ taskStoreConfig p
instance AbsorbPartial CompleteTaskStoreConfig PartialTaskStoreConfig where
absorbPartial :: CompleteTaskStoreConfig -> PartialTaskStoreConfig -> CompleteTaskStoreConfig
absorbPartial c p = TaskStoreConfig { tscDBFilePath = maybe (tscDBFilePath c) Identity (tscDBFilePath p) }
-- | Ensure that an Either resolves to it's Right value, ensure that a
rightOrThrow :: (Exception a) => Either a b -> IO b
......@@ -143,7 +202,7 @@ rightOrThrow e = case e of
(Right v) -> return v
buildConfigWithDefault :: CompleteAppConfig -> [PartialAppConfig] -> CompleteAppConfig
buildConfigWithDefault orig partials = orig `mergeInPartial` combinedPartials
buildConfigWithDefault orig partials = orig `absorbPartial` combinedPartials
where
combinedPartials :: PartialAppConfig
combinedPartials = Prelude.foldl (<>) (mempty :: PartialAppConfig) partials
......@@ -173,11 +232,12 @@ makeAppConfig maybeStrPath env = try generateConfig
envCfg :: PartialAppConfig
envCfg = fromENV env :: PartialAppConfig
fullySpecifiedPartialCfg :: CompleteAppConfig
fullySpecifiedPartialCfg = mergeInPartial mempty mempty
-- | The default configuration *is* a fully specified complete app config @ mempty state
defaultCfg :: CompleteAppConfig
defaultCfg = mempty
buildFromEnv :: IO CompleteAppConfig
buildFromEnv = pure $ mergeInPartial fullySpecifiedPartialCfg envCfg
buildFromEnv = pure $ absorbPartial defaultCfg envCfg
getFileConfig :: FPCOS.FilePath -> IO (Either ConfigurationError PartialAppConfig)
getFileConfig = if isJSONFile then fromJSONFile else fromTOMLFile
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment