mirror of
https://github.com/Start9Labs/start-os.git
synced 2026-03-31 20:43:41 +00:00
0.2.5 initial commit
Makefile incomplete
This commit is contained in:
Aiden McClelland
760
agent/src/Handler/Apps.hs
Normal file
760
agent/src/Handler/Apps.hs
Normal file
@@ -0,0 +1,760 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Handler.Apps where
|
||||
|
||||
import Startlude hiding ( modify
|
||||
, execState
|
||||
, asks
|
||||
, Reader
|
||||
, runReader
|
||||
, catchError
|
||||
, forkFinally
|
||||
, empty
|
||||
)
|
||||
|
||||
import Control.Carrier.Reader
|
||||
import Control.Carrier.Error.Church
|
||||
import Control.Carrier.Lift
|
||||
import qualified Control.Concurrent.Async.Lifted
|
||||
as LAsync
|
||||
import qualified Control.Concurrent.Lifted as Lifted
|
||||
import qualified Control.Exception.Lifted as Lifted
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Effect.Empty hiding ( guard )
|
||||
import Control.Effect.Labelled ( HasLabelled
|
||||
, Labelled
|
||||
, runLabelled
|
||||
)
|
||||
import Control.Lens hiding ( (??) )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Trans.Control ( MonadBaseControl )
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Lens
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.IORef
|
||||
import qualified Data.HashMap.Lazy as HML
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Singletons
|
||||
import Data.Singletons.Prelude.Bool ( SBool(..)
|
||||
, If
|
||||
)
|
||||
import Data.Singletons.Prelude.List ( Elem )
|
||||
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql ( ConnectionPool )
|
||||
import Database.Persist.Sqlite ( runSqlPool )
|
||||
import Exinst
|
||||
import Network.HTTP.Types
|
||||
import Yesod.Core.Content
|
||||
import Yesod.Core.Json
|
||||
import Yesod.Core.Handler hiding ( cached )
|
||||
import Yesod.Core.Types ( JSONResponse(..) )
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import Foundation
|
||||
import Handler.Backups
|
||||
import Handler.Icons
|
||||
import Handler.Types.Apps
|
||||
import Handler.Util
|
||||
import qualified Lib.Algebra.Domain.AppMgr as AppMgr2
|
||||
import Lib.Algebra.State.RegistryUrl
|
||||
import Lib.Background
|
||||
import Lib.Error
|
||||
import qualified Lib.External.AppMgr as AppMgr
|
||||
import qualified Lib.External.Registry as Reg
|
||||
import Lib.IconCache
|
||||
import qualified Lib.Notifications as Notifications
|
||||
import Lib.SystemPaths
|
||||
import Lib.TyFam.ConditionalData
|
||||
import Lib.Types.Core
|
||||
import Lib.Types.Emver
|
||||
import Lib.Types.ServerApp
|
||||
import Model
|
||||
import Settings
|
||||
import Crypto.Hash
|
||||
|
||||
pureLog :: Show a => a -> Handler a
|
||||
pureLog = liftA2 (*>) ($logInfo . show) pure
|
||||
|
||||
logRet :: ToJSON a => Handler a -> Handler a
|
||||
logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . LBS.toStrict . encode) pure)
|
||||
|
||||
mkAppStatus :: HM.HashMap AppId (BackupJobType, a) -> AppId -> AppContainerStatus -> AppStatus
|
||||
mkAppStatus hm appId status = case HM.lookup appId hm of
|
||||
Nothing -> AppStatusAppMgr status
|
||||
Just (CreateBackup , _) -> AppStatusTmp CreatingBackup
|
||||
Just (RestoreBackup, _) -> AppStatusTmp RestoringBackup
|
||||
|
||||
|
||||
type AllEffects m
|
||||
= AppMgr2.AppMgrCliC
|
||||
( RegistryUrlIOC
|
||||
( Labelled
|
||||
"iconTagCache"
|
||||
(ReaderT (TVar (HM.HashMap AppId (Digest MD5))))
|
||||
( Labelled
|
||||
"filesystemBase"
|
||||
(ReaderT Text)
|
||||
( Labelled
|
||||
"databaseConnection"
|
||||
(ReaderT ConnectionPool)
|
||||
(ReaderT AgentCtx (ErrorC S9Error (LiftC m)))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
intoHandler :: AllEffects Handler x -> Handler x
|
||||
intoHandler m = do
|
||||
ctx <- getYesod
|
||||
let fsbase = appFilesystemBase . appSettings $ ctx
|
||||
runM
|
||||
. handleS9ErrC
|
||||
. flip runReaderT ctx
|
||||
. flip runReaderT (appConnPool ctx)
|
||||
. runLabelled @"databaseConnection"
|
||||
. flip runReaderT fsbase
|
||||
. runLabelled @"filesystemBase"
|
||||
. flip runReaderT (appIconTags ctx)
|
||||
. runLabelled @"iconTagCache"
|
||||
. runRegistryUrlIOC
|
||||
. AppMgr2.runAppMgrCliC
|
||||
$ m
|
||||
{-# INLINE intoHandler #-}
|
||||
|
||||
-- TODO nasty. Also, note that if AppMgr.getInstalledApp fails for any app we will not return available apps res.
|
||||
getAvailableAppsR :: Handler (JSONResponse [AppAvailablePreview])
|
||||
getAvailableAppsR = disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getAvailableAppsLogic
|
||||
|
||||
getAvailableAppsLogic :: ( Has (Reader AgentCtx) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has RegistryUrl sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, MonadIO m
|
||||
, MonadBaseControl IO m
|
||||
)
|
||||
=> m [AppAvailablePreview]
|
||||
getAvailableAppsLogic = do
|
||||
jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
|
||||
let installCache = inspect SInstalling jobCache
|
||||
(Reg.AppManifestRes apps, serverApps) <- LAsync.concurrently Reg.getAppManifest
|
||||
(AppMgr2.list [AppMgr2.flags|-s -d|])
|
||||
let remapped = remapAppMgrInfo jobCache serverApps
|
||||
pure $ foreach apps $ \app@StoreApp { storeAppId } ->
|
||||
let installing =
|
||||
( (storeAppVersionInfoVersion . snd . installInfo &&& const (AppStatusTmp Installing))
|
||||
. fst
|
||||
<$> HM.lookup storeAppId installCache
|
||||
)
|
||||
installed = ((view _2 &&& view _1) <$> HM.lookup storeAppId remapped)
|
||||
in storeAppToAvailablePreview app $ installing <|> installed
|
||||
|
||||
getAvailableAppByIdR :: AppId -> Handler (JSONResponse AppAvailableFull)
|
||||
getAvailableAppByIdR appId =
|
||||
disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getAvailableAppByIdLogic appId
|
||||
|
||||
getAvailableAppByIdLogic :: ( Has (Reader AgentCtx) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has RegistryUrl sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, MonadIO m
|
||||
, MonadBaseControl IO m
|
||||
)
|
||||
=> AppId
|
||||
-> m AppAvailableFull
|
||||
getAvailableAppByIdLogic appId = do
|
||||
let storeAppId' = storeAppId
|
||||
jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
|
||||
let installCache = inspect SInstalling jobCache
|
||||
(Reg.AppManifestRes storeApps, serverApps) <- LAsync.concurrently Reg.getAppManifest
|
||||
(AppMgr2.list [AppMgr2.flags|-s -d|])
|
||||
StoreApp {..} <- pure (find ((== appId) . storeAppId) storeApps) `orThrowM` NotFoundE "appId" (show appId)
|
||||
let remapped = remapAppMgrInfo jobCache serverApps
|
||||
let installingInfo =
|
||||
( (storeAppVersionInfoVersion . snd . installInfo &&& const (AppStatusTmp Installing))
|
||||
. fst
|
||||
<$> HM.lookup appId installCache
|
||||
)
|
||||
<|> ((view _2 &&& view _1) <$> HM.lookup appId remapped)
|
||||
let latest = extract storeAppVersions
|
||||
dependencies <- AppMgr2.checkDependencies (AppMgr2.LocalOnly False)
|
||||
appId
|
||||
(Just . exactly $ storeAppVersionInfoVersion latest)
|
||||
enrichedDeps <- maybe (throwError (NotFoundE "dependencyId for" (show appId))) pure $ flip
|
||||
HML.traverseWithKey
|
||||
dependencies
|
||||
\depId depInfo ->
|
||||
let
|
||||
base = storeAppToAppBase <$> find ((== depId) . storeAppId') storeApps
|
||||
status =
|
||||
(HM.lookup depId installCache $> AppStatusTmp Installing) <|> (view _1 <$> HM.lookup depId remapped)
|
||||
in
|
||||
(, status, depInfo) <$> base
|
||||
let dependencyRequirements = fmap (dependencyInfoToDependencyRequirement (AsInstalled SFalse)) enrichedDeps
|
||||
pure AppAvailableFull
|
||||
{ appAvailableFullBase = AppBase
|
||||
appId
|
||||
storeAppTitle
|
||||
(storeIconUrl appId (storeAppVersionInfoVersion $ extract storeAppVersions))
|
||||
, appAvailableFullInstallInfo = installingInfo
|
||||
, appAvailableFullVersionLatest = storeAppVersionInfoVersion latest
|
||||
, appAvailableFullDescriptionShort = storeAppDescriptionShort
|
||||
, appAvailableFullDescriptionLong = storeAppDescriptionLong
|
||||
, appAvailableFullReleaseNotes = storeAppVersionInfoReleaseNotes latest
|
||||
, appAvailableFullDependencyRequirements = HM.elems dependencyRequirements
|
||||
, appAvailableFullVersions = storeAppVersionInfoVersion <$> storeAppVersions
|
||||
}
|
||||
|
||||
getAppLogsByIdR :: AppId -> Handler (JSONResponse [Text])
|
||||
getAppLogsByIdR appId = disableEndpointOnFailedUpdate $ handleS9ErrT $ do
|
||||
logs <- AppMgr.getAppLogs appId
|
||||
pure . JSONResponse . lines $ logs
|
||||
|
||||
getInstalledAppsR :: Handler (JSONResponse [AppInstalledPreview])
|
||||
getInstalledAppsR = disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getInstalledAppsLogic
|
||||
|
||||
cached :: MonadIO m => m a -> m (m a)
|
||||
cached action = do
|
||||
ref <- liftIO $ newIORef Nothing
|
||||
pure $ liftIO (readIORef ref) >>= \case
|
||||
Nothing -> action >>= liftA2 (*>) (liftIO . writeIORef ref . Just) pure
|
||||
Just x -> pure x
|
||||
|
||||
getInstalledAppsLogic :: (Has (Reader AgentCtx) sig m, Has AppMgr2.AppMgr sig m, MonadIO m) => m [AppInstalledPreview]
|
||||
getInstalledAppsLogic = do
|
||||
jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
|
||||
let installCache = installInfo . fst <$> inspect SInstalling jobCache
|
||||
serverApps <- AppMgr2.list [AppMgr2.flags|-s -d|]
|
||||
let remapped = remapAppMgrInfo jobCache serverApps
|
||||
installingPreviews = flip
|
||||
HM.mapWithKey
|
||||
installCache
|
||||
\installingId (StoreApp {..}, StoreAppVersionInfo {..}) -> AppInstalledPreview
|
||||
{ appInstalledPreviewBase = AppBase installingId
|
||||
storeAppTitle
|
||||
(iconUrl installingId storeAppVersionInfoVersion)
|
||||
, appInstalledPreviewStatus = AppStatusTmp Installing
|
||||
, appInstalledPreviewVersionInstalled = storeAppVersionInfoVersion
|
||||
, appInstalledPreviewTorAddress = Nothing
|
||||
}
|
||||
installedPreviews = flip
|
||||
HML.mapWithKey
|
||||
remapped
|
||||
\appId (s, v, AppMgr2.InfoRes {..}) -> AppInstalledPreview
|
||||
{ appInstalledPreviewBase = AppBase appId infoResTitle (iconUrl appId v)
|
||||
, appInstalledPreviewStatus = s
|
||||
, appInstalledPreviewVersionInstalled = v
|
||||
, appInstalledPreviewTorAddress = infoResTorAddress
|
||||
}
|
||||
|
||||
pure $ HML.elems $ HML.union installingPreviews installedPreviews
|
||||
|
||||
getInstalledAppByIdR :: AppId -> Handler (JSONResponse AppInstalledFull)
|
||||
getInstalledAppByIdR appId =
|
||||
disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getInstalledAppByIdLogic appId
|
||||
|
||||
getInstalledAppByIdLogic :: ( Has (Reader AgentCtx) sig m
|
||||
, Has RegistryUrl sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, MonadIO m
|
||||
, MonadBaseControl IO m
|
||||
)
|
||||
=> AppId
|
||||
-> m AppInstalledFull
|
||||
getInstalledAppByIdLogic appId = do
|
||||
jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
|
||||
let installCache = installInfo . fst <$> inspect SInstalling jobCache
|
||||
db <- asks appConnPool
|
||||
backupTime' <- LAsync.async $ liftIO $ flip runSqlPool db $ getLastSuccessfulBackup appId
|
||||
let installing = do
|
||||
backupTime <- lift $ LAsync.wait backupTime'
|
||||
hoistMaybe $ HM.lookup appId installCache <&> \(StoreApp {..}, StoreAppVersionInfo {..}) -> AppInstalledFull
|
||||
{ appInstalledFullBase = AppBase appId storeAppTitle (iconUrl appId storeAppVersionInfoVersion)
|
||||
, appInstalledFullStatus = AppStatusTmp Installing
|
||||
, appInstalledFullVersionInstalled = storeAppVersionInfoVersion
|
||||
, appInstalledFullInstructions = Nothing
|
||||
, appInstalledFullLastBackup = backupTime
|
||||
, appInstalledFullTorAddress = Nothing
|
||||
, appInstalledFullConfiguredRequirements = []
|
||||
}
|
||||
serverApps <- AppMgr2.list [AppMgr2.flags|-s -d|]
|
||||
let remapped = remapAppMgrInfo jobCache serverApps
|
||||
appManifestFetchCached <- cached Reg.getAppManifest
|
||||
let
|
||||
installed = do
|
||||
(status, version, AppMgr2.InfoRes {..}) <- hoistMaybe (HM.lookup appId remapped)
|
||||
instructions' <- lift $ LAsync.async $ AppMgr2.instructions appId
|
||||
requirements <- LAsync.runConcurrently $ flip
|
||||
HML.traverseWithKey
|
||||
(HML.filter AppMgr2.dependencyInfoRequired infoResDependencies)
|
||||
\depId depInfo -> LAsync.Concurrently $ do
|
||||
let
|
||||
fromInstalled = (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion)
|
||||
<$> hoistMaybe (HM.lookup depId serverApps)
|
||||
let fromStore = do
|
||||
Reg.AppManifestRes res <- lift appManifestFetchCached
|
||||
(storeAppTitle &&& storeAppVersionInfoVersion . extract . storeAppVersions)
|
||||
<$> hoistMaybe (find ((== depId) . storeAppId) res)
|
||||
(title, v) <- fromInstalled <|> fromStore
|
||||
let base = AppBase depId title (iconUrl depId v)
|
||||
let
|
||||
depStatus =
|
||||
(HM.lookup depId installCache $> AppStatusTmp Installing)
|
||||
<|> (view _1 <$> HM.lookup depId remapped)
|
||||
pure $ dependencyInfoToDependencyRequirement (AsInstalled STrue) (base, depStatus, depInfo)
|
||||
instructions <- lift $ LAsync.wait instructions'
|
||||
backupTime <- lift $ LAsync.wait backupTime'
|
||||
pure AppInstalledFull { appInstalledFullBase = AppBase appId infoResTitle (iconUrl appId version)
|
||||
, appInstalledFullStatus = status
|
||||
, appInstalledFullVersionInstalled = version
|
||||
, appInstalledFullInstructions = instructions
|
||||
, appInstalledFullLastBackup = backupTime
|
||||
, appInstalledFullTorAddress = infoResTorAddress
|
||||
, appInstalledFullConfiguredRequirements = HM.elems requirements
|
||||
}
|
||||
runMaybeT (installing <|> installed) `orThrowM` NotFoundE "appId" (show appId)
|
||||
|
||||
postUninstallAppR :: AppId -> Handler (JSONResponse (WithBreakages ()))
|
||||
postUninstallAppR appId = do
|
||||
dry <- AppMgr2.DryRun . isJust <$> lookupGetParam "dryrun"
|
||||
disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> postUninstallAppLogic appId dry
|
||||
|
||||
postUninstallAppLogic :: ( HasFilesystemBase sig m
|
||||
, Has (Reader AgentCtx) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, MonadIO m
|
||||
, HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
|
||||
, HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId (Digest MD5)))) sig m
|
||||
)
|
||||
=> AppId
|
||||
-> AppMgr2.DryRun
|
||||
-> m (WithBreakages ())
|
||||
postUninstallAppLogic appId dryrun = do
|
||||
jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
|
||||
let tmpStatuses = statuses jobCache
|
||||
serverApps <- AppMgr2.list [AppMgr2.flags| |]
|
||||
when (not $ HM.member appId serverApps) $ throwError (AppNotInstalledE appId)
|
||||
case HM.lookup appId tmpStatuses of
|
||||
Just Installing -> throwError (TemporarilyForbiddenE appId "uninstall" (show Installing))
|
||||
Just CreatingBackup -> throwError (TemporarilyForbiddenE appId "uninstall" (show CreatingBackup))
|
||||
Just RestoringBackup -> throwError (TemporarilyForbiddenE appId "uninstall" (show RestoringBackup))
|
||||
_ -> pure ()
|
||||
let flags = if coerce dryrun then Left dryrun else Right (AppMgr2.Purge True)
|
||||
breakageIds <- HM.keys . AppMgr2.unBreakageMap <$> AppMgr2.remove flags appId
|
||||
bs <- pure (traverse (hydrate $ (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> serverApps) breakageIds)
|
||||
`orThrowM` InternalE "Reported app breakage for app that isn't installed, contact support"
|
||||
when (not $ coerce dryrun) $ clearIcon appId
|
||||
pure $ WithBreakages bs ()
|
||||
|
||||
type InstallResponse :: Bool -> Type
|
||||
data InstallResponse a = InstallResponse (If a (WithBreakages ()) AppInstalledFull)
|
||||
instance ToJSON (Some1 InstallResponse) where
|
||||
toJSON (Some1 STrue (InstallResponse a)) = toJSON a
|
||||
toJSON (Some1 SFalse (InstallResponse a)) = toJSON a
|
||||
postInstallNewAppR :: AppId -> Handler (JSONResponse (Some1 InstallResponse))
|
||||
postInstallNewAppR appId = do
|
||||
dryrun <- isJust <$> lookupGetParam "dryrun"
|
||||
InstallNewAppReq { installNewAppVersion } <- requireCheckJsonBody
|
||||
disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> do
|
||||
withSomeSing dryrun $ \sb -> Some1 sb . InstallResponse <$> postInstallNewAppLogic appId installNewAppVersion sb
|
||||
|
||||
postInstallNewAppLogic :: forall sig m a
|
||||
. ( Has (Reader AgentCtx) sig m
|
||||
, HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
|
||||
, HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId (Digest MD5)))) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has RegistryUrl sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, HasFilesystemBase sig m
|
||||
, MonadIO m
|
||||
, MonadBaseControl IO m
|
||||
)
|
||||
=> AppId
|
||||
-> Version
|
||||
-> SBool a
|
||||
-> m (If a (WithBreakages ()) AppInstalledFull)
|
||||
postInstallNewAppLogic appId appVersion dryrun = do
|
||||
db <- asks appConnPool
|
||||
full <- (Just <$> getInstalledAppByIdLogic appId) `catchError` \case
|
||||
NotFoundE "appId" appId' ->
|
||||
if AppId appId' == appId then pure Nothing else throwError (NotFoundE "appId" appId')
|
||||
other -> throwError other
|
||||
case full of
|
||||
Just aif@AppInstalledFull{} -> if appInstalledFullVersionInstalled aif == appVersion
|
||||
then pure $ case dryrun of
|
||||
STrue -> WithBreakages [] ()
|
||||
SFalse -> aif
|
||||
else installIt db True
|
||||
Nothing -> installIt db False
|
||||
where
|
||||
installIt :: ConnectionPool -> Bool -> m (If a (WithBreakages ()) AppInstalledFull)
|
||||
installIt db isUpdate = do
|
||||
jobCacheTVar <- asks appBackgroundJobs
|
||||
store@StoreApp {..} <- Reg.getStoreAppInfo appId `orThrowM` NotFoundE "appId" (show appId)
|
||||
vinfo@StoreAppVersionInfo{} <-
|
||||
find ((== appVersion) . storeAppVersionInfoVersion) storeAppVersions
|
||||
`orThrowPure` NotFoundE "version" (show appVersion)
|
||||
-- if it is a dry run of an update we don't want to modify the cache
|
||||
case dryrun of
|
||||
STrue -> if not isUpdate
|
||||
then pure $ WithBreakages [] ()
|
||||
else do
|
||||
serverApps' <- LAsync.async $ AppMgr2.list [AppMgr2.flags| |]
|
||||
hm <- AppMgr2.update (AppMgr2.DryRun True) appId (Just $ exactly appVersion)
|
||||
(serverApps :: HM.HashMap AppId (AppMgr2.InfoRes ( 'Right '[]))) <- LAsync.wait serverApps'
|
||||
breakages <-
|
||||
traverse (hydrate ((AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> serverApps))
|
||||
(HM.keys $ AppMgr2.unBreakageMap hm)
|
||||
`orThrowPure` InternalE
|
||||
"Breakage reported for app that isn't installed, contact support"
|
||||
pure $ WithBreakages breakages ()
|
||||
SFalse -> do
|
||||
let
|
||||
action = do
|
||||
iconAction <- LAsync.async $ saveIcon (toS storeAppIconUrl)
|
||||
let install = if isUpdate
|
||||
then void $ AppMgr2.update (AppMgr2.DryRun False) appId (Just $ exactly appVersion)
|
||||
else AppMgr2.install (AppMgr2.NoCache True) appId (Just $ exactly appVersion)
|
||||
let
|
||||
success = liftIO $ void $ flip runSqlPool db $ Notifications.emit
|
||||
appId
|
||||
appVersion
|
||||
Notifications.InstallSuccess
|
||||
let failure e = liftIO $ do
|
||||
let notif = case e of
|
||||
AppMgrE _ ec -> Notifications.InstallFailedAppMgrExitCode ec
|
||||
_ -> Notifications.InstallFailedS9Error e
|
||||
void $ flip runSqlPool db $ Notifications.emit appId appVersion notif
|
||||
putStrLn @Text (show e)
|
||||
let todo = do
|
||||
install
|
||||
() <- LAsync.wait iconAction
|
||||
success
|
||||
todo `catchError` failure
|
||||
tid <- action `Lifted.forkFinally` const postInstall
|
||||
liftIO $ atomically $ modifyTVar' jobCacheTVar (insertJob appId (Install store vinfo) tid)
|
||||
getInstalledAppByIdLogic appId
|
||||
postInstall :: m ()
|
||||
postInstall = do
|
||||
jobCache <- asks appBackgroundJobs
|
||||
pool <- asks appConnPool
|
||||
liftIO . atomically $ modifyTVar jobCache (deleteJob appId)
|
||||
ls <- AppMgr2.list [AppMgr2.flags| |]
|
||||
LAsync.forConcurrently_ (HM.toList ls) $ \(k, AppMgr2.InfoRes {..}) -> when
|
||||
infoResNeedsRestart
|
||||
( postRestartServerAppLogic k
|
||||
`catchError` \e -> liftIO $ runSqlPool
|
||||
(void $ Notifications.emit k infoResVersion (Notifications.RestartFailed e))
|
||||
pool
|
||||
)
|
||||
|
||||
|
||||
postStartServerAppR :: AppId -> Handler ()
|
||||
postStartServerAppR appId = disableEndpointOnFailedUpdate . intoHandler $ postStartServerAppLogic appId
|
||||
|
||||
postStartServerAppLogic :: (Has (Error S9Error) sig m, Has AppMgr2.AppMgr sig m, Has (Reader AgentCtx) sig m, MonadIO m)
|
||||
=> AppId
|
||||
-> m ()
|
||||
postStartServerAppLogic appId = do
|
||||
jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
|
||||
info <- AppMgr2.info [AppMgr2.flags|-s -d|] appId `orThrowM` AppNotInstalledE appId
|
||||
(status, _, _) <- (HM.lookup appId $ remapAppMgrInfo jobCache (HM.singleton appId info))
|
||||
`orThrowPure` InternalE "Remapping magically deleted keys between source and target structures"
|
||||
case status of
|
||||
AppStatusAppMgr Stopped -> AppMgr2.start appId
|
||||
other -> throwError $ AppStateActionIncompatibleE appId other Start
|
||||
|
||||
postRestartServerAppR :: AppId -> Handler ()
|
||||
postRestartServerAppR appId = disableEndpointOnFailedUpdate . intoHandler $ postRestartServerAppLogic appId
|
||||
|
||||
postRestartServerAppLogic :: ( Has (Reader AgentCtx) sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, MonadBaseControl IO m
|
||||
, MonadIO m
|
||||
)
|
||||
=> AppId
|
||||
-> m ()
|
||||
postRestartServerAppLogic appId = do
|
||||
jobCache <- asks appBackgroundJobs
|
||||
answer <- Lifted.newEmptyMVar
|
||||
void . Lifted.fork $ do
|
||||
tid <- Lifted.myThreadId
|
||||
problem <- liftIO . atomically $ do
|
||||
JobCache jobs <- readTVar jobCache
|
||||
case HM.lookup appId jobs of
|
||||
Just (Some1 s _, _) -> pure (Just . throwError $ TemporarilyForbiddenE appId "restart" (show s))
|
||||
Nothing -> do
|
||||
modifyTVar jobCache (insertJob appId RestartApp tid)
|
||||
pure Nothing
|
||||
case problem of
|
||||
Nothing -> do
|
||||
AppMgr2.restart appId `Lifted.finally` (liftIO . atomically) (modifyTVar jobCache (deleteJob appId))
|
||||
Lifted.putMVar answer Nothing
|
||||
Just p -> Lifted.putMVar answer (Just p)
|
||||
Lifted.takeMVar answer >>= \case
|
||||
Nothing -> pure ()
|
||||
Just p -> p
|
||||
|
||||
|
||||
postStopServerAppR :: AppId -> Handler (JSONResponse (WithBreakages ()))
|
||||
postStopServerAppR appId = disableEndpointOnFailedUpdate do
|
||||
dryrun <- isJust <$> lookupGetParam "dryrun"
|
||||
mRes <- intoHandler $ runMaybeT (JSONResponse <$> postStopServerAppLogic appId (AppMgr2.DryRun dryrun))
|
||||
case mRes of
|
||||
Nothing -> sendResponseStatus status200 ()
|
||||
Just x -> pure x
|
||||
|
||||
postStopServerAppLogic :: ( Has Empty sig m
|
||||
, Has (Reader AgentCtx) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, MonadIO m
|
||||
, MonadBaseControl IO m
|
||||
)
|
||||
=> AppId
|
||||
-> AppMgr2.DryRun
|
||||
-> m (WithBreakages ())
|
||||
postStopServerAppLogic appId dryrun = do
|
||||
jobCache <- asks appBackgroundJobs
|
||||
titles <- (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <<$>> AppMgr2.list [AppMgr2.flags| |]
|
||||
let stopIt = do
|
||||
breakages <- AppMgr2.stop dryrun appId
|
||||
bases <- traverse (hydrate titles) (HM.keys $ AppMgr2.unBreakageMap breakages)
|
||||
`orThrowPure` InternalE "Breakages reported for app that isn't installed, contact support"
|
||||
pure $ WithBreakages bases ()
|
||||
status <- AppMgr2.infoResStatus <<$>> AppMgr2.info [AppMgr2.flags|-S|] appId
|
||||
case (dryrun, status) of
|
||||
(_ , Nothing ) -> throwError $ NotFoundE "appId" (show appId)
|
||||
(AppMgr2.DryRun False, Just Running) -> do
|
||||
tid <- (void stopIt)
|
||||
`Lifted.forkFinally` const ((liftIO . atomically) (modifyTVar jobCache (deleteJob appId)))
|
||||
liftIO . atomically $ modifyTVar jobCache (insertJob appId StopApp tid)
|
||||
empty
|
||||
(AppMgr2.DryRun True , Just Running ) -> stopIt
|
||||
(AppMgr2.DryRun False, Just Restarting) -> do
|
||||
tid <- (void stopIt)
|
||||
`Lifted.forkFinally` const ((liftIO . atomically) (modifyTVar jobCache (deleteJob appId)))
|
||||
liftIO . atomically $ modifyTVar jobCache (insertJob appId StopApp tid)
|
||||
empty
|
||||
(AppMgr2.DryRun True, Just Restarting) -> stopIt
|
||||
(_, Just other) -> throwError $ AppStateActionIncompatibleE appId (AppStatusAppMgr other) Stop
|
||||
|
||||
getAppConfigR :: AppId -> Handler TypedContent
|
||||
getAppConfigR =
|
||||
disableEndpointOnFailedUpdate
|
||||
. handleS9ErrT
|
||||
. fmap (TypedContent typeJson . toContent)
|
||||
. AppMgr.getConfigurationAndSpec
|
||||
|
||||
patchAppConfigR :: AppId -> Handler (JSONResponse (WithBreakages ()))
|
||||
patchAppConfigR appId = disableEndpointOnFailedUpdate $ do
|
||||
dryrun <- isJust <$> lookupGetParam "dryrun"
|
||||
value <- requireCheckJsonBody @_ @Value
|
||||
realVal <-
|
||||
runM . handleS9ErrC $ ((value ^? key "config") `orThrowPure` (InvalidRequestE value "Missing 'config' key"))
|
||||
intoHandler $ JSONResponse <$> patchAppConfigLogic appId (AppMgr2.DryRun dryrun) realVal
|
||||
|
||||
patchAppConfigLogic :: ( Has (Reader AgentCtx) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, MonadBaseControl IO m
|
||||
, MonadIO m
|
||||
)
|
||||
=> AppId
|
||||
-> AppMgr2.DryRun
|
||||
-> Value
|
||||
-> m (WithBreakages ())
|
||||
patchAppConfigLogic appId dryrun cfg = do
|
||||
serverApps <- AppMgr2.list [AppMgr2.flags| |]
|
||||
AppMgr2.ConfigureRes {..} <- AppMgr2.configure dryrun appId (Just cfg)
|
||||
when (not $ coerce dryrun) $ for_ configureResNeedsRestart postRestartServerAppLogic
|
||||
breakages <-
|
||||
traverse (hydrate ((AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> serverApps))
|
||||
(HM.keys configureResStopped)
|
||||
`orThrowPure` InternalE "Breakage reported for app that is not installed, contact support"
|
||||
pure $ WithBreakages breakages ()
|
||||
|
||||
|
||||
getAppNotificationsR :: AppId -> Handler (JSONResponse [Entity Notification])
|
||||
getAppNotificationsR appId = disableEndpointOnFailedUpdate $ runDB $ do
|
||||
page <- lookupGetParam "page" `orDefaultTo` 1
|
||||
pageSize <- lookupGetParam "perPage" `orDefaultTo` 20
|
||||
evs <- selectList [NotificationAppId ==. appId]
|
||||
[Desc NotificationCreatedAt, LimitTo pageSize, OffsetBy ((page - 1) * pageSize)]
|
||||
let toArchive = fmap entityKey $ filter ((== Nothing) . notificationArchivedAt . entityVal) evs
|
||||
void $ Notifications.archive toArchive
|
||||
pure $ JSONResponse evs
|
||||
where
|
||||
orDefaultTo :: (Monad m, Read a) => m (Maybe Text) -> a -> m a
|
||||
orDefaultTo m a = do
|
||||
m' <- m
|
||||
case m' >>= readMaybe . toS of
|
||||
Nothing -> pure a
|
||||
Just x -> pure x
|
||||
|
||||
getAppMetricsR :: AppId -> Handler TypedContent
|
||||
getAppMetricsR appId =
|
||||
disableEndpointOnFailedUpdate . handleS9ErrT $ fmap (TypedContent typeJson . toContent) $ AppMgr.stats appId
|
||||
|
||||
getAvailableAppVersionInfoR :: AppId -> VersionRange -> Handler (JSONResponse AppVersionInfo)
|
||||
getAvailableAppVersionInfoR appId version =
|
||||
disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getAvailableAppVersionInfoLogic appId version
|
||||
|
||||
getAvailableAppVersionInfoLogic :: ( Has (Reader AgentCtx) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has RegistryUrl sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, MonadIO m
|
||||
, MonadBaseControl IO m
|
||||
)
|
||||
=> AppId
|
||||
-> VersionRange
|
||||
-> m AppVersionInfo
|
||||
getAvailableAppVersionInfoLogic appId appVersionSpec = do
|
||||
jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
|
||||
Reg.AppManifestRes storeApps <- Reg.getAppManifest
|
||||
let titles =
|
||||
(storeAppTitle &&& storeAppVersionInfoVersion . extract . storeAppVersions) <$> indexBy storeAppId storeApps
|
||||
StoreApp {..} <- find ((== appId) . storeAppId) storeApps `orThrowPure` NotFoundE "appId" (show appId)
|
||||
serverApps <- AppMgr2.list [AppMgr2.flags|-s -d|]
|
||||
let remapped = remapAppMgrInfo jobCache serverApps
|
||||
StoreAppVersionInfo {..} <-
|
||||
maximumMay (NE.filter ((<|| appVersionSpec) . storeAppVersionInfoVersion) storeAppVersions)
|
||||
`orThrowPure` NotFoundE "version spec " (show appVersionSpec)
|
||||
dependencies <- AppMgr2.checkDependencies (AppMgr2.LocalOnly False)
|
||||
appId
|
||||
(Just $ exactly storeAppVersionInfoVersion)
|
||||
requirements <- flip HML.traverseWithKey dependencies $ \depId depInfo -> do
|
||||
base <- hydrate titles depId `orThrowPure` NotFoundE "metadata for" (show depId)
|
||||
let status =
|
||||
(HM.lookup depId (inspect SInstalling jobCache) $> AppStatusTmp Installing)
|
||||
<|> (view _1 <$> HM.lookup depId remapped)
|
||||
pure $ dependencyInfoToDependencyRequirement (AsInstalled SFalse) (base, status, depInfo)
|
||||
pure AppVersionInfo { appVersionInfoVersion = storeAppVersionInfoVersion
|
||||
, appVersionInfoReleaseNotes = storeAppVersionInfoReleaseNotes
|
||||
, appVersionInfoDependencyRequirements = HM.elems requirements
|
||||
}
|
||||
|
||||
postAutoconfigureR :: AppId -> AppId -> Handler (JSONResponse (WithBreakages AutoconfigureChangesRes))
|
||||
postAutoconfigureR dependency dependent = do
|
||||
dry <- AppMgr2.DryRun . isJust <$> lookupGetParam "dryrun"
|
||||
disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> postAutoconfigureLogic dependency dependent dry
|
||||
|
||||
postAutoconfigureLogic :: ( Has (Reader AgentCtx) sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, MonadBaseControl IO m
|
||||
, MonadIO m
|
||||
)
|
||||
=> AppId
|
||||
-> AppId
|
||||
-> AppMgr2.DryRun
|
||||
-> m (WithBreakages AutoconfigureChangesRes)
|
||||
postAutoconfigureLogic dependency dependent dry = do
|
||||
-- IMPORTANT! AppMgr reverses arguments from the endpoint
|
||||
appData <- AppMgr2.list [AppMgr2.flags| |]
|
||||
let apps = HM.keys appData
|
||||
case (dependency `elem` apps, dependent `elem` apps) of
|
||||
(False, _ ) -> throwError $ NotFoundE "appId" (show dependency)
|
||||
(_ , False) -> throwError $ NotFoundE "appId" (show dependent)
|
||||
_ -> pure ()
|
||||
AppMgr2.AutoconfigureRes {..} <- AppMgr2.autoconfigure dry dependent dependency
|
||||
when (not $ coerce dry) $ for_ (AppMgr2.configureResNeedsRestart autoconfigureConfigRes) postRestartServerAppLogic
|
||||
let titles = (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> appData
|
||||
bases <- traverse (hydrate titles) (HM.keys (AppMgr2.configureResStopped autoconfigureConfigRes))
|
||||
`orThrowPure` InternalE "Breakages reported for app that isn't installed, contact support"
|
||||
pure $ WithBreakages bases (AutoconfigureChangesRes $ HM.lookup dependency autoconfigureChanged)
|
||||
|
||||
indexBy :: (Eq k, Hashable k) => (v -> k) -> [v] -> HM.HashMap k v
|
||||
indexBy = flip foldr HM.empty . (>>= HM.insertWith const)
|
||||
{-# INLINE indexBy #-}
|
||||
|
||||
hydrate :: HM.HashMap AppId (Text, Version) -> AppId -> Maybe AppBase
|
||||
hydrate titles appId = HM.lookup appId titles <&> \(t, v) -> AppBase appId t (iconUrl appId v)
|
||||
|
||||
remapAppMgrInfo :: (Elem 'AppMgr2.IncludeDependencies ls ~ 'True, Elem 'AppMgr2.IncludeStatus ls ~ 'True)
|
||||
=> JobCache
|
||||
-> HM.HashMap AppId (AppMgr2.InfoRes ( 'Right ls)) -- ^ AppMgr response
|
||||
-> HM.HashMap AppId (AppStatus, Version, AppMgr2.InfoRes ( 'Right ls))
|
||||
remapAppMgrInfo jobCache serverApps = flip
|
||||
HML.mapWithKey
|
||||
serverApps
|
||||
\appId infoRes@AppMgr2.InfoRes {..} ->
|
||||
let refinedDepInfo = flip
|
||||
HML.mapWithKey
|
||||
infoResDependencies
|
||||
\depId depInfo ->
|
||||
case
|
||||
( HM.lookup depId tmpStatuses
|
||||
, AppMgr2.infoResStatus <$> HM.lookup depId serverApps
|
||||
, AppMgr2.dependencyInfoError depInfo
|
||||
)
|
||||
of
|
||||
-- mute all of the not-running violations that are currently backing up and container is paused
|
||||
(Just CreatingBackup, Just Paused, Just AppMgr2.NotRunning) ->
|
||||
depInfo { AppMgr2.dependencyInfoError = Nothing }
|
||||
(_, _, _) -> depInfo
|
||||
realViolations =
|
||||
any (isJust . AppMgr2.dependencyInfoError <&&> AppMgr2.dependencyInfoRequired) refinedDepInfo
|
||||
(status, version) =
|
||||
maybe (AppStatusAppMgr infoResStatus, infoResVersion) (first AppStatusTmp)
|
||||
$ ((, infoResVersion) <$> HM.lookup appId tmpStatuses)
|
||||
<|> (guard (not infoResIsConfigured || infoResIsRecoverable) $> (NeedsConfig, infoResVersion))
|
||||
<|> (guard realViolations $> (BrokenDependencies, infoResVersion))
|
||||
<|> (guard (infoResStatus == Restarting) $> (Crashed, infoResVersion))
|
||||
in ( status
|
||||
, version
|
||||
, infoRes
|
||||
{ AppMgr2.infoResDependencies = case status of
|
||||
AppStatusTmp NeedsConfig -> HM.empty
|
||||
_ -> refinedDepInfo
|
||||
}
|
||||
)
|
||||
where tmpStatuses = statuses jobCache
|
||||
|
||||
storeAppToAppBase :: StoreApp -> AppBase
|
||||
storeAppToAppBase StoreApp {..} =
|
||||
AppBase storeAppId storeAppTitle (storeIconUrl storeAppId (storeAppVersionInfoVersion $ extract storeAppVersions))
|
||||
|
||||
storeAppToAvailablePreview :: StoreApp -> Maybe (Version, AppStatus) -> AppAvailablePreview
|
||||
storeAppToAvailablePreview s@StoreApp {..} installed = AppAvailablePreview
|
||||
(storeAppToAppBase s)
|
||||
(storeAppVersionInfoVersion $ extract storeAppVersions)
|
||||
storeAppDescriptionShort
|
||||
installed
|
||||
|
||||
type AsInstalled :: Bool -> Type
|
||||
newtype AsInstalled a = AsInstalled { unAsInstalled :: SBool a }
|
||||
dependencyInfoToDependencyRequirement :: AsInstalled a
|
||||
-> (AppBase, Maybe AppStatus, AppMgr2.DependencyInfo)
|
||||
-> (AppDependencyRequirement (If a Strip Keep))
|
||||
dependencyInfoToDependencyRequirement asInstalled (base, status, AppMgr2.DependencyInfo {..}) = do
|
||||
let appDependencyRequirementBase = base
|
||||
let appDependencyRequirementDescription = dependencyInfoDescription
|
||||
let appDependencyRequirementVersionSpec = dependencyInfoVersionSpec
|
||||
let appDependencyRequirementViolation = case (status, dependencyInfoError) of
|
||||
(Just s@(AppStatusTmp Installing), _) -> Just $ IncompatibleStatus s
|
||||
(Nothing, _ ) -> Just Missing
|
||||
(_ , Just AppMgr2.NotInstalled) -> Just Missing
|
||||
(_, Just (AppMgr2.InvalidVersion _ _)) -> Just IncompatibleVersion
|
||||
(_, Just (AppMgr2.UnsatisfiedConfig reasons)) -> Just . IncompatibleConfig $ reasons
|
||||
(Just s , Just AppMgr2.NotRunning ) -> Just $ IncompatibleStatus s
|
||||
(_ , Nothing ) -> Nothing
|
||||
case asInstalled of
|
||||
AsInstalled STrue ->
|
||||
let appDependencyRequirementReasonOptional = ()
|
||||
appDependencyRequirementDefault = ()
|
||||
in AppDependencyRequirement { .. }
|
||||
AsInstalled SFalse ->
|
||||
let appDependencyRequirementReasonOptional = dependencyInfoReasonOptional
|
||||
appDependencyRequirementDefault = dependencyInfoRequired
|
||||
in AppDependencyRequirement { .. }
|
||||
Reference in New Issue
Block a user