0.2.5 initial commit

Makefile incomplete

agent/src/Daemon/AppNotifications.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+module Daemon.AppNotifications where
+
+import           Startlude
+
+import qualified Data.HashMap.Strict           as HM
+import           Data.UUID.V4
+import           Data.Time.Clock.POSIX
+import           Database.Persist.Sql
+
+import           Foundation
+import           Lib.Error
+import           Lib.Algebra.Domain.AppMgr     as AppMgr2
+import           Lib.External.AppMgr           as AppMgr
+import           Lib.Types.Core
+import           Lib.Types.Emver
+import           Model
+
+toModelNotif :: (AppId, Version) -> AppMgrNotif -> Notification
+toModelNotif (appId, appVersion) AppMgrNotif {..} =
+    let prefix = (<> "1") $ case appMgrNotifLevel of
+            INFO    -> "0"
+            SUCCESS -> "1"
+            WARN    -> "2"
+            ERROR   -> "3"
+    in  Notification (posixSecondsToUTCTime . fromRational $ appMgrNotifTime)
+                     Nothing
+                     appId
+                     appVersion
+                     (prefix <> show appMgrNotifCode)
+                     appMgrNotifTitle
+                     appMgrNotifMessage
+
+fetchAndSave :: ReaderT AgentCtx IO ()
+fetchAndSave = handleErr $ do
+    pool <- asks appConnPool
+    apps <- HM.toList <$> AppMgr2.runAppMgrCliC (AppMgr2.list [AppMgr2.flags| |])
+    for_ apps $ \(appId, AppMgr2.InfoRes { infoResVersion }) -> do
+        notifs <- AppMgr.notifications appId
+        let mods = toModelNotif (appId, infoResVersion) <$> notifs
+        keys <- liftIO $ replicateM (length mods) (NotificationKey <$> nextRandom)
+        let ents = zipWith Entity keys mods
+        lift $ flip runSqlPool pool $ insertEntityMany ents
+    where
+        handleErr m = runExceptT m >>= \case
+            Left  e -> putStrLn (errorMessage $ toError e)
+            Right _ -> pure ()

agent/src/Daemon/RefreshProcDev.hs

@@ -0,0 +1,20 @@
+module Daemon.RefreshProcDev where
+
+import           Startlude
+
+import           Data.IORef
+
+import           Foundation
+import           Lib.Error
+import           Lib.External.Metrics.ProcDev
+
+refreshProcDev :: AgentCtx -> IO ()
+refreshProcDev agentCtx = do
+    let procDevCache = appProcDevMomentCache agentCtx
+    (oldTime, oldMoment, _) <- liftIO . readIORef . appProcDevMomentCache $ agentCtx
+
+    eProcDev                <- runS9ErrT $ getProcDevMetrics (oldTime, oldMoment)
+    case eProcDev of
+        Left  e -> putStrLn @Text . show $ e
+        Right (newTime, newMoment, newMetrics) -> liftIO $ writeIORef procDevCache (newTime, newMoment, newMetrics)
+

agent/src/Daemon/ZeroConf.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE TypeApplications #-}
+module Daemon.ZeroConf where
+
+import           Startlude               hiding ( ask )
+
+import           Control.Lens
+import           Control.Effect.Reader.Labelled ( ask )
+import           Control.Monad.Trans.Reader     ( withReaderT )
+import           Crypto.Hash
+import           Data.ByteArray                 ( convert )
+import           Data.ByteArray.Encoding
+import qualified Data.ByteString               as BS
+import           System.FilePath.Lens
+
+import           Foundation
+import qualified Lib.Avahi                     as Avahi
+import           Lib.ProductKey
+import           Lib.SystemPaths
+
+import           Settings
+
+start9AgentServicePrefix :: IsString a => a
+start9AgentServicePrefix = "start9-"
+
+getStart9AgentHostname :: (HasFilesystemBase sig m, MonadIO m, ConvertText Text a) => m a
+getStart9AgentHostname = do
+    base   <- ask @"filesystemBase"
+    suffix <-
+        liftIO
+        $   decodeUtf8
+        .   convertToBase Base16
+        .   BS.take 4
+        .   convert
+        .   hashWith SHA256
+        .   encodeUtf8
+        <$> getProductKey base
+    pure . toS $ start9AgentServicePrefix <> suffix
+
+getStart9AgentHostnameLocal :: (HasFilesystemBase sig m, MonadIO m) => m Text
+getStart9AgentHostnameLocal = getStart9AgentHostname <&> (<> ".local")
+
+publishAgentToAvahi :: ReaderT AgentCtx IO ()
+publishAgentToAvahi = do
+    filesystemBase     <- asks $ appFilesystemBase . appSettings
+    start9AgentService <- injectFilesystemBase filesystemBase getStart9AgentHostname
+    lift $ Avahi.createDaemonConf $ toS start9AgentService
+    agentPort <- asks $ appPort . appSettings
+    services  <- lift Avahi.listServices
+    let serviceNames = view basename <$> services
+    unless (start9AgentService `elem` serviceNames) $ withReaderT appSettings $ Avahi.createService
+        (toS start9AgentService)
+        (Avahi.WildcardsEnabled, "%h")
+        "_http._tcp"
+        agentPort
+    lift Avahi.reload
+