diff --git a/agent/config/routes b/agent/config/routes index 899d90131..43ad00853 100644 --- a/agent/config/routes +++ b/agent/config/routes @@ -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 diff --git a/agent/src/Application.hs b/agent/src/Application.hs index 956c869d6..806dcc650 100644 --- a/agent/src/Application.hs +++ b/agent/src/Application.hs @@ -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 diff --git a/agent/src/Foundation.hs b/agent/src/Foundation.hs index a2af4dd05..142aa9477 100644 --- a/agent/src/Foundation.hs +++ b/agent/src/Foundation.hs @@ -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 () diff --git a/agent/src/Handler/Apps.hs b/agent/src/Handler/Apps.hs index 261a7d771..247fbda95 100644 --- a/agent/src/Handler/Apps.hs +++ b/agent/src/Handler/Apps.hs @@ -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 diff --git a/agent/src/Handler/Types/Apps.hs b/agent/src/Handler/Types/Apps.hs index 443c1e8c1..888dbed62 100644 --- a/agent/src/Handler/Types/Apps.hs +++ b/agent/src/Handler/Types/Apps.hs @@ -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] diff --git a/agent/src/Lib/Algebra/Domain/AppMgr.hs b/agent/src/Lib/Algebra/Domain/AppMgr.hs index 85b294fa7..5067a2e2e 100644 --- a/agent/src/Lib/Algebra/Domain/AppMgr.hs +++ b/agent/src/Lib/Algebra/Domain/AppMgr.hs @@ -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 diff --git a/agent/src/Lib/Types/NetAddress.hs b/agent/src/Lib/Types/NetAddress.hs index 82d4c5138..9b78522b7 100644 --- a/agent/src/Lib/Types/NetAddress.hs +++ b/agent/src/Lib/Types/NetAddress.hs @@ -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