module Boots.Factory.Application(
HasApp(..)
, AppEnv(..)
, buildApp
, rand64
, buildRandom
, getRand
) where
import Boots.App.Internal
import Boots.Factory
import Boots.Factory.Logger
import Boots.Factory.Salak
import Boots.Factory.Vault
import Control.Concurrent.MVar
import Data.Maybe
import Data.String
import Data.Text (Text)
import Data.Version (Version)
import Data.Word
import Lens.Micro
import Lens.Micro.Extras
import Numeric (showHex)
import Salak
import System.Random.SplitMix
class HasApp cxt env | env -> cxt where
askApp :: Lens' env (AppEnv cxt)
instance HasApp cxt (AppEnv cxt) where
askApp = id
instance HasSalak (AppEnv cxt) where
askSalak = lens configure (\x y -> x {configure = y})
instance HasLogger (AppEnv cxt) where
askLogger = lens logF (\x y -> x {logF = y})
instance HasVault cxt (AppEnv cxt) where
askVault = lens vaultF (\x y -> x {vaultF = y})
data AppEnv cxt = AppEnv
{ name :: Text
, instanceId :: Text
, version :: Version
, randSeed :: MVar SMGen
, configure :: Salak
, logF :: LogFunc
, vaultF :: VaultRef cxt
}
buildApp :: (HasLogger cxt, MonadIO m, MonadCatch m) => String -> Version -> Factory m () (AppEnv cxt)
buildApp confName version = do
configure <- buildSalak confName
within configure $ do
name <- fromMaybe (fromString confName) <$> require "application.name"
randSeed <- liftIO $ initSMGen >>= newMVar
instanceId <- liftIO $ hex32 <$> random64 randSeed
vaultF <- liftIO newVaultRef
logF <- buildLogger vaultF (name <> "," <> instanceId)
return AppEnv{..}
random64 :: MVar SMGen -> IO Word64
random64 ref = modifyMVar ref (return . go . nextWord64)
where
go (a,b) = (b,a)
hex64 :: IsString a => Word64 -> a
hex64 i = fromString $ let x = showHex i "" in replicate (16 - length x) '0' ++ x
hex32 :: IsString a => Word64 -> a
hex32 i = fromString $ let x = showHex i "" in drop 8 $ replicate (16 - length x) '0' ++ x
rand64 :: (IsString a, MonadIO m) => MVar SMGen -> m a
rand64 = liftIO . fmap hex64 . random64
getRand :: (IsString a, HasApp cxt env, MonadIO m) => AppT env m a
getRand = do
AppEnv{..} <- asks (view askApp)
lift $ rand64 randSeed
buildRandom :: (IsString a, MonadIO m, HasApp cxt env) => Factory m env a
buildRandom = do
AppEnv{..} <- asks (view askApp)
offer $ rand64 randSeed