mirror of
https://github.com/Start9Labs/start-os.git
synced 2026-03-26 10:21:52 +00:00
finishes lan support for the agent
This commit is contained in:
Keagan McClelland
committed by
Aiden McClelland
Aiden McClelland
parent
397236c68e
commit
a4f7d53a6b
@@ -39,6 +39,8 @@
|
||||
/v0/apps/#AppId/backup/stop StopBackupR POST
|
||||
/v0/apps/#AppId/backup/restore RestoreBackupR POST
|
||||
/v0/apps/#AppId/autoconfig/#AppId AutoconfigureR POST
|
||||
/v0/apps/#AppId/lan/enable EnableLanR POST
|
||||
/v0/apps/#AppId/lan/disable DisableLanR POST
|
||||
|
||||
/v0/disks DisksR GET
|
||||
/v0/disks/eject EjectR POST
|
||||
|
||||
@@ -118,6 +118,7 @@ makeFoundation appSettings = do
|
||||
def <- getDefaultProcDevMetrics
|
||||
appProcDevMomentCache <- newIORef (now, mempty, def)
|
||||
appLastTorRestart <- newIORef now
|
||||
appLanThreads <- newTVarIO HM.empty
|
||||
|
||||
-- We need a log function to create a connection pool. We need a connection
|
||||
-- pool to create our foundation. And we need our foundation to get a
|
||||
|
||||
@@ -75,6 +75,7 @@ data AgentCtx = AgentCtx
|
||||
, appBackgroundJobs :: TVar JobCache
|
||||
, appIconTags :: TVar (HM.HashMap AppId (Digest MD5))
|
||||
, appLastTorRestart :: IORef UTCTime
|
||||
, appLanThreads :: TVar (HM.HashMap AppId (Async ()))
|
||||
}
|
||||
|
||||
setWebProcessThreadId :: ThreadId -> AgentCtx -> IO ()
|
||||
|
||||
@@ -79,6 +79,8 @@ import Lib.Types.ServerApp
|
||||
import Model
|
||||
import Settings
|
||||
import Crypto.Hash
|
||||
import qualified Data.Text as Text
|
||||
import Lib.Types.NetAddress
|
||||
|
||||
pureLog :: Show a => a -> Handler a
|
||||
pureLog = liftA2 (*>) ($logInfo . show) pure
|
||||
@@ -231,6 +233,7 @@ cached action = do
|
||||
getInstalledAppsLogic :: (Has (Reader AgentCtx) sig m, Has AppMgr2.AppMgr sig m, MonadIO m) => m [AppInstalledPreview]
|
||||
getInstalledAppsLogic = do
|
||||
jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
|
||||
lanCache <- asks appLanThreads >>= liftIO . readTVarIO
|
||||
let installCache = installInfo . fst <$> inspect SInstalling jobCache
|
||||
serverApps <- AppMgr2.list [AppMgr2.flags|-s -d -m|]
|
||||
let remapped = remapAppMgrInfo jobCache serverApps
|
||||
@@ -244,6 +247,7 @@ getInstalledAppsLogic = do
|
||||
, appInstalledPreviewStatus = AppStatusTmp Installing
|
||||
, appInstalledPreviewVersionInstalled = storeAppVersionInfoVersion
|
||||
, appInstalledPreviewTorAddress = Nothing
|
||||
, appInstalledPreviewLanAddress = Nothing
|
||||
, appInstalledPreviewUi = False
|
||||
}
|
||||
installedPreviews = flip
|
||||
@@ -254,6 +258,13 @@ getInstalledAppsLogic = do
|
||||
, appInstalledPreviewStatus = s
|
||||
, appInstalledPreviewVersionInstalled = v
|
||||
, appInstalledPreviewTorAddress = infoResTorAddress
|
||||
, appInstalledPreviewLanAddress = if appId `HM.member` lanCache
|
||||
then
|
||||
LanAddress
|
||||
. (".onion" `Text.replace` ".local")
|
||||
. unTorAddress
|
||||
<$> infoResTorAddress
|
||||
else Nothing
|
||||
, appInstalledPreviewUi = AppManifest.uiAvailable infoResManifest
|
||||
}
|
||||
|
||||
@@ -286,6 +297,7 @@ getInstalledAppByIdLogic appId = do
|
||||
, appInstalledFullInstructions = Nothing
|
||||
, appInstalledFullLastBackup = backupTime
|
||||
, appInstalledFullTorAddress = Nothing
|
||||
, appInstalledFullLanAddress = Nothing
|
||||
, appInstalledFullConfiguredRequirements = []
|
||||
, appInstalledFullUninstallAlert = Nothing
|
||||
, appInstalledFullRestoreAlert = Nothing
|
||||
@@ -319,15 +331,21 @@ getInstalledAppByIdLogic appId = do
|
||||
manifest <- lift $ LAsync.wait manifest'
|
||||
instructions <- lift $ LAsync.wait instructions'
|
||||
backupTime <- lift $ LAsync.wait backupTime'
|
||||
lans <- asks appLanThreads
|
||||
lanEnabled <- liftIO $ HM.member appId <$> readTVarIO lans
|
||||
let lanAddress = if lanEnabled
|
||||
then LanAddress . (".onion" `Text.replace` ".local") . unTorAddress <$> infoResTorAddress
|
||||
else Nothing
|
||||
pure AppInstalledFull { appInstalledFullBase = AppBase appId infoResTitle (iconUrl appId version)
|
||||
, appInstalledFullStatus = status
|
||||
, appInstalledFullVersionInstalled = version
|
||||
, appInstalledFullInstructions = instructions
|
||||
, appInstalledFullLastBackup = backupTime
|
||||
, appInstalledFullTorAddress = infoResTorAddress
|
||||
, appInstalledFullLanAddress = lanAddress
|
||||
, appInstalledFullConfiguredRequirements = HM.elems requirements
|
||||
, appInstalledFullUninstallAlert = manifest >>= AppManifest.appManifestUninstallAlert
|
||||
, appInstalledFullRestoreAlert = manifest >>= AppManifest.appManifestRestoreAlert
|
||||
, appInstalledFullUninstallAlert = manifest >>= AppManifest.appManifestUninstallAlert
|
||||
, appInstalledFullRestoreAlert = manifest >>= AppManifest.appManifestRestoreAlert
|
||||
}
|
||||
runMaybeT (installing <|> installed) `orThrowM` NotFoundE "appId" (show appId)
|
||||
|
||||
@@ -769,3 +787,25 @@ dependencyInfoToDependencyRequirement asInstalled (base, status, AppMgr2.Depende
|
||||
let appDependencyRequirementReasonOptional = dependencyInfoReasonOptional
|
||||
appDependencyRequirementDefault = dependencyInfoRequired
|
||||
in AppDependencyRequirement { .. }
|
||||
|
||||
postEnableLanR :: AppId -> Handler ()
|
||||
postEnableLanR = intoHandler . postEnableLanLogic
|
||||
|
||||
postEnableLanLogic :: (Has (Reader AgentCtx) sig m, Has AppMgr2.AppMgr sig m, MonadBaseControl IO m, MonadIO m)
|
||||
=> AppId
|
||||
-> m ()
|
||||
postEnableLanLogic appId = do
|
||||
cache <- asks appLanThreads
|
||||
action <- const () <<$>> LAsync.async (AppMgr2.lanEnable appId) -- unconditionally drops monad state from the action
|
||||
liftIO $ atomically $ modifyTVar' cache (HM.insert appId action)
|
||||
|
||||
postDisableLanR :: AppId -> Handler ()
|
||||
postDisableLanR = intoHandler . postDisableLanLogic
|
||||
|
||||
postDisableLanLogic :: (Has (Reader AgentCtx) sig m, MonadBaseControl IO m, MonadIO m) => AppId -> m ()
|
||||
postDisableLanLogic appId = do
|
||||
cache <- asks appLanThreads
|
||||
action <- liftIO . atomically $ stateTVar cache $ \s -> (HM.lookup appId s, HM.delete appId s)
|
||||
case action of
|
||||
Nothing -> pure () -- Nothing to do here
|
||||
Just x -> LAsync.cancel x
|
||||
|
||||
@@ -45,6 +45,7 @@ data AppInstalledPreview = AppInstalledPreview
|
||||
, appInstalledPreviewStatus :: AppStatus
|
||||
, appInstalledPreviewVersionInstalled :: Version
|
||||
, appInstalledPreviewTorAddress :: Maybe TorAddress
|
||||
, appInstalledPreviewLanAddress :: Maybe LanAddress
|
||||
, appInstalledPreviewUi :: Bool
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -129,6 +130,7 @@ data AppInstalledFull = AppInstalledFull
|
||||
, appInstalledFullStatus :: AppStatus
|
||||
, appInstalledFullVersionInstalled :: Version
|
||||
, appInstalledFullTorAddress :: Maybe TorAddress
|
||||
, appInstalledFullLanAddress :: Maybe LanAddress
|
||||
, appInstalledFullInstructions :: Maybe Text
|
||||
, appInstalledFullLastBackup :: Maybe UTCTime
|
||||
, appInstalledFullConfiguredRequirements :: [Stripped AppDependencyRequirement]
|
||||
|
||||
@@ -65,9 +65,8 @@ data InfoRes a = InfoRes
|
||||
:: Include
|
||||
(Either_ (DefaultEqSym1 'OnlyDependencies) (ElemSym1 'IncludeDependencies) a)
|
||||
(HM.HashMap AppId DependencyInfo)
|
||||
, infoResManifest
|
||||
:: Include (Either_ (DefaultEqSym1 'OnlyManifest) (ElemSym1 'IncludeManifest) a) AppManifest
|
||||
, infoResStatus :: Include (Either_ (DefaultEqSym1 'OnlyStatus) (ElemSym1 'IncludeStatus) a) AppContainerStatus
|
||||
, infoResManifest :: Include (Either_ (DefaultEqSym1 'OnlyManifest) (ElemSym1 'IncludeManifest) a) AppManifest
|
||||
, infoResStatus :: Include (Either_ (DefaultEqSym1 'OnlyStatus) (ElemSym1 'IncludeStatus) a) AppContainerStatus
|
||||
}
|
||||
instance SingI (a :: Either OnlyInfoFlag [IncludeInfoFlag]) => FromJSON (InfoRes a) where
|
||||
parseJSON = withObject "AppMgr Info/List Response" $ \o -> do
|
||||
@@ -270,6 +269,7 @@ data AppMgr (m :: Type -> Type) k where
|
||||
-- Tor ::_
|
||||
Update ::DryRun -> AppId -> Maybe VersionRange -> AppMgr m BreakageMap
|
||||
-- Verify ::_
|
||||
LanEnable ::AppId -> AppMgr m ()
|
||||
makeSmartConstructors ''AppMgr
|
||||
|
||||
newtype AppMgrCliC m a = AppMgrCliC { runAppMgrCliC :: m a }
|
||||
@@ -421,7 +421,8 @@ instance (Has (Error S9Error) sig m, Algebra sig m, MonadIO m) => Algebra (AppMg
|
||||
ExitFailure 6 ->
|
||||
throwError $ NotFoundE "appId@version" ([i|#{appId}#{maybe "" (('@':) . show) version}|])
|
||||
ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
|
||||
R other -> AppMgrCliC $ alg (runAppMgrCliC . hdl) other ctx
|
||||
(L (LanEnable appId)) -> readProcessInheritStderr "appmgr" ["lan", "enable", show appId] "" $> ctx
|
||||
R other -> AppMgrCliC $ alg (runAppMgrCliC . hdl) other ctx
|
||||
where
|
||||
versionSpec :: (IsString a, Semigroup a, ConvertText String a) => Maybe VersionRange -> a -> a
|
||||
versionSpec v = case v of
|
||||
|
||||
@@ -7,6 +7,10 @@ newtype TorAddress = TorAddress { unTorAddress :: Text } deriving (Eq)
|
||||
instance Show TorAddress where
|
||||
show = toS . unTorAddress
|
||||
|
||||
newtype LanAddress = LanAddress { unLanAddress :: Text } deriving (Eq)
|
||||
instance Show LanAddress where
|
||||
show = toS . unLanAddress
|
||||
|
||||
newtype LanIp = LanIp { unLanIp :: Text } deriving (Eq)
|
||||
instance Show LanIp where
|
||||
show = toS . unLanIp
|
||||
|
||||
Reference in New Issue
Block a user