module MiniLight.Loader (
module MiniLight.Loader.Internal.Types,
createComponentBy,
lookupByTagID,
LoaderEnv (..),
HasLoaderEnv (..),
resolveConfig,
loadAppConfig,
patchAppConfig,
resolve,
parseAppConfig,
) where
import Control.Lens
import Control.Monad
import qualified Control.Monad.Caster as Caster
import Control.Monad.Catch
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Data.Aeson
import qualified Data.Aeson.Diff as Diff
import Data.Aeson.Patch
import Data.Aeson.Pointer
import Data.IORef
import qualified Data.HashMap.Strict as HM
import qualified Data.Registry as R
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Yaml (decodeFileEither)
import MiniLight.Light
import MiniLight.Component
import MiniLight.Loader.Internal.Types
import MiniLight.Loader.Internal.Resolver (resolve, resolveWith, parseAppConfig, emptyContext, Context(..))
data LoaderEnv = LoaderEnv {
registry :: R.Registry Component,
tagRegistry :: IORef (HM.HashMap T.Text T.Text),
appConfig :: IORef AppConfig
}
makeClassy_ ''LoaderEnv
createComponentBy
:: (HasLoaderEnv env, HasLightEnv env, MonadIO m)
=> Resolver
-> Maybe T.Text
-> ComponentConfig
-> LightT env m (Either String Component)
createComponentBy resolver uid config = do
uuid <- maybe newUID return uid
result <- liftMiniLight
$ resolver (componentType config) uuid (properties config)
case tagID config of
Just tag -> do
regRef <- view _tagRegistry
liftIO $ modifyIORef' regRef $ \reg -> HM.insert tag uuid reg
Caster.debug $ "TagID registered: " <> show tag <> " = " <> show uuid
_ -> return ()
return $ fmap
( \c -> setHooks
c
( fmap
( fmap $ \hk -> (,) (signalName hk) $ \evprops ->
(\(Right r) -> r)
$ resolveWith (emptyContext { values = evprops }) (parameter hk)
)
$ hooks config
)
)
result
lookupByTagID
:: (HasLightEnv env, HasLoaderEnv env, MonadIO m)
=> T.Text
-> LightT env m (Maybe T.Text)
lookupByTagID tag = do
regRef <- view _tagRegistry
reg <- liftIO $ readIORef regRef
return $ HM.lookup tag reg
resolveConfig :: MonadIO m => FilePath -> m (Either T.Text AppConfig)
resolveConfig path =
liftIO
$ (parseAppConfig <=< either (Left . T.pack . show) Right)
<$> decodeFileEither path
loadAppConfig
:: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)
=> FilePath
-> Resolver
-> LightT env m ()
loadAppConfig path mapper = fmap (maybe () id) $ runMaybeT $ do
conf <- resolveConfig path >>= \case
Left e -> do
lift $ Caster.err e
fail ""
Right r -> return r
confs <- lift $ fmap (V.mapMaybe id) $ V.forM (app conf) $ \conf -> do
uid <- newUID
result <- createComponentBy mapper (Just uid) conf
case result of
Left e -> do
Caster.err e
return Nothing
Right component -> do
reg <- view _registry
R.register reg uid component
Caster.info
$ "Component loaded: {type: "
<> show (componentType conf)
<> ", uid: "
<> show uid
<> "}"
return $ Just (uid, conf)
ref <- view _appConfig
liftIO $ writeIORef ref $ AppConfig (V.map snd confs) (V.map fst confs)
patchAppConfig
:: (HasLightEnv env, HasLoaderEnv env, MonadIO m, MonadCatch m)
=> FilePath
-> Resolver
-> LightT env m ()
patchAppConfig path resolver = fmap (maybe () id) $ runMaybeT $ do
cref <- view _appConfig
appConfig <- liftIO $ readIORef cref
conf' <- do
mconf <- lift $ resolveConfig path
case mconf of
Left e -> do
lift $ Caster.err e
fail ""
Right r -> return r
lift
$ forM_
( Diff.patchOperations
$ Diff.diff (toJSON $ app appConfig) (toJSON $ app conf')
)
$ \op -> fmap (maybe () id) $ runMaybeT $ do
lift $ Caster.debug $ "CMR detected: " <> show op
case op of
Add (Pointer [AKey n]) v -> create n v
Rem (Pointer [AKey n]) -> remove n
Rep (Pointer [AKey n ]) v -> modify n (Rep (Pointer []) v)
Rep (Pointer (AKey n:path)) v -> modify n (Rep (Pointer path) v)
Add (Pointer (AKey n:path)) v -> modify n (Add (Pointer path) v)
Rem (Pointer (AKey n:path)) -> modify n (Rem (Pointer path))
_ ->
lift
$ Caster.warn
$ "CMR does not support the operation yet: "
<> show op
where
create n v = do
cref <- view _appConfig
compConf <- case fromJSON v of
Success a -> return a
Error err -> do
lift $ Caster.err err
fail ""
newID <- lift newUID
component <- do
result <- lift $ createComponentBy resolver (Just newID) compConf
case result of
Left err -> do
lift $ Caster.err $ "Failed to resolve: " <> err
fail ""
Right c -> return c
reg <- view _registry
lift $ R.insert reg n (getUID component) component
lift
$ Caster.info
$ "Component registered: {type: "
<> show (componentType compConf)
<> ", uid: "
<> show (getUID component)
<> "}"
liftIO $ modifyIORef' cref $ \conf -> conf
{ app = V.snoc (app conf) compConf
, uuid = V.snoc (uuid conf) newID
}
remove n = do
cref <- view _appConfig
appConf <- liftIO $ readIORef cref
let uid = uuid appConf V.! n
reg <- view _registry
lift $ R.delete reg uid
lift $ Caster.info $ "Component deleted: {uid: " <> show uid <> "}"
liftIO $ writeIORef cref $ appConf
{ app = V.ifilter (\i _ -> i /= n) $ app appConf
, uuid = V.ifilter (\i _ -> i /= n) $ uuid appConf
}
modify n op = do
cref <- view _appConfig
appConf <- liftIO $ readIORef cref
compConf <-
case Diff.applyOperation op (toJSON (app appConf V.! n)) >>= fromJSON of
Success a -> return a
Error err -> do
lift $ Caster.err err
fail ""
let uid = uuid appConf V.! n
component <- do
result <- lift $ createComponentBy resolver (Just uid) compConf
case result of
Left err -> do
lift $ Caster.err $ "Failed to resolve: " <> err
fail ""
Right c -> return c
reg <- view _registry
lift $ R.write reg uid component
lift
$ Caster.info
$ "Component replaced: {name: "
<> show (componentType compConf)
<> ", uid: "
<> show (getUID component)
<> "}"
liftIO $ writeIORef cref $ appConf { app = app appConf V.// [(n, compConf)]
}