mirror of
https://github.com/Start9Labs/start-os.git
synced 2026-03-26 18:31:52 +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 { .. }
|
||||
9
agent/src/Handler/Authenticate.hs
Normal file
9
agent/src/Handler/Authenticate.hs
Normal file
@@ -0,0 +1,9 @@
|
||||
module Handler.Authenticate where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Foundation
|
||||
|
||||
-- handled by auth switch in Foundation
|
||||
getAuthenticateR :: Handler ()
|
||||
getAuthenticateR = pure ()
|
||||
218
agent/src/Handler/Backups.hs
Normal file
218
agent/src/Handler/Backups.hs
Normal file
@@ -0,0 +1,218 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Backups where
|
||||
|
||||
import Startlude hiding ( Reader
|
||||
, ask
|
||||
, runReader
|
||||
)
|
||||
|
||||
import Control.Effect.Labelled hiding ( Handler )
|
||||
import Control.Effect.Reader.Labelled
|
||||
import Control.Carrier.Error.Church
|
||||
import Control.Carrier.Lift
|
||||
import Control.Carrier.Reader ( runReader )
|
||||
import Data.Aeson
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.UUID.V4
|
||||
import Database.Persist.Sql
|
||||
import Yesod.Auth
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Types
|
||||
|
||||
import Foundation
|
||||
import Handler.Util
|
||||
import Lib.Error
|
||||
import qualified Lib.External.AppMgr as AppMgr
|
||||
import qualified Lib.Notifications as Notifications
|
||||
import Lib.Password
|
||||
import Lib.Types.Core
|
||||
import Lib.Types.Emver
|
||||
import Model
|
||||
import qualified Lib.Algebra.Domain.AppMgr as AppMgr2
|
||||
import Lib.Background
|
||||
import Control.Concurrent.STM
|
||||
import Exinst
|
||||
|
||||
|
||||
data CreateBackupReq = CreateBackupReq
|
||||
{ createBackupLogicalName :: FilePath
|
||||
, createBackupPassword :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON CreateBackupReq where
|
||||
parseJSON = withObject "Create Backup Req" $ \o -> do
|
||||
createBackupLogicalName <- o .: "logicalname"
|
||||
createBackupPassword <- o .:? "password" .!= Nothing
|
||||
pure CreateBackupReq { .. }
|
||||
|
||||
data RestoreBackupReq = RestoreBackupReq
|
||||
{ restoreBackupLogicalName :: FilePath
|
||||
, restoreBackupPassword :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON RestoreBackupReq where
|
||||
parseJSON = withObject "Restore Backup Req" $ \o -> do
|
||||
restoreBackupLogicalName <- o .: "logicalname"
|
||||
restoreBackupPassword <- o .:? "password" .!= Nothing
|
||||
pure RestoreBackupReq { .. }
|
||||
|
||||
-- Handlers
|
||||
|
||||
postCreateBackupR :: AppId -> Handler ()
|
||||
postCreateBackupR appId = disableEndpointOnFailedUpdate $ do
|
||||
req <- requireCheckJsonBody
|
||||
AgentCtx {..} <- getYesod
|
||||
account <- entityVal <$> requireAuth
|
||||
case validatePass account <$> (createBackupPassword req) of
|
||||
Just False -> runM . handleS9ErrC $ throwError BackupPassInvalidE
|
||||
_ ->
|
||||
createBackupLogic appId req
|
||||
& AppMgr2.runAppMgrCliC
|
||||
& runLabelled @"databaseConnection"
|
||||
& runReader appConnPool
|
||||
& runLabelled @"backgroundJobCache"
|
||||
& runReader appBackgroundJobs
|
||||
& handleS9ErrC
|
||||
& runM
|
||||
|
||||
|
||||
postStopBackupR :: AppId -> Handler ()
|
||||
postStopBackupR appId = disableEndpointOnFailedUpdate $ do
|
||||
cache <- getsYesod appBackgroundJobs
|
||||
stopBackupLogic appId & runLabelled @"backgroundJobCache" & runReader cache & handleS9ErrC & runM
|
||||
|
||||
postRestoreBackupR :: AppId -> Handler ()
|
||||
postRestoreBackupR appId = disableEndpointOnFailedUpdate $ do
|
||||
req <- requireCheckJsonBody
|
||||
AgentCtx {..} <- getYesod
|
||||
restoreBackupLogic appId req
|
||||
& AppMgr2.runAppMgrCliC
|
||||
& runLabelled @"databaseConnection"
|
||||
& runReader appConnPool
|
||||
& runLabelled @"backgroundJobCache"
|
||||
& runReader appBackgroundJobs
|
||||
& handleS9ErrC
|
||||
& runM
|
||||
|
||||
getListDisksR :: Handler (JSONResponse [AppMgr.DiskInfo])
|
||||
getListDisksR = fmap JSONResponse . runM . handleS9ErrC $ listDisksLogic
|
||||
|
||||
|
||||
-- Logic
|
||||
|
||||
createBackupLogic :: ( HasLabelled "backgroundJobCache" (Reader (TVar JobCache)) sig m
|
||||
, HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, MonadIO m
|
||||
)
|
||||
=> AppId
|
||||
-> CreateBackupReq
|
||||
-> m ()
|
||||
createBackupLogic appId CreateBackupReq {..} = do
|
||||
jobCache <- ask @"backgroundJobCache"
|
||||
db <- ask @"databaseConnection"
|
||||
version <- fmap AppMgr2.infoResVersion $ AppMgr2.info [AppMgr2.flags| |] appId `orThrowM` NotFoundE "appId"
|
||||
(show appId)
|
||||
res <- liftIO . atomically $ do
|
||||
(JobCache jobs) <- readTVar jobCache
|
||||
case HM.lookup appId jobs of
|
||||
Just (Some1 SCreatingBackup _, _) -> pure (Left $ BackupE appId "Already creating backup")
|
||||
Just (Some1 SRestoringBackup _, _) -> pure (Left $ BackupE appId "Cannot backup during restore")
|
||||
Just (Some1 _ _, _) -> pure (Left $ BackupE appId "Cannot backup: incompatible status")
|
||||
Nothing -> do
|
||||
-- this panic is here because we don't have the threadID yet, and it is required. We want to write the
|
||||
-- TVar anyway though so that we don't accidentally launch multiple backup jobs
|
||||
-- TODO: consider switching to MVar's for this
|
||||
modifyTVar jobCache (insertJob appId Backup $ panic "ThreadID prematurely forced")
|
||||
pure $ Right ()
|
||||
case res of
|
||||
Left e -> throwError e
|
||||
Right () -> do
|
||||
tid <- liftIO . forkIO $ do
|
||||
appmgrRes <- runExceptT (AppMgr.backupCreate createBackupPassword appId createBackupLogicalName)
|
||||
atomically $ modifyTVar' jobCache (deleteJob appId)
|
||||
let notif = case appmgrRes of
|
||||
Left e -> Notifications.BackupFailed e
|
||||
Right _ -> Notifications.BackupSucceeded
|
||||
flip runSqlPool db $ do
|
||||
void $ insertBackupResult appId version (isRight appmgrRes)
|
||||
void $ Notifications.emit appId version notif
|
||||
liftIO . atomically $ modifyTVar jobCache (insertJob appId Backup tid)
|
||||
|
||||
stopBackupLogic :: ( HasLabelled "backgroundJobCache" (Reader (TVar JobCache)) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, MonadIO m
|
||||
)
|
||||
=> AppId
|
||||
-> m ()
|
||||
stopBackupLogic appId = do
|
||||
jobCache <- ask @"backgroundJobCache"
|
||||
res <- liftIO . atomically $ do
|
||||
(JobCache jobs) <- readTVar jobCache
|
||||
case HM.lookup appId jobs of
|
||||
Just (Some1 SCreatingBackup _, tid) -> do
|
||||
modifyTVar jobCache (deleteJob appId)
|
||||
pure (Right tid)
|
||||
Just (Some1 SRestoringBackup _, _) -> pure (Left $ BackupE appId "Cannot interrupt restore")
|
||||
_ -> pure (Left $ NotFoundE "backup job" (show appId))
|
||||
case res of
|
||||
Left e -> throwError e
|
||||
Right tid -> liftIO $ killThread tid
|
||||
|
||||
restoreBackupLogic :: ( HasLabelled "backgroundJobCache" (Reader (TVar JobCache)) sig m
|
||||
, HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
|
||||
, Has (Error S9Error) sig m
|
||||
, Has AppMgr2.AppMgr sig m
|
||||
, MonadIO m
|
||||
)
|
||||
=> AppId
|
||||
-> RestoreBackupReq
|
||||
-> m ()
|
||||
restoreBackupLogic appId RestoreBackupReq {..} = do
|
||||
jobCache <- ask @"backgroundJobCache"
|
||||
db <- ask @"databaseConnection"
|
||||
version <- fmap AppMgr2.infoResVersion $ AppMgr2.info [AppMgr2.flags| |] appId `orThrowM` NotFoundE "appId"
|
||||
(show appId)
|
||||
res <- liftIO . atomically $ do
|
||||
(JobCache jobs) <- readTVar jobCache
|
||||
case HM.lookup appId jobs of
|
||||
Just (Some1 SCreatingBackup _, _) -> pure (Left $ BackupE appId "Cannot restore during backup")
|
||||
Just (Some1 SRestoringBackup _, _) -> pure (Left $ BackupE appId "Already restoring backup")
|
||||
Just (Some1 _ _, _) -> pure (Left $ BackupE appId "Cannot backup: incompatible status")
|
||||
Nothing -> do
|
||||
-- this panic is here because we don't have the threadID yet, and it is required. We want to write the
|
||||
-- TVar anyway though so that we don't accidentally launch multiple backup jobs
|
||||
-- TODO: consider switching to MVar's for this
|
||||
modifyTVar jobCache (insertJob appId Restore $ panic "ThreadID prematurely forced")
|
||||
pure $ Right ()
|
||||
case res of
|
||||
Left e -> throwError e
|
||||
Right _ -> do
|
||||
tid <- liftIO . forkIO $ do
|
||||
appmgrRes <- runExceptT (AppMgr.backupRestore restoreBackupPassword appId restoreBackupLogicalName)
|
||||
atomically $ modifyTVar jobCache (deleteJob appId)
|
||||
let notif = case appmgrRes of
|
||||
Left e -> Notifications.RestoreFailed e
|
||||
Right _ -> Notifications.RestoreSucceeded
|
||||
flip runSqlPool db $ void $ Notifications.emit appId version notif
|
||||
liftIO . atomically $ modifyTVar jobCache (insertJob appId Restore tid)
|
||||
|
||||
|
||||
listDisksLogic :: (Has (Error S9Error) sig m, MonadIO m) => m [AppMgr.DiskInfo]
|
||||
listDisksLogic = runExceptT AppMgr.diskShow >>= liftEither
|
||||
|
||||
insertBackupResult :: MonadIO m => AppId -> Version -> Bool -> SqlPersistT m (Entity BackupRecord)
|
||||
insertBackupResult appId appVersion succeeded = do
|
||||
uuid <- liftIO nextRandom
|
||||
now <- liftIO getCurrentTime
|
||||
let k = (BackupRecordKey uuid)
|
||||
let v = (BackupRecord now appId appVersion succeeded)
|
||||
insertKey k v
|
||||
pure $ Entity k v
|
||||
|
||||
getLastSuccessfulBackup :: MonadIO m => AppId -> SqlPersistT m (Maybe UTCTime)
|
||||
getLastSuccessfulBackup appId = backupRecordCreatedAt . entityVal <<$>> selectFirst
|
||||
[BackupRecordAppId ==. appId, BackupRecordSucceeded ==. True]
|
||||
[Desc BackupRecordCreatedAt]
|
||||
85
agent/src/Handler/Hosts.hs
Normal file
85
agent/src/Handler/Hosts.hs
Normal file
@@ -0,0 +1,85 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Hosts where
|
||||
|
||||
import Startlude hiding ( ask )
|
||||
|
||||
import Control.Carrier.Lift ( runM )
|
||||
import Control.Carrier.Error.Church
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Binary as CB
|
||||
import Data.Time.ISO8601
|
||||
import Yesod.Core hiding ( expiresAt )
|
||||
|
||||
import Foundation
|
||||
import Daemon.ZeroConf
|
||||
import Handler.Register ( produceProofOfKey
|
||||
, checkExistingPasswordRegistration
|
||||
)
|
||||
import Handler.Types.Hosts
|
||||
import Handler.Types.Register
|
||||
import Lib.Crypto
|
||||
import Lib.Error
|
||||
import Lib.Password ( rootAccountName )
|
||||
import Lib.ProductKey
|
||||
import Lib.Ssl
|
||||
import Lib.SystemPaths
|
||||
import Lib.Tor
|
||||
import Settings
|
||||
|
||||
getHostsR :: Handler HostsRes
|
||||
getHostsR = handleS9ErrT $ do
|
||||
settings <- getsYesod appSettings
|
||||
productKey <- liftIO . getProductKey . appFilesystemBase $ settings
|
||||
hostParams <- extractHostsQueryParams
|
||||
|
||||
verifyHmac productKey hostParams
|
||||
verifyTimestampNotExpired $ hostsParamsExpiration hostParams
|
||||
|
||||
mClaimedAt <- checkExistingPasswordRegistration rootAccountName
|
||||
case mClaimedAt of
|
||||
Nothing -> pure $ NullReply
|
||||
Just claimedAt -> do
|
||||
fmap HostsRes . mapExceptT (liftIO . runM . injectFilesystemBaseFromContext settings) $ getRegistration
|
||||
productKey
|
||||
claimedAt
|
||||
|
||||
verifyHmac :: MonadIO m => Text -> HostsParams -> S9ErrT m ()
|
||||
verifyHmac productKey params = do
|
||||
let computedHmacDigest = computeHmac productKey hostsParamsExpiration hostsParamsSalt
|
||||
unless (hostsParamsHmac == computedHmacDigest) $ throwE unauthorizedHmac
|
||||
where
|
||||
HostsParams { hostsParamsHmac, hostsParamsExpiration, hostsParamsSalt } = params
|
||||
unauthorizedHmac = ClientCryptographyE "Unauthorized hmac"
|
||||
|
||||
verifyTimestampNotExpired :: MonadIO m => Text -> S9ErrT m ()
|
||||
verifyTimestampNotExpired expirationTimestamp = do
|
||||
now <- liftIO getCurrentTime
|
||||
case parseISO8601 . toS $ expirationTimestamp of
|
||||
Nothing -> throwE $ TTLExpirationE "invalid timestamp"
|
||||
Just expiration -> when (expiration < now) (throwE $ TTLExpirationE "expired")
|
||||
|
||||
getRegistration :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => Text -> UTCTime -> m RegisterRes
|
||||
getRegistration productKey registerResClaimedAt = do
|
||||
torAddress <- getAgentHiddenServiceUrlMaybe >>= \case
|
||||
Nothing -> throwError $ NotFoundE "prior registration" "torAddress"
|
||||
Just t -> pure $ t
|
||||
caCert <- readSystemPath rootCaCertPath >>= \case
|
||||
Nothing -> throwError $ NotFoundE "prior registration" "cert"
|
||||
Just t -> pure t
|
||||
|
||||
-- create an hmac of the torAddress + caCert for front end
|
||||
registerResTorAddressSig <- produceProofOfKey productKey torAddress
|
||||
registerResCertSig <- produceProofOfKey productKey caCert
|
||||
|
||||
let registerResCertName = root_CA_CERT_NAME
|
||||
registerResLanAddress <- getStart9AgentHostnameLocal
|
||||
|
||||
pure RegisterRes { .. }
|
||||
|
||||
getCertificateR :: Handler TypedContent
|
||||
getCertificateR = do
|
||||
base <- getsYesod $ appFilesystemBase . appSettings
|
||||
respondSource "application/x-x509-ca-cert"
|
||||
$ CB.sourceFile (toS $ rootCaCertPath `relativeTo` base)
|
||||
.| awaitForever sendChunkBS
|
||||
106
agent/src/Handler/Icons.hs
Normal file
106
agent/src/Handler/Icons.hs
Normal file
@@ -0,0 +1,106 @@
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
module Handler.Icons where
|
||||
|
||||
import Startlude hiding ( Reader
|
||||
, runReader
|
||||
)
|
||||
|
||||
import Control.Carrier.Error.Either
|
||||
import Control.Carrier.Lift
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Binary as CB
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Simple
|
||||
import System.FilePath.Posix
|
||||
import Yesod.Core
|
||||
|
||||
import Foundation
|
||||
import Lib.Algebra.State.RegistryUrl
|
||||
import Lib.Error
|
||||
import qualified Lib.External.Registry as Reg
|
||||
import Lib.IconCache
|
||||
import Lib.SystemPaths hiding ( (</>) )
|
||||
import Lib.Types.Core
|
||||
import Lib.Types.ServerApp
|
||||
import Settings
|
||||
import Control.Carrier.Reader hiding ( asks )
|
||||
import Control.Effect.Labelled ( runLabelled )
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Control.Concurrent.STM ( modifyTVar
|
||||
, readTVarIO
|
||||
)
|
||||
import Crypto.Hash.Conduit ( hashFile )
|
||||
import Lib.Types.Emver
|
||||
|
||||
iconUrl :: AppId -> Version -> Text
|
||||
iconUrl appId version = (foldMap (T.cons '/') . fst . renderRoute . AppIconR $ appId) <> "?" <> show version
|
||||
|
||||
storeIconUrl :: AppId -> Version -> Text
|
||||
storeIconUrl appId version =
|
||||
(foldMap (T.cons '/') . fst . renderRoute . AvailableAppIconR $ appId) <> "?" <> show version
|
||||
|
||||
getAppIconR :: AppId -> Handler TypedContent
|
||||
getAppIconR appId = handleS9ErrT $ do
|
||||
ctx <- getYesod
|
||||
let iconTags = appIconTags ctx
|
||||
storedTag <- liftIO $ readTVarIO iconTags >>= pure . HM.lookup appId
|
||||
path <- case storedTag of
|
||||
Nothing -> interp ctx $ do
|
||||
findIcon appId >>= \case
|
||||
Nothing -> fetchIcon
|
||||
Just fp -> do
|
||||
tag <- hashFile fp
|
||||
saveTag appId tag
|
||||
pure fp
|
||||
Just x -> do
|
||||
setWeakEtag (show x)
|
||||
interp ctx $ findIcon appId >>= \case
|
||||
Nothing -> do
|
||||
liftIO $ atomically $ modifyTVar iconTags (HM.delete appId)
|
||||
fetchIcon
|
||||
Just fp -> pure fp
|
||||
cacheSeconds 86_400
|
||||
lift $ respondSource (parseContentType path) $ CB.sourceFile path .| awaitForever sendChunkBS
|
||||
where
|
||||
fetchIcon = do
|
||||
url <- find ((== appId) . storeAppId) . Reg.storeApps <$> Reg.getAppManifest >>= \case
|
||||
Nothing -> throwError $ NotFoundE "icon" (show appId)
|
||||
Just x -> pure . toS $ storeAppIconUrl x
|
||||
bp <- getAbsoluteLocationFor iconBasePath
|
||||
saveIcon url
|
||||
pure (toS bp </> takeFileName url)
|
||||
interp ctx =
|
||||
mapExceptT (liftIO . runM)
|
||||
. runReader (appConnPool ctx)
|
||||
. runLabelled @"databaseConnection"
|
||||
. runReader (appFilesystemBase $ appSettings ctx)
|
||||
. runLabelled @"filesystemBase"
|
||||
. runReader (appIconTags ctx)
|
||||
. runLabelled @"iconTagCache"
|
||||
. runRegistryUrlIOC
|
||||
|
||||
|
||||
getAvailableAppIconR :: AppId -> Handler TypedContent
|
||||
getAvailableAppIconR appId = handleS9ErrT $ do
|
||||
s <- getsYesod appSettings
|
||||
url <- do
|
||||
find ((== appId) . storeAppId) . Reg.storeApps <$> interp s Reg.getAppManifest >>= \case
|
||||
Nothing -> throwE $ NotFoundE "icon" (show appId)
|
||||
Just x -> pure . toS $ storeAppIconUrl x
|
||||
req <- case parseRequest url of
|
||||
Nothing -> throwE $ RegistryParseE (toS url) "invalid url"
|
||||
Just x -> pure x
|
||||
cacheSeconds 86_400
|
||||
lift $ respondSource (parseContentType url) $ httpSource req getResponseBody .| awaitForever sendChunkBS
|
||||
where interp s = ExceptT . liftIO . runError . injectFilesystemBaseFromContext s . runRegistryUrlIOC
|
||||
|
||||
parseContentType :: FilePath -> ContentType
|
||||
parseContentType = contentTypeMapping . takeExtension
|
||||
where
|
||||
contentTypeMapping ext = case ext of
|
||||
".png" -> typePng
|
||||
".jpeg" -> typeJpeg
|
||||
".jpg" -> typeJpeg
|
||||
".gif" -> typeGif
|
||||
".svg" -> typeSvg
|
||||
_ -> typePlain
|
||||
75
agent/src/Handler/Login.hs
Normal file
75
agent/src/Handler/Login.hs
Normal file
@@ -0,0 +1,75 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Handler.Login
|
||||
( HasPasswordHash(..)
|
||||
, defaultStrength
|
||||
, setPasswordStrength
|
||||
, setPassword
|
||||
, validatePass
|
||||
-- * Interface to database and Yesod.Auth
|
||||
, validateUserWithPasswordHash
|
||||
-- Login Route Handler
|
||||
, postLoginR
|
||||
-- Logout Route Handler
|
||||
, postLogoutR
|
||||
)
|
||||
where
|
||||
|
||||
import Startlude
|
||||
import Data.Aeson ( withObject )
|
||||
import Yesod.Auth ( setCredsRedirect
|
||||
, clearCreds
|
||||
, Creds(..)
|
||||
)
|
||||
import Yesod.Core
|
||||
import Yesod.Persist
|
||||
|
||||
import Auth
|
||||
import Foundation
|
||||
import Lib.Password
|
||||
import Model
|
||||
|
||||
-- Internal data type for receiving JSON encoded accountIdentifier and password
|
||||
data LoginReq = LoginReq
|
||||
{ loginReqName :: Text
|
||||
, loginReqPassword :: Text
|
||||
}
|
||||
|
||||
instance FromJSON LoginReq where
|
||||
parseJSON = withObject "Login Request" $ \o -> do
|
||||
-- future version can pass an accountIdentifier
|
||||
let loginReqName = rootAccountName
|
||||
loginReqPassword <- o .: "password"
|
||||
pure LoginReq { .. }
|
||||
|
||||
-- the redirect in the 'then' block gets picked up by the 'authenticate'
|
||||
-- function in the YesodAuth instance for AgentCtx
|
||||
postLoginR :: SubHandlerFor Auth AgentCtx TypedContent
|
||||
postLoginR = do
|
||||
LoginReq name password <- requireCheckJsonBody
|
||||
isValid <- liftHandler $ validateUserWithPasswordHash (UniqueAccount name) password
|
||||
if isValid then liftHandler $ setCredsRedirect $ Creds "hashdb" name [] else notAuthenticated
|
||||
|
||||
-- the redirect in the 'then' block gets picked up by the 'authenticate'
|
||||
-- function in the YesodAuth instance for AgentCtx
|
||||
postLogoutR :: SubHandlerFor Auth AgentCtx ()
|
||||
postLogoutR = liftHandler $ clearCreds False
|
||||
|
||||
-- | Given a user unique identifier and password in plaintext, validate them against
|
||||
-- the database values. This function simply looks up the user id in the
|
||||
-- database and calls 'validatePass' to do the work.
|
||||
validateUserWithPasswordHash :: Unique Account -> Text -> Handler Bool
|
||||
validateUserWithPasswordHash name password = do
|
||||
account <- runDB $ getBy name
|
||||
pure case account of
|
||||
Nothing -> False
|
||||
Just account' -> flip validatePass password . entityVal $ account'
|
||||
|
||||
32
agent/src/Handler/Notifications.hs
Normal file
32
agent/src/Handler/Notifications.hs
Normal file
@@ -0,0 +1,32 @@
|
||||
module Handler.Notifications where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Data.UUID
|
||||
import Database.Persist
|
||||
import Yesod.Core.Handler
|
||||
import Yesod.Core.Types ( JSONResponse(..) )
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import Foundation
|
||||
import qualified Lib.Notifications as Notification
|
||||
import Model
|
||||
|
||||
getNotificationsR :: Handler (JSONResponse [Entity Notification])
|
||||
getNotificationsR = runDB $ do
|
||||
page <- lookupGetParam "page" `orDefaultTo` 1
|
||||
pageSize <- lookupGetParam "perPage" `orDefaultTo` 20
|
||||
evs <- selectList [] [Desc NotificationCreatedAt, LimitTo pageSize, OffsetBy ((page - 1) * pageSize)]
|
||||
let toArchive = fmap entityKey $ filter ((== Nothing) . notificationArchivedAt . entityVal) evs
|
||||
void $ Notification.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
|
||||
|
||||
deleteNotificationR :: UUID -> Handler ()
|
||||
deleteNotificationR notifId = runDB $ delete (coerce @_ @(Key Notification) notifId)
|
||||
36
agent/src/Handler/PasswordUpdate.hs
Normal file
36
agent/src/Handler/PasswordUpdate.hs
Normal file
@@ -0,0 +1,36 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.PasswordUpdate where
|
||||
|
||||
import Startlude hiding ( ask )
|
||||
|
||||
import Data.Aeson
|
||||
import Yesod.Core hiding ( expiresAt )
|
||||
import Yesod.Persist
|
||||
|
||||
|
||||
import Foundation
|
||||
import Lib.Error
|
||||
import Lib.Password
|
||||
import Model
|
||||
|
||||
patchPasswordR :: Handler ()
|
||||
patchPasswordR = handleS9ErrT $ do
|
||||
PasswordUpdateReq {..} <- requireCheckJsonBody
|
||||
updateAccountRegistration rootAccountName passwordUpdateReqPassword
|
||||
data PasswordUpdateReq = PasswordUpdateReq
|
||||
{ passwordUpdateReqPassword :: Text
|
||||
} deriving (Eq, Show)
|
||||
instance FromJSON PasswordUpdateReq where
|
||||
parseJSON = withObject "Update Password" $ \o -> do
|
||||
passwordUpdateReqPassword <- o .: "value"
|
||||
pure PasswordUpdateReq { .. }
|
||||
|
||||
updateAccountRegistration :: Text -> Text -> S9ErrT Handler ()
|
||||
updateAccountRegistration acctName newPassword = do
|
||||
now <- liftIO $ getCurrentTime
|
||||
account <- (lift . runDB . getBy $ UniqueAccount acctName) >>= \case
|
||||
Nothing -> throwE $ NotFoundE "account" acctName
|
||||
Just a -> pure a
|
||||
|
||||
account' <- setPassword newPassword $ (entityVal account) { accountUpdatedAt = now }
|
||||
(lift . runDB $ Yesod.Persist.replace (entityKey account) account')
|
||||
28
agent/src/Handler/PowerOff.hs
Normal file
28
agent/src/Handler/PowerOff.hs
Normal file
@@ -0,0 +1,28 @@
|
||||
module Handler.PowerOff where
|
||||
|
||||
import Startlude
|
||||
|
||||
import System.Process
|
||||
|
||||
import Foundation
|
||||
import Lib.Sound
|
||||
import Yesod.Core.Handler
|
||||
import Network.HTTP.Types
|
||||
|
||||
postShutdownR :: Handler ()
|
||||
postShutdownR = do
|
||||
liftIO $ callCommand "/bin/sync"
|
||||
liftIO $ playSong 400 marioDeath
|
||||
void $ liftIO $ forkIO $ do
|
||||
threadDelay 1_000_000
|
||||
callCommand "/sbin/shutdown now"
|
||||
sendResponseStatus status200 ()
|
||||
|
||||
postRestartR :: Handler ()
|
||||
postRestartR = do
|
||||
liftIO $ callCommand "/bin/sync"
|
||||
liftIO $ playSong 400 marioDeath
|
||||
void $ liftIO $ forkIO $ do
|
||||
threadDelay 1_000_000
|
||||
callCommand "/sbin/reboot"
|
||||
sendResponseStatus status200 ()
|
||||
140
agent/src/Handler/Register.hs
Normal file
140
agent/src/Handler/Register.hs
Normal file
@@ -0,0 +1,140 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Register where
|
||||
|
||||
import Startlude hiding ( ask )
|
||||
|
||||
import Control.Carrier.Error.Either ( runError )
|
||||
import Control.Carrier.Lift
|
||||
import Control.Effect.Throw ( liftEither )
|
||||
import Crypto.Cipher.Types
|
||||
import Data.ByteArray.Sized
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
import Database.Persist
|
||||
import Network.HTTP.Types.Status
|
||||
import Yesod.Core hiding ( expiresAt )
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import Daemon.ZeroConf
|
||||
import Foundation
|
||||
import Handler.Register.Nginx
|
||||
import Handler.Register.Tor
|
||||
import Handler.Types.HmacSig
|
||||
import Handler.Types.Register
|
||||
import Lib.Crypto
|
||||
import Lib.Error
|
||||
import Lib.Password
|
||||
import Lib.ProductKey
|
||||
import Lib.Ssl
|
||||
import Lib.SystemPaths
|
||||
import Model
|
||||
import Settings
|
||||
|
||||
postRegisterR :: Handler RegisterRes
|
||||
postRegisterR = handleS9ErrT $ do
|
||||
settings <- getsYesod appSettings
|
||||
|
||||
productKey <- liftIO . getProductKey . appFilesystemBase $ settings
|
||||
req <- requireCheckJsonBody
|
||||
|
||||
-- Decrypt torkey and password. This acts as product key authentication.
|
||||
torKeyFileContents <- decryptTorkey productKey req
|
||||
password <- decryptPassword productKey req
|
||||
rsaKeyFileContents <- decryptRSAKey productKey req
|
||||
|
||||
-- Check for existing registration.
|
||||
checkExistingPasswordRegistration rootAccountName >>= \case
|
||||
Nothing -> pure ()
|
||||
Just _ -> sendResponseStatus (Status 209 "Preexisting") ()
|
||||
|
||||
-- install new tor hidden service key and restart tor
|
||||
registerResTorAddress <- runM (injectFilesystemBaseFromContext settings $ bootupTor torKeyFileContents) >>= \case
|
||||
Just t -> pure t
|
||||
Nothing -> throwE TorServiceTimeoutE
|
||||
|
||||
-- install new ssl CA cert + nginx conf and restart nginx
|
||||
registerResCert <-
|
||||
runM . handleS9ErrC . (>>= liftEither) . liftIO . runM . injectFilesystemBaseFromContext settings $ do
|
||||
bootupHttpNginx
|
||||
runError @S9Error $ bootupSslNginx rsaKeyFileContents
|
||||
|
||||
-- create an hmac of the torAddress + caCert for front end
|
||||
registerResTorAddressSig <- produceProofOfKey productKey registerResTorAddress
|
||||
registerResCertSig <- produceProofOfKey productKey registerResCert
|
||||
|
||||
-- must match CN in config/csr.conf
|
||||
let registerResCertName = root_CA_CERT_NAME
|
||||
registerResLanAddress <- runM . injectFilesystemBaseFromContext settings $ getStart9AgentHostnameLocal
|
||||
|
||||
-- registration successful, save the password hash
|
||||
registerResClaimedAt <- saveAccountRegistration rootAccountName password
|
||||
pure RegisterRes { .. }
|
||||
|
||||
|
||||
decryptTorkey :: MonadIO m => Text -> RegisterReq -> S9ErrT m ByteString
|
||||
decryptTorkey productKey RegisterReq { registerTorKey, registerTorCtrCounter, registerTorKdfSalt } = do
|
||||
aesKey <- case mkAesKey registerTorKdfSalt productKey of
|
||||
Just k -> pure k
|
||||
Nothing -> throwE ProductKeyE
|
||||
|
||||
torKeyFileContents <- case makeIV registerTorCtrCounter of
|
||||
Just counter -> pure $ decryptAes256Ctr aesKey counter (unSizedByteArray registerTorKey)
|
||||
Nothing -> throwE $ ClientCryptographyE "invalid torkey aes ctr counter"
|
||||
|
||||
unless (torKeyPrefix `BS.isPrefixOf` torKeyFileContents) (throwE $ ClientCryptographyE "invalid tor key encryption")
|
||||
|
||||
pure torKeyFileContents
|
||||
where torKeyPrefix = "== ed25519v1-secret: type0 =="
|
||||
|
||||
decryptPassword :: MonadIO m => Text -> RegisterReq -> S9ErrT m Text
|
||||
decryptPassword productKey RegisterReq { registerPassword, registerPasswordCtrCounter, registerPasswordKdfSalt } = do
|
||||
aesKey <- case mkAesKey registerPasswordKdfSalt productKey of
|
||||
Just k -> pure k
|
||||
Nothing -> throwE ProductKeyE
|
||||
|
||||
password <- case makeIV registerPasswordCtrCounter of
|
||||
Just counter -> pure $ decryptAes256Ctr aesKey counter registerPassword
|
||||
Nothing -> throwE $ ClientCryptographyE "invalid password aes ctr counter"
|
||||
|
||||
let decoded = decodeUtf8 password
|
||||
unless (passwordPrefix `T.isPrefixOf` decoded) (throwE $ ClientCryptographyE "invalid password encryption")
|
||||
|
||||
-- drop password prefix in this case
|
||||
pure . T.drop (T.length passwordPrefix) $ decoded
|
||||
where passwordPrefix = "== password =="
|
||||
|
||||
decryptRSAKey :: MonadIO m => Text -> RegisterReq -> S9ErrT m ByteString
|
||||
decryptRSAKey productKey RegisterReq { registerRsa, registerRsaCtrCounter, registerRsaKdfSalt } = do
|
||||
aesKey <- case mkAesKey registerRsaKdfSalt productKey of
|
||||
Just k -> pure k
|
||||
Nothing -> throwE ProductKeyE
|
||||
|
||||
cert <- case makeIV registerRsaCtrCounter of
|
||||
Just counter -> pure $ decryptAes256Ctr aesKey counter registerRsa
|
||||
Nothing -> throwE $ ClientCryptographyE "invalid password aes ctr counter"
|
||||
|
||||
unless (certPrefix `BS.isPrefixOf` cert) (throwE $ ClientCryptographyE "invalid cert encryption")
|
||||
|
||||
pure cert
|
||||
where certPrefix = "-----BEGIN RSA PRIVATE KEY-----"
|
||||
|
||||
|
||||
checkExistingPasswordRegistration :: Text -> S9ErrT Handler (Maybe UTCTime)
|
||||
checkExistingPasswordRegistration acctIdentifier = lift . runDB $ do
|
||||
mAccount <- getBy $ UniqueAccount acctIdentifier
|
||||
pure $ fmap (accountCreatedAt . entityVal) mAccount
|
||||
|
||||
saveAccountRegistration :: Text -> Text -> S9ErrT Handler UTCTime
|
||||
saveAccountRegistration acctName password = lift . runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
account <- setPassword password $ accountNoPw now
|
||||
insert_ account
|
||||
pure now
|
||||
where accountNoPw t = Account t t acctName ""
|
||||
|
||||
produceProofOfKey :: MonadIO m => Text -> Text -> m HmacSig
|
||||
produceProofOfKey key message = do
|
||||
salt <- random16
|
||||
let hmac = computeHmac key message salt
|
||||
pure $ HmacSig hmac message salt
|
||||
158
agent/src/Handler/Register/Nginx.hs
Normal file
158
agent/src/Handler/Register/Nginx.hs
Normal file
@@ -0,0 +1,158 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Handler.Register.Nginx where
|
||||
|
||||
import Startlude hiding ( ask
|
||||
, catchError
|
||||
)
|
||||
|
||||
import Control.Carrier.Error.Church
|
||||
import Control.Effect.Lift
|
||||
import qualified Control.Effect.Reader.Labelled
|
||||
as Fused
|
||||
import qualified Data.ByteString as BS
|
||||
import System.Directory
|
||||
import Daemon.ZeroConf
|
||||
import Lib.ClientManifest
|
||||
import Lib.Error
|
||||
import Lib.Ssl
|
||||
import Lib.Synchronizers
|
||||
import Lib.SystemPaths
|
||||
import Lib.Tor
|
||||
import System.Posix ( removeLink )
|
||||
|
||||
-- Left error, Right CA cert for hmac signing
|
||||
bootupSslNginx :: (HasFilesystemBase sig m, Has (Error S9Error) sig m, Has (Lift IO) sig m, MonadIO m)
|
||||
=> ByteString
|
||||
-> m Text
|
||||
bootupSslNginx rsaKeyFileContents = do
|
||||
-- we need to ensure if the ssl setup fails that we remove all openssl key material and the nginx ssl conf before
|
||||
-- starting again
|
||||
resetSslState
|
||||
cert <- writeSslKeyAndCert rsaKeyFileContents
|
||||
sid <- getStart9AgentHostname
|
||||
installAmbassadorUiNginxHTTPS (sslOverrides sid) "start9-ambassador-ssl.conf"
|
||||
pure cert
|
||||
where
|
||||
sslOverrides sid =
|
||||
let hostname = sid <> ".local"
|
||||
in NginxSiteConfOverride
|
||||
{ nginxSiteConfOverrideAdditionalServerName = hostname
|
||||
, nginxSiteConfOverrideListen = 443
|
||||
, nginxSiteConfOverrideSsl = Just $ NginxSsl { nginxSslKeyPath = entityKeyPath sid
|
||||
, nginxSslCertPath = entityCertPath sid
|
||||
, nginxSslOnlyServerNames = [hostname]
|
||||
}
|
||||
}
|
||||
|
||||
resetSslState :: (HasFilesystemBase sig m, Has (Lift IO) sig m, MonadIO m) => m ()
|
||||
resetSslState = do
|
||||
base <- Fused.ask @"filesystemBase"
|
||||
host <- getStart9AgentHostname
|
||||
-- remove all files we explicitly create
|
||||
traverse_
|
||||
(liftIO . removePathForcibly . toS . flip relativeTo base)
|
||||
[ rootCaKeyPath
|
||||
, relBase $ (rootCaCertPath `relativeTo` "/") <> ".csr"
|
||||
, rootCaCertPath
|
||||
, intermediateCaKeyPath
|
||||
, relBase $ (intermediateCaCertPath `relativeTo` "/") <> ".csr"
|
||||
, intermediateCaCertPath
|
||||
, entityKeyPath host
|
||||
, relBase $ (entityCertPath host `relativeTo` "/") <> ".csr"
|
||||
, entityCertPath host
|
||||
, entityConfPath host
|
||||
, nginxSitesAvailable nginxSslConf
|
||||
]
|
||||
liftIO $ do
|
||||
withCurrentDirectory (toS $ flip relativeTo base $ rootCaDirectory <> "/newcerts")
|
||||
$ listDirectory "."
|
||||
>>= traverse_ removePathForcibly
|
||||
withCurrentDirectory (toS $ flip relativeTo base $ intermediateCaDirectory <> "/newcerts")
|
||||
$ listDirectory "."
|
||||
>>= traverse_ removePathForcibly
|
||||
writeFile (toS $ flip relativeTo base $ rootCaDirectory <> "/index.txt") ""
|
||||
writeFile (toS $ flip relativeTo base $ intermediateCaDirectory <> "/index.txt") ""
|
||||
_ <- liftIO $ try @SomeException . removeLink . toS $ (nginxSitesEnabled nginxSslConf) `relativeTo` base
|
||||
pure ()
|
||||
|
||||
|
||||
bootupHttpNginx :: (HasFilesystemBase sig m, MonadIO m) => m ()
|
||||
bootupHttpNginx = installAmbassadorUiNginxHTTP "start9-ambassador.conf"
|
||||
|
||||
writeSslKeyAndCert :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => ByteString -> m Text
|
||||
writeSslKeyAndCert rsaKeyFileContents = do
|
||||
directory <- toS <$> getAbsoluteLocationFor sslDirectory
|
||||
caKeyPath <- toS <$> getAbsoluteLocationFor rootCaKeyPath
|
||||
caConfPath <- toS <$> getAbsoluteLocationFor rootCaOpenSslConfPath
|
||||
caCertPath <- toS <$> getAbsoluteLocationFor rootCaCertPath
|
||||
intCaKeyPath <- toS <$> getAbsoluteLocationFor intermediateCaKeyPath
|
||||
intCaConfPath <- toS <$> getAbsoluteLocationFor intermediateCaOpenSslConfPath
|
||||
intCaCertPath <- toS <$> getAbsoluteLocationFor intermediateCaCertPath
|
||||
sid <- getStart9AgentHostname
|
||||
entKeyPath <- toS <$> getAbsoluteLocationFor (entityKeyPath sid)
|
||||
entConfPath <- toS <$> getAbsoluteLocationFor (entityConfPath sid)
|
||||
entCertPath <- toS <$> getAbsoluteLocationFor (entityCertPath sid)
|
||||
torAddr <- getAgentHiddenServiceUrl
|
||||
|
||||
let hostname = sid <> ".local"
|
||||
|
||||
liftIO $ createDirectoryIfMissing False directory
|
||||
liftIO $ BS.writeFile caKeyPath rsaKeyFileContents
|
||||
|
||||
(exit, str1, str2) <- writeRootCaCert caConfPath caKeyPath caCertPath
|
||||
liftIO $ do
|
||||
putStrLn @Text "openssl logs"
|
||||
putStrLn @Text "exit code: "
|
||||
print exit
|
||||
putStrLn @String $ "stdout: " <> str1
|
||||
putStrLn @String $ "stderr: " <> str2
|
||||
case exit of
|
||||
ExitSuccess -> pure ()
|
||||
ExitFailure ec -> throwError $ OpenSslE "root" ec str1 str2
|
||||
|
||||
(exit', str1', str2') <- writeIntermediateCert $ DeriveCertificate { applicantConfPath = intCaConfPath
|
||||
, applicantKeyPath = intCaKeyPath
|
||||
, applicantCertPath = intCaCertPath
|
||||
, signingConfPath = caConfPath
|
||||
, signingKeyPath = caKeyPath
|
||||
, signingCertPath = caCertPath
|
||||
, duration = 3650
|
||||
}
|
||||
liftIO $ do
|
||||
putStrLn @Text "openssl logs"
|
||||
putStrLn @Text "exit code: "
|
||||
print exit'
|
||||
putStrLn @String $ "stdout: " <> str1'
|
||||
putStrLn @String $ "stderr: " <> str2'
|
||||
case exit' of
|
||||
ExitSuccess -> pure ()
|
||||
ExitFailure ec -> throwError $ OpenSslE "intermediate" ec str1' str2'
|
||||
|
||||
|
||||
liftIO $ BS.writeFile entConfPath (domain_CSR_CONF hostname)
|
||||
|
||||
(exit'', str1'', str2'') <- writeLeafCert
|
||||
DeriveCertificate { applicantConfPath = entConfPath
|
||||
, applicantKeyPath = entKeyPath
|
||||
, applicantCertPath = entCertPath
|
||||
, signingConfPath = intCaConfPath
|
||||
, signingKeyPath = intCaKeyPath
|
||||
, signingCertPath = intCaCertPath
|
||||
, duration = 365
|
||||
}
|
||||
hostname
|
||||
torAddr
|
||||
|
||||
liftIO $ do
|
||||
putStrLn @Text "openssl logs"
|
||||
putStrLn @Text "exit code: "
|
||||
print exit''
|
||||
putStrLn @String $ "stdout: " <> str1''
|
||||
putStrLn @String $ "stderr: " <> str2''
|
||||
case exit'' of
|
||||
ExitSuccess -> pure ()
|
||||
ExitFailure ec -> throwError $ OpenSslE "leaf" ec str1' str2'
|
||||
|
||||
readSystemPath' rootCaCertPath
|
||||
44
agent/src/Handler/Register/Tor.hs
Normal file
44
agent/src/Handler/Register/Tor.hs
Normal file
@@ -0,0 +1,44 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Register.Tor where
|
||||
|
||||
import Startlude hiding ( ask )
|
||||
|
||||
import Control.Effect.Reader.Labelled
|
||||
import qualified Data.ByteString as BS
|
||||
import System.Directory
|
||||
import System.Process
|
||||
import Lib.SystemCtl
|
||||
import Lib.SystemPaths
|
||||
import Lib.Tor
|
||||
|
||||
bootupTor :: (HasFilesystemBase sig m, MonadIO m) => ByteString -> m (Maybe Text)
|
||||
bootupTor torKeyFileContents = do
|
||||
base <- ask @"filesystemBase"
|
||||
writeTorPrivateKeyFile torKeyFileContents
|
||||
|
||||
putStrLn @Text "restarting tor"
|
||||
liftIO . void $ systemCtl RestartService "tor"
|
||||
putStrLn @Text "restarted tor"
|
||||
|
||||
liftIO . fmap (join . hush) $ race
|
||||
(threadDelay 30_000_000)
|
||||
(runMaybeT . asum . repeat $ MaybeT . fmap hush $ try @SomeException
|
||||
(threadDelay 100_000 *> injectFilesystemBase base getAgentHiddenServiceUrl)
|
||||
)
|
||||
|
||||
writeTorPrivateKeyFile :: (MonadIO m, HasFilesystemBase sig m) => ByteString -> m ()
|
||||
writeTorPrivateKeyFile contents = do
|
||||
directory <- fmap toS . getAbsoluteLocationFor $ agentTorHiddenServiceDirectory
|
||||
privateKeyFilePath <- fmap toS . getAbsoluteLocationFor $ agentTorHiddenServicePrivateKeyPath
|
||||
liftIO $ do
|
||||
-- Clean out directory
|
||||
removePathForcibly directory
|
||||
createDirectory directory
|
||||
|
||||
-- write private key file
|
||||
BS.writeFile privateKeyFilePath contents
|
||||
|
||||
-- Set ownership and permissions so tor executable can generate other files
|
||||
callCommand $ "chown -R debian-tor:debian-tor " <> directory
|
||||
callCommand $ "chmod 2700 " <> directory
|
||||
51
agent/src/Handler/SelfUpdate.hs
Normal file
51
agent/src/Handler/SelfUpdate.hs
Normal file
@@ -0,0 +1,51 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Handler.SelfUpdate where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Control.Carrier.Error.Either
|
||||
import Data.Aeson
|
||||
import Yesod.Core
|
||||
|
||||
import Foundation
|
||||
import Lib.Algebra.State.RegistryUrl
|
||||
import Lib.Error
|
||||
import Lib.External.Registry
|
||||
import Lib.SystemPaths
|
||||
import Lib.Types.Emver
|
||||
|
||||
newtype UpdateAgentReq = UpdateAgentReq { updateAgentVersionSpecification :: VersionRange } deriving (Eq, Show)
|
||||
|
||||
instance FromJSON UpdateAgentReq where
|
||||
parseJSON = withObject "update agent request" $ fmap UpdateAgentReq . (.: "version")
|
||||
|
||||
newtype UpdateAgentRes = UpdateAgentRes { status :: UpdateInitStatus } deriving (Eq)
|
||||
instance ToJSON UpdateAgentRes where
|
||||
toJSON (UpdateAgentRes status) = object ["status" .= status]
|
||||
|
||||
instance ToTypedContent UpdateAgentRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent UpdateAgentRes where
|
||||
toContent = toContent . toJSON
|
||||
|
||||
|
||||
data UpdateInitStatus = UpdatingAlreadyInProgress | UpdatingCommence deriving (Show, Eq)
|
||||
instance ToJSON UpdateInitStatus where
|
||||
toJSON UpdatingAlreadyInProgress = String "UPDATING_ALREADY_IN_PROGRESS"
|
||||
toJSON UpdatingCommence = String "UPDATING_COMMENCE"
|
||||
|
||||
postUpdateAgentR :: Handler UpdateAgentRes
|
||||
postUpdateAgentR = handleS9ErrT $ do
|
||||
settings <- getsYesod appSettings
|
||||
avs <- updateAgentVersionSpecification <$> requireCheckJsonBody
|
||||
mVersion <- interp settings $ getLatestAgentVersionForSpec avs
|
||||
|
||||
when (isNothing mVersion) $ throwE $ NoCompliantAgentE avs
|
||||
|
||||
updateSpecBox <- getsYesod appSelfUpdateSpecification
|
||||
success <- liftIO $ tryPutMVar updateSpecBox avs
|
||||
|
||||
if success then pure $ UpdateAgentRes UpdatingCommence else pure $ UpdateAgentRes UpdatingAlreadyInProgress
|
||||
where interp s = ExceptT . liftIO . runError . injectFilesystemBaseFromContext s . runRegistryUrlIOC
|
||||
39
agent/src/Handler/SshKeys.hs
Normal file
39
agent/src/Handler/SshKeys.hs
Normal file
@@ -0,0 +1,39 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.SshKeys where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Types ( JSONResponse(..) )
|
||||
|
||||
import Foundation
|
||||
import Lib.Error
|
||||
import Lib.Ssh
|
||||
import Util.Function
|
||||
import Handler.Types.V0.Ssh
|
||||
|
||||
postSshKeysR :: Handler SshKeyFingerprint
|
||||
postSshKeysR = handleS9ErrT $ do
|
||||
settings <- getsYesod appSettings
|
||||
key <- sshKey <$> requireCheckJsonBody
|
||||
case fingerprint key of
|
||||
Left e -> throwE $ InvalidSshKeyE (toS e)
|
||||
Right fp -> do
|
||||
runReaderT (createSshKey key) settings
|
||||
pure $ uncurry3 SshKeyFingerprint fp
|
||||
|
||||
deleteSshKeyByFingerprintR :: Text -> Handler ()
|
||||
deleteSshKeyByFingerprintR key = handleS9ErrT $ do
|
||||
settings <- getsYesod appSettings
|
||||
runReaderT (deleteSshKey key) settings >>= \case
|
||||
True -> pure ()
|
||||
False -> throwE $ NotFoundE "sshKey" key
|
||||
|
||||
getSshKeysR :: Handler (JSONResponse [SshKeyFingerprint]) -- deprecated in 0.2.0
|
||||
getSshKeysR = handleS9ErrT $ do
|
||||
settings <- getsYesod appSettings
|
||||
keys <- runReaderT getSshKeys settings
|
||||
JSONResponse <$> case traverse fingerprint keys of
|
||||
Left e -> throwE $ InvalidSshKeyE (toS e)
|
||||
Right as -> pure $ uncurry3 SshKeyFingerprint <$> as
|
||||
71
agent/src/Handler/Status.hs
Normal file
71
agent/src/Handler/Status.hs
Normal file
@@ -0,0 +1,71 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Handler.Status where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Control.Carrier.Error.Either
|
||||
import Data.Aeson.Encoding
|
||||
import Git.Embed
|
||||
import Yesod.Core.Handler
|
||||
import Yesod.Core.Json
|
||||
import Yesod.Core.Types
|
||||
|
||||
import Constants
|
||||
import Daemon.ZeroConf
|
||||
import Foundation
|
||||
import Handler.Types.Metrics
|
||||
import Handler.Types.V0.Specs
|
||||
import Handler.Types.V0.Base
|
||||
import Lib.Algebra.State.RegistryUrl
|
||||
import Lib.Error
|
||||
import Lib.External.Metrics.Df
|
||||
import qualified Lib.External.Registry as Reg
|
||||
import Lib.External.Specs.CPU
|
||||
import Lib.External.Specs.Memory
|
||||
import Lib.Metrics
|
||||
import Lib.SystemPaths hiding ( (</>) )
|
||||
import Lib.Tor
|
||||
import Settings
|
||||
import Control.Carrier.Lift ( runM )
|
||||
|
||||
getVersionR :: Handler AppVersionRes
|
||||
getVersionR = pure . AppVersionRes $ agentVersion
|
||||
|
||||
getVersionLatestR :: Handler VersionLatestRes
|
||||
getVersionLatestR = handleS9ErrT $ do
|
||||
s <- getsYesod appSettings
|
||||
v <- interp s $ Reg.getLatestAgentVersion
|
||||
pure $ VersionLatestRes v
|
||||
where interp s = ExceptT . liftIO . runError . injectFilesystemBaseFromContext s . runRegistryUrlIOC
|
||||
|
||||
|
||||
getSpecsR :: Handler Encoding -- deprecated in 0.2.0
|
||||
getSpecsR = handleS9ErrT $ do
|
||||
settings <- getsYesod appSettings
|
||||
specsCPU <- liftIO getCpuInfo
|
||||
specsMem <- liftIO getMem
|
||||
specsDisk <- fmap show . metricDiskSize <$> getDfMetrics
|
||||
specsNetworkId <- lift . runM . injectFilesystemBaseFromContext settings $ getStart9AgentHostname
|
||||
specsTorAddress <- lift . runM . injectFilesystemBaseFromContext settings $ getAgentHiddenServiceUrl
|
||||
|
||||
let specsAgentVersion = agentVersion
|
||||
returnJsonEncoding SpecsRes { .. }
|
||||
|
||||
getMetricsR :: Handler (JSONResponse MetricsRes)
|
||||
getMetricsR = do
|
||||
app <- getYesod
|
||||
fmap (JSONResponse . MetricsRes) . handleS9ErrT . getServerMetrics $ app
|
||||
|
||||
embassyNamePath :: SystemPath
|
||||
embassyNamePath = "/root/agent/name.txt"
|
||||
|
||||
patchServerR :: Handler ()
|
||||
patchServerR = do
|
||||
PatchServerReq { patchServerReqName } <- requireCheckJsonBody @_ @PatchServerReq
|
||||
base <- getsYesod $ appFilesystemBase . appSettings
|
||||
liftIO $ writeFile (toS $ embassyNamePath `relativeTo` base) patchServerReqName
|
||||
|
||||
getGitR :: Handler Text
|
||||
getGitR = pure $embedGitRevision
|
||||
|
||||
24
agent/src/Handler/Tor.hs
Normal file
24
agent/src/Handler/Tor.hs
Normal file
@@ -0,0 +1,24 @@
|
||||
module Handler.Tor where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Data.Aeson
|
||||
import Yesod.Core
|
||||
|
||||
import Foundation
|
||||
import Lib.SystemPaths
|
||||
import Lib.Tor
|
||||
import Control.Carrier.Lift ( runM )
|
||||
|
||||
newtype GetTorRes = GetTorRes { unGetTorRes :: Text }
|
||||
instance ToJSON GetTorRes where
|
||||
toJSON a = object ["torAddress" .= unGetTorRes a]
|
||||
instance ToContent GetTorRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent GetTorRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
getTorAddressR :: Handler GetTorRes
|
||||
getTorAddressR = do
|
||||
settings <- getsYesod appSettings
|
||||
runM $ GetTorRes <$> injectFilesystemBaseFromContext settings getAgentHiddenServiceUrl
|
||||
178
agent/src/Handler/Types/Apps.hs
Normal file
178
agent/src/Handler/Types/Apps.hs
Normal file
@@ -0,0 +1,178 @@
|
||||
{-# LANGUAGE StandaloneKindSignatures #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Types.Apps where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Flatten
|
||||
import Data.Singletons
|
||||
|
||||
import Lib.TyFam.ConditionalData
|
||||
import Lib.Types.Core
|
||||
import Lib.Types.Emver
|
||||
import Lib.Types.Emver.Orphans ( )
|
||||
import Lib.Types.NetAddress
|
||||
data AppBase = AppBase
|
||||
{ appBaseId :: AppId
|
||||
, appBaseTitle :: Text
|
||||
, appBaseIconUrl :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON AppBase where
|
||||
toJSON AppBase {..} = object ["id" .= appBaseId, "title" .= appBaseTitle, "iconURL" .= appBaseIconUrl]
|
||||
|
||||
data AppAvailablePreview = AppAvailablePreview
|
||||
{ appAvailablePreviewBase :: AppBase
|
||||
, appAvailablePreviewVersionLatest :: Version
|
||||
, appAvailablePreviewDescriptionShort :: Text
|
||||
, appAvailablePreviewInstallInfo :: Maybe (Version, AppStatus)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON AppAvailablePreview where
|
||||
toJSON AppAvailablePreview {..} = mergeTo (toJSON appAvailablePreviewBase) $ object
|
||||
[ "versionLatest" .= appAvailablePreviewVersionLatest
|
||||
, "descriptionShort" .= appAvailablePreviewDescriptionShort
|
||||
, "versionInstalled" .= (fst <$> appAvailablePreviewInstallInfo)
|
||||
, "status" .= (snd <$> appAvailablePreviewInstallInfo)
|
||||
]
|
||||
|
||||
data AppInstalledPreview = AppInstalledPreview
|
||||
{ appInstalledPreviewBase :: AppBase
|
||||
, appInstalledPreviewStatus :: AppStatus
|
||||
, appInstalledPreviewVersionInstalled :: Version
|
||||
, appInstalledPreviewTorAddress :: Maybe TorAddress
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON AppInstalledPreview where
|
||||
toJSON AppInstalledPreview {..} = mergeTo (toJSON appInstalledPreviewBase) $ object
|
||||
[ "status" .= appInstalledPreviewStatus
|
||||
, "versionInstalled" .= appInstalledPreviewVersionInstalled
|
||||
, "torAddress" .= (unTorAddress <$> appInstalledPreviewTorAddress)
|
||||
]
|
||||
|
||||
data InstallNewAppReq = InstallNewAppReq
|
||||
{ installNewAppVersion :: Version
|
||||
, installNewAppDryRun :: Bool
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON InstallNewAppReq where
|
||||
parseJSON = withObject "Install New App Request" $ \o -> do
|
||||
installNewAppVersion <- o .: "version"
|
||||
installNewAppDryRun <- o .:? "dryRun" .!= False
|
||||
pure InstallNewAppReq { .. }
|
||||
|
||||
data AppAvailableFull = AppAvailableFull
|
||||
{ appAvailableFullBase :: AppBase
|
||||
, appAvailableFullInstallInfo :: Maybe (Version, AppStatus)
|
||||
, appAvailableFullVersionLatest :: Version
|
||||
, appAvailableFullDescriptionShort :: Text
|
||||
, appAvailableFullDescriptionLong :: Text
|
||||
, appAvailableFullReleaseNotes :: Text
|
||||
, appAvailableFullDependencyRequirements :: [Full AppDependencyRequirement]
|
||||
, appAvailableFullVersions :: NonEmpty Version
|
||||
}
|
||||
-- deriving Eq
|
||||
instance ToJSON AppAvailableFull where
|
||||
toJSON AppAvailableFull {..} = mergeTo
|
||||
(toJSON appAvailableFullBase)
|
||||
(object
|
||||
[ "versionInstalled" .= fmap fst appAvailableFullInstallInfo
|
||||
, "status" .= fmap snd appAvailableFullInstallInfo
|
||||
, "versionLatest" .= appAvailableFullVersionLatest
|
||||
, "descriptionShort" .= appAvailableFullDescriptionShort
|
||||
, "descriptionLong" .= appAvailableFullDescriptionLong
|
||||
, "versions" .= appAvailableFullVersions
|
||||
, "releaseNotes" .= appAvailableFullReleaseNotes
|
||||
, "serviceRequirements" .= appAvailableFullDependencyRequirements
|
||||
]
|
||||
)
|
||||
|
||||
type AppDependencyRequirement :: (Type ~> Type) -> Type
|
||||
data AppDependencyRequirement f = AppDependencyRequirement
|
||||
{ appDependencyRequirementBase :: AppBase
|
||||
, appDependencyRequirementReasonOptional :: Apply f (Maybe Text)
|
||||
, appDependencyRequirementDefault :: Apply f Bool
|
||||
, appDependencyRequirementDescription :: Maybe Text
|
||||
, appDependencyRequirementViolation :: Maybe ApiDependencyViolation
|
||||
, appDependencyRequirementVersionSpec :: VersionRange
|
||||
}
|
||||
instance ToJSON (AppDependencyRequirement Strip) where
|
||||
toJSON AppDependencyRequirement {..} = mergeTo (toJSON appDependencyRequirementBase) $ object
|
||||
[ "versionSpec" .= appDependencyRequirementVersionSpec
|
||||
, "description" .= appDependencyRequirementDescription
|
||||
, "violation" .= appDependencyRequirementViolation
|
||||
]
|
||||
instance ToJSON (AppDependencyRequirement Keep) where
|
||||
toJSON r =
|
||||
let stripped = r { appDependencyRequirementReasonOptional = (), appDependencyRequirementDefault = () }
|
||||
in
|
||||
mergeTo
|
||||
(toJSON @(AppDependencyRequirement Strip) stripped)
|
||||
(object
|
||||
[ "optional" .= appDependencyRequirementReasonOptional r
|
||||
, "default" .= appDependencyRequirementDefault r
|
||||
]
|
||||
)
|
||||
|
||||
-- filter non required dependencies in installed show
|
||||
-- mute violations downstream of version for installing apps
|
||||
data AppInstalledFull = AppInstalledFull
|
||||
{ appInstalledFullBase :: AppBase
|
||||
, appInstalledFullStatus :: AppStatus
|
||||
, appInstalledFullVersionInstalled :: Version
|
||||
, appInstalledFullTorAddress :: Maybe TorAddress
|
||||
, appInstalledFullInstructions :: Maybe Text
|
||||
, appInstalledFullLastBackup :: Maybe UTCTime
|
||||
, appInstalledFullConfiguredRequirements :: [Stripped AppDependencyRequirement]
|
||||
}
|
||||
instance ToJSON AppInstalledFull where
|
||||
toJSON AppInstalledFull {..} = object
|
||||
[ "instructions" .= appInstalledFullInstructions
|
||||
, "lastBackup" .= appInstalledFullLastBackup
|
||||
, "configuredRequirements" .= appInstalledFullConfiguredRequirements
|
||||
, "torAddress" .= (unTorAddress <$> appInstalledFullTorAddress)
|
||||
, "id" .= appBaseId appInstalledFullBase
|
||||
, "title" .= appBaseTitle appInstalledFullBase
|
||||
, "iconURL" .= appBaseIconUrl appInstalledFullBase
|
||||
, "versionInstalled" .= appInstalledFullVersionInstalled
|
||||
, "status" .= appInstalledFullStatus
|
||||
]
|
||||
|
||||
data AppVersionInfo = AppVersionInfo
|
||||
{ appVersionInfoVersion :: Version
|
||||
, appVersionInfoReleaseNotes :: Text
|
||||
, appVersionInfoDependencyRequirements :: [Full AppDependencyRequirement]
|
||||
}
|
||||
instance ToJSON AppVersionInfo where
|
||||
toJSON AppVersionInfo {..} = object
|
||||
[ "version" .= appVersionInfoVersion
|
||||
, "releaseNotes" .= appVersionInfoReleaseNotes
|
||||
, "serviceRequirements" .= appVersionInfoDependencyRequirements
|
||||
]
|
||||
|
||||
data ApiDependencyViolation
|
||||
= Missing
|
||||
| IncompatibleVersion
|
||||
| IncompatibleConfig [Text] -- rule violations
|
||||
| IncompatibleStatus AppStatus
|
||||
|
||||
instance ToJSON ApiDependencyViolation where
|
||||
toJSON Missing = object ["name" .= ("missing" :: Text)]
|
||||
toJSON IncompatibleVersion = object ["name" .= ("incompatible-version" :: Text)]
|
||||
toJSON (IncompatibleConfig ruleViolations) =
|
||||
object ["name" .= ("incompatible-config" :: Text), "ruleViolations" .= ruleViolations]
|
||||
toJSON (IncompatibleStatus status) = object ["name" .= ("incompatible-status" :: Text), "status" .= status]
|
||||
|
||||
data WithBreakages a = WithBreakages [AppBase] a
|
||||
instance {-# Overlappable #-} ToJSON a => ToJSON (WithBreakages a) where
|
||||
toJSON (WithBreakages breakages thing) = mergeTo (toJSON thing) (object ["breakages" .= breakages])
|
||||
instance ToJSON (WithBreakages ()) where
|
||||
toJSON (WithBreakages breakages _) = object ["breakages" .= breakages]
|
||||
|
||||
newtype AutoconfigureChangesRes = AutoconfigureChangesRes
|
||||
{ autoconfigureChangesConfig :: Maybe Value
|
||||
}
|
||||
instance ToJSON AutoconfigureChangesRes where
|
||||
toJSON AutoconfigureChangesRes {..} = object ["config" .= autoconfigureChangesConfig]
|
||||
28
agent/src/Handler/Types/HmacSig.hs
Normal file
28
agent/src/Handler/Types/HmacSig.hs
Normal file
@@ -0,0 +1,28 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Types.HmacSig where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Crypto.Hash
|
||||
import Data.Aeson
|
||||
import Data.ByteArray.Encoding
|
||||
import Data.ByteArray.Sized
|
||||
import Yesod.Core
|
||||
|
||||
import Handler.Types.Parse
|
||||
|
||||
data HmacSig = HmacSig
|
||||
{ sigHmac :: Digest SHA256
|
||||
, sigMessage :: Text
|
||||
, sigSalt :: SizedByteArray 16 ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON HmacSig where
|
||||
toJSON (HmacSig {..}) =
|
||||
object ["hmac" .= fromUnsizedBs Base16 sigHmac, "message" .= sigMessage, "salt" .= fromSizedBs Base16 sigSalt]
|
||||
|
||||
instance ToTypedContent HmacSig where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent HmacSig where
|
||||
toContent = toContent . toJSON
|
||||
44
agent/src/Handler/Types/Hosts.hs
Normal file
44
agent/src/Handler/Types/Hosts.hs
Normal file
@@ -0,0 +1,44 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Types.Hosts where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Crypto.Hash
|
||||
import Data.Aeson
|
||||
import Data.ByteArray.Encoding
|
||||
import Data.ByteArray.Sized
|
||||
import Yesod.Core
|
||||
|
||||
import Handler.Types.Parse
|
||||
import Handler.Types.Register
|
||||
import Lib.Error
|
||||
|
||||
data HostsParams = HostsParams
|
||||
{ hostsParamsHmac :: Digest SHA256 -- hmac of an expiration timestamp
|
||||
, hostsParamsExpiration :: Text -- This is a UTC time text string. we leave it as text as it is precisely this which is signed by the above hmac.
|
||||
, hostsParamsSalt :: SizedByteArray 16 ByteString
|
||||
}
|
||||
|
||||
data HostsRes = NullReply | HostsRes RegisterRes
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON HostsRes where
|
||||
toJSON NullReply = Null
|
||||
toJSON (HostsRes registerRes) = toJSON registerRes
|
||||
|
||||
instance ToTypedContent HostsRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent HostsRes where
|
||||
toContent = toContent . toJSON
|
||||
|
||||
extractHostsQueryParams :: MonadHandler m => S9ErrT m HostsParams
|
||||
extractHostsQueryParams = do
|
||||
hostsParamsHmac <- lookupGetParam "hmac" <&> (>>= sizedBs @32 Base16 >=> digestFromByteString) >>= orThrow400 "hmac"
|
||||
hostsParamsSalt <- lookupGetParam "salt" <&> (>>= sizedBs @16 Base16) >>= orThrow400 "salt"
|
||||
hostsParamsExpiration <- lookupGetParam "message" >>= orThrow400 "message"
|
||||
|
||||
pure HostsParams { .. }
|
||||
where
|
||||
orThrow400 desc = \case
|
||||
Nothing -> throwE $ HostsParamsE desc
|
||||
Just p -> pure p
|
||||
26
agent/src/Handler/Types/Metrics.hs
Normal file
26
agent/src/Handler/Types/Metrics.hs
Normal file
@@ -0,0 +1,26 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Types.Metrics where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Lib.Metrics
|
||||
|
||||
import Data.Aeson
|
||||
import Yesod.Core.Content
|
||||
|
||||
newtype MetricsRes = MetricsRes { unMetricsRes :: ServerMetrics }
|
||||
instance ToJSON MetricsRes where
|
||||
toJSON = toJSON . unMetricsRes
|
||||
toEncoding = toEncoding . unMetricsRes
|
||||
instance ToTypedContent MetricsRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent MetricsRes where
|
||||
toContent = toContent . toJSON
|
||||
|
||||
newtype PatchServerReq = PatchServerReq { patchServerReqName :: Text }
|
||||
instance FromJSON PatchServerReq where
|
||||
parseJSON = withObject "Patch Server Request" $ \o -> do
|
||||
patchServerReqName <- o .: "name"
|
||||
pure $ PatchServerReq { patchServerReqName }
|
||||
32
agent/src/Handler/Types/Parse.hs
Normal file
32
agent/src/Handler/Types/Parse.hs
Normal file
@@ -0,0 +1,32 @@
|
||||
module Handler.Types.Parse where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Control.Monad.Fail
|
||||
import Data.Aeson.Types
|
||||
import Data.ByteArray
|
||||
import Data.ByteArray.Encoding
|
||||
import Data.ByteArray.Sized
|
||||
|
||||
mToParser :: String -> Maybe a -> Parser a
|
||||
mToParser failureText = \case
|
||||
Nothing -> fail failureText
|
||||
Just t -> pure t
|
||||
|
||||
toUnsizedBs :: String -> Base -> Text -> Parser ByteString
|
||||
toUnsizedBs failureText base = mToParser failureText . unsizedBs base
|
||||
|
||||
unsizedBs :: Base -> Text -> Maybe ByteString
|
||||
unsizedBs base = hush . convertFromBase base . encodeUtf8
|
||||
|
||||
toSizedBs :: KnownNat n => String -> Base -> Text -> Parser (SizedByteArray n ByteString)
|
||||
toSizedBs failureText base = mToParser failureText . sizedBs base
|
||||
|
||||
sizedBs :: KnownNat n => Base -> Text -> Maybe (SizedByteArray n ByteString)
|
||||
sizedBs base = sizedByteArray <=< unsizedBs base
|
||||
|
||||
fromUnsizedBs :: ByteArrayAccess ba => Base -> ba -> Text
|
||||
fromUnsizedBs base = decodeUtf8 . convertToBase base
|
||||
|
||||
fromSizedBs :: (KnownNat n, ByteArrayAccess ba) => Base -> SizedByteArray n ba -> Text
|
||||
fromSizedBs b = fromUnsizedBs b . unSizedByteArray
|
||||
65
agent/src/Handler/Types/Register.hs
Normal file
65
agent/src/Handler/Types/Register.hs
Normal file
@@ -0,0 +1,65 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Types.Register where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Data.Aeson
|
||||
import Data.ByteArray.Encoding
|
||||
import Data.ByteArray.Sized
|
||||
import Yesod.Core
|
||||
|
||||
import Handler.Types.HmacSig
|
||||
import Handler.Types.Parse
|
||||
|
||||
data RegisterReq = RegisterReq
|
||||
{ registerTorKey :: SizedByteArray 96 ByteString -- Represents a tor private key along with tor private key file prefix.
|
||||
, registerTorCtrCounter :: SizedByteArray 16 ByteString
|
||||
, registerTorKdfSalt :: SizedByteArray 16 ByteString
|
||||
, registerPassword :: ByteString -- Encrypted password
|
||||
, registerPasswordCtrCounter :: SizedByteArray 16 ByteString
|
||||
, registerPasswordKdfSalt :: SizedByteArray 16 ByteString
|
||||
, registerRsa :: ByteString -- Encrypted RSA key
|
||||
, registerRsaCtrCounter :: SizedByteArray 16 ByteString
|
||||
, registerRsaKdfSalt :: SizedByteArray 16 ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
data RegisterRes = RegisterRes
|
||||
{ registerResClaimedAt :: UTCTime
|
||||
, registerResTorAddressSig :: HmacSig
|
||||
, registerResCertSig :: HmacSig
|
||||
, registerResCertName :: Text
|
||||
, registerResLanAddress :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSON RegisterReq where
|
||||
parseJSON = withObject "Register Tor Request" $ \o -> do
|
||||
registerTorKey <- o .: "torkey" >>= toSizedBs "Invalid torkey encryption" Base16
|
||||
registerTorCtrCounter <- o .: "torkeyCounter" >>= toSizedBs "Invalid torkey ctr counter" Base16
|
||||
registerTorKdfSalt <- o .: "torkeySalt" >>= toSizedBs "Invalid torkey pbkdf2 salt" Base16
|
||||
|
||||
registerPassword <- o .: "password" >>= toUnsizedBs "Invalid password encryption" Base16
|
||||
registerPasswordCtrCounter <- o .: "passwordCounter" >>= toSizedBs "Invalid password ctr counter" Base16
|
||||
registerPasswordKdfSalt <- o .: "passwordSalt" >>= toSizedBs "Invalid password pbkdf2 salt" Base16
|
||||
|
||||
registerRsa <- o .: "rsaKey" >>= toUnsizedBs "Invalid rsa encryption" Base16
|
||||
registerRsaCtrCounter <- o .: "rsaCounter" >>= toSizedBs "Invalid rsa ctr counter" Base16
|
||||
registerRsaKdfSalt <- o .: "rsaSalt" >>= toSizedBs "Invalid rsa pbkdf2 salt" Base16
|
||||
|
||||
pure RegisterReq { .. }
|
||||
|
||||
instance ToJSON RegisterRes where
|
||||
toJSON (RegisterRes {..}) = object
|
||||
[ "claimedAt" .= registerResClaimedAt
|
||||
, "torAddressSig" .= registerResTorAddressSig
|
||||
, "certSig" .= registerResCertSig
|
||||
, "certName" .= registerResCertName
|
||||
, "lanAddress" .= registerResLanAddress
|
||||
]
|
||||
|
||||
instance ToTypedContent RegisterRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent RegisterRes where
|
||||
toContent = toContent . toJSON
|
||||
77
agent/src/Handler/Types/V0/Base.hs
Normal file
77
agent/src/Handler/Types/V0/Base.hs
Normal file
@@ -0,0 +1,77 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Types.V0.Base where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Data.Aeson
|
||||
import Database.Persist
|
||||
import Yesod.Core
|
||||
|
||||
import Handler.Types.V0.Ssh
|
||||
import Handler.Types.V0.Specs
|
||||
import Handler.Types.V0.Wifi
|
||||
import Lib.Types.Core
|
||||
import Lib.Types.Emver
|
||||
import Model
|
||||
|
||||
data VersionLatestRes = VersionLatestRes
|
||||
{ versionLatestVersion :: Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON VersionLatestRes where
|
||||
toJSON VersionLatestRes {..} = object $ ["versionLatest" .= versionLatestVersion]
|
||||
instance ToTypedContent VersionLatestRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent VersionLatestRes where
|
||||
toContent = toContent . toJSON
|
||||
|
||||
data ServerRes = ServerRes
|
||||
{ serverId :: Text
|
||||
, serverName :: Text
|
||||
, serverStatus :: Maybe AppStatus
|
||||
, serverStatusAt :: UTCTime
|
||||
, serverVersionInstalled :: Version
|
||||
, serverNotifications :: [Entity Notification]
|
||||
, serverWifi :: WifiList
|
||||
, serverSsh :: [SshKeyFingerprint]
|
||||
, serverAlternativeRegistryUrl :: Maybe Text
|
||||
, serverSpecs :: SpecsRes
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type JsonEncoding a = Encoding
|
||||
jsonEncode :: (Monad m, ToJSON a) => a -> m (JsonEncoding a)
|
||||
jsonEncode = returnJsonEncoding
|
||||
|
||||
instance ToJSON ServerRes where
|
||||
toJSON ServerRes {..} = object
|
||||
[ "serverId" .= serverId
|
||||
, "name" .= serverName
|
||||
, "status" .= case serverStatus of
|
||||
Nothing -> String "UPDATING"
|
||||
Just stat -> toJSON stat
|
||||
, "versionInstalled" .= serverVersionInstalled
|
||||
, "versionLatest" .= Null
|
||||
, "notifications" .= serverNotifications
|
||||
, "wifi" .= serverWifi
|
||||
, "ssh" .= serverSsh
|
||||
, "alternativeRegistryUrl" .= serverAlternativeRegistryUrl
|
||||
, "specs" .= serverSpecs
|
||||
]
|
||||
instance ToTypedContent ServerRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent ServerRes where
|
||||
toContent = toContent . toJSON
|
||||
|
||||
newtype AppVersionRes = AppVersionRes
|
||||
{ unAppVersionRes :: Version } deriving (Eq, Show)
|
||||
instance ToJSON AppVersionRes where
|
||||
toJSON AppVersionRes { unAppVersionRes } = object ["version" .= unAppVersionRes]
|
||||
instance FromJSON AppVersionRes where
|
||||
parseJSON = withObject "app version response" $ \o -> do
|
||||
av <- o .: "version"
|
||||
pure $ AppVersionRes av
|
||||
instance ToContent AppVersionRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent AppVersionRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
45
agent/src/Handler/Types/V0/Specs.hs
Normal file
45
agent/src/Handler/Types/V0/Specs.hs
Normal file
@@ -0,0 +1,45 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Types.V0.Specs where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Lib.Types.Emver
|
||||
import Lib.Types.Emver.Orphans ( )
|
||||
|
||||
import Data.Aeson
|
||||
import Yesod.Core
|
||||
|
||||
data SpecsRes = SpecsRes
|
||||
{ specsCPU :: Text
|
||||
, specsMem :: Text
|
||||
, specsDisk :: Maybe Text
|
||||
, specsNetworkId :: Text
|
||||
, specsAgentVersion :: Version
|
||||
, specsTorAddress :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON SpecsRes where
|
||||
toJSON SpecsRes {..} = object
|
||||
[ "EmbassyOS Version" .= specsAgentVersion
|
||||
, "Tor Address" .= specsTorAddress
|
||||
, "Network ID" .= specsNetworkId
|
||||
, "CPU" .= specsCPU
|
||||
, "Memory" .= specsMem
|
||||
, "Disk" .= specsDisk
|
||||
]
|
||||
toEncoding SpecsRes {..} =
|
||||
pairs
|
||||
. fold
|
||||
$ [ "EmbassyOS Version" .= specsAgentVersion
|
||||
, "Tor Address" .= specsTorAddress
|
||||
, "Network ID" .= specsNetworkId
|
||||
, "CPU" .= specsCPU
|
||||
, "Memory" .= specsMem
|
||||
, "Disk" .= specsDisk
|
||||
]
|
||||
|
||||
instance ToTypedContent SpecsRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent SpecsRes where
|
||||
toContent = toContent . toJSON
|
||||
25
agent/src/Handler/Types/V0/Ssh.hs
Normal file
25
agent/src/Handler/Types/V0/Ssh.hs
Normal file
@@ -0,0 +1,25 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Types.V0.Ssh where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Lib.Ssh
|
||||
|
||||
import Data.Aeson
|
||||
import Yesod.Core
|
||||
|
||||
newtype SshKeyModReq = SshKeyModReq { sshKey :: Text } deriving (Eq, Show)
|
||||
instance FromJSON SshKeyModReq where
|
||||
parseJSON = withObject "ssh key" $ fmap SshKeyModReq . (.: "sshKey")
|
||||
|
||||
data SshKeyFingerprint = SshKeyFingerprint
|
||||
{ sshKeyAlg :: SshAlg
|
||||
, sshKeyHash :: Text
|
||||
, sshKeyHostname :: Text
|
||||
} deriving (Eq, Show)
|
||||
instance ToJSON SshKeyFingerprint where
|
||||
toJSON SshKeyFingerprint {..} = object ["alg" .= sshKeyAlg, "hash" .= sshKeyHash, "hostname" .= sshKeyHostname]
|
||||
instance ToTypedContent SshKeyFingerprint where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent SshKeyFingerprint where
|
||||
toContent = toContent . toJSON
|
||||
32
agent/src/Handler/Types/V0/Wifi.hs
Normal file
32
agent/src/Handler/Types/V0/Wifi.hs
Normal file
@@ -0,0 +1,32 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Handler.Types.V0.Wifi where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Data.Aeson
|
||||
import Yesod.Core
|
||||
|
||||
data AddWifiReq = AddWifiReq
|
||||
{ addWifiSsid :: Text
|
||||
, addWifiPassword :: Text
|
||||
, addWifiCountry :: Text
|
||||
, skipConnect :: Bool
|
||||
} deriving (Eq, Show)
|
||||
instance FromJSON AddWifiReq where
|
||||
parseJSON = withObject "AddWifiReq" $ \o -> do
|
||||
addWifiSsid <- o .: "ssid"
|
||||
addWifiPassword <- o .: "password"
|
||||
addWifiCountry <- o .:? "country" .!= "US"
|
||||
skipConnect <- o .:? "skipConnect" .!= False
|
||||
pure AddWifiReq { .. }
|
||||
|
||||
data WifiList = WifiList
|
||||
{ wifiListCurrent :: Maybe Text
|
||||
, wifiListSsids :: [Text]
|
||||
} deriving (Eq, Show)
|
||||
instance ToJSON WifiList where
|
||||
toJSON WifiList {..} = object ["current" .= wifiListCurrent, "ssids" .= wifiListSsids]
|
||||
instance ToTypedContent WifiList where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent WifiList where
|
||||
toContent = toContent . toJSON
|
||||
16
agent/src/Handler/Util.hs
Normal file
16
agent/src/Handler/Util.hs
Normal file
@@ -0,0 +1,16 @@
|
||||
module Handler.Util where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Data.IORef
|
||||
import Yesod.Core
|
||||
|
||||
import Foundation
|
||||
import Lib.Error
|
||||
|
||||
disableEndpointOnFailedUpdate :: Handler a -> Handler a
|
||||
disableEndpointOnFailedUpdate m = handleS9ErrT $ do
|
||||
updateFailed <- getsYesod appIsUpdateFailed >>= liftIO . readIORef
|
||||
case updateFailed of
|
||||
Just e -> throwE e
|
||||
Nothing -> lift m
|
||||
120
agent/src/Handler/V0.hs
Normal file
120
agent/src/Handler/V0.hs
Normal file
@@ -0,0 +1,120 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Handler.V0 where
|
||||
|
||||
import Startlude hiding ( runReader )
|
||||
|
||||
import Control.Carrier.Lift ( runM )
|
||||
import Data.Aeson
|
||||
import Data.IORef
|
||||
import qualified Data.Text as T
|
||||
import Database.Persist
|
||||
import Yesod.Core.Handler
|
||||
import Yesod.Persist.Core
|
||||
import Yesod.Core.Json
|
||||
|
||||
import Constants
|
||||
import Daemon.ZeroConf
|
||||
import Foundation
|
||||
import Handler.Types.V0.Specs
|
||||
import Handler.Types.V0.Ssh
|
||||
import Handler.Types.V0.Base
|
||||
import Handler.Types.V0.Wifi
|
||||
import Lib.Error
|
||||
import Lib.External.Metrics.Df
|
||||
import Lib.External.Specs.CPU
|
||||
import Lib.External.Specs.Memory
|
||||
import qualified Lib.External.WpaSupplicant as WpaSupplicant
|
||||
import Lib.Notifications
|
||||
import Lib.SystemPaths
|
||||
import Lib.Ssh
|
||||
import Lib.Tor
|
||||
import Lib.Types.Core
|
||||
import Model
|
||||
import Settings
|
||||
import Util.Function
|
||||
|
||||
|
||||
getServerR :: Handler (JsonEncoding ServerRes)
|
||||
getServerR = handleS9ErrT $ do
|
||||
settings <- getsYesod appSettings
|
||||
now <- liftIO getCurrentTime
|
||||
isUpdating <- getsYesod appIsUpdating >>= liftIO . readIORef
|
||||
|
||||
let status = if isJust isUpdating then Nothing else Just Running
|
||||
|
||||
notifs <- case isUpdating of
|
||||
Nothing -> lift . runDB $ do
|
||||
notif <- selectList [NotificationArchivedAt ==. Nothing] [Desc NotificationCreatedAt]
|
||||
void . archive . fmap entityKey $ notif
|
||||
pure notif
|
||||
Just _ -> pure []
|
||||
|
||||
alternativeRegistryUrl <- runM $ injectFilesystemBaseFromContext settings $ readSystemPath altRegistryUrlPath
|
||||
name <- runM $ injectFilesystemBaseFromContext settings $ readSystemPath serverNamePath
|
||||
ssh <- readFromPath settings sshKeysFilePath >>= parseSshKeys
|
||||
wifi <- WpaSupplicant.runWlan0 $ liftA2 WifiList WpaSupplicant.getCurrentNetwork WpaSupplicant.listNetworks
|
||||
specs <- getSpecs settings
|
||||
let sid = T.drop 7 $ specsNetworkId specs
|
||||
|
||||
jsonEncode ServerRes { serverId = specsNetworkId specs
|
||||
, serverName = fromMaybe ("Embassy:" <> sid) name
|
||||
, serverStatus = AppStatusAppMgr <$> status
|
||||
, serverStatusAt = now
|
||||
, serverVersionInstalled = agentVersion
|
||||
, serverNotifications = notifs
|
||||
, serverWifi = wifi
|
||||
, serverSsh = ssh
|
||||
, serverAlternativeRegistryUrl = alternativeRegistryUrl
|
||||
, serverSpecs = specs
|
||||
}
|
||||
where
|
||||
parseSshKeys :: Text -> S9ErrT Handler [SshKeyFingerprint]
|
||||
parseSshKeys keysContent = do
|
||||
let keys = lines . T.strip $ keysContent
|
||||
case traverse fingerprint keys of
|
||||
Left e -> throwE $ InvalidSshKeyE (toS e)
|
||||
Right as -> pure $ uncurry3 SshKeyFingerprint <$> as
|
||||
|
||||
getSpecs :: MonadIO m => AppSettings -> S9ErrT m SpecsRes
|
||||
getSpecs settings = do
|
||||
specsCPU <- liftIO getCpuInfo
|
||||
specsMem <- liftIO getMem
|
||||
specsDisk <- fmap show . metricDiskSize <$> getDfMetrics
|
||||
specsNetworkId <- runM $ injectFilesystemBaseFromContext settings getStart9AgentHostname
|
||||
specsTorAddress <- runM $ injectFilesystemBaseFromContext settings getAgentHiddenServiceUrl
|
||||
|
||||
let specsAgentVersion = agentVersion
|
||||
pure $ SpecsRes { .. }
|
||||
|
||||
readFromPath :: MonadIO m => AppSettings -> SystemPath -> S9ErrT m Text
|
||||
readFromPath settings sp = runM (injectFilesystemBaseFromContext settings (readSystemPath sp)) >>= \case
|
||||
Nothing -> throwE $ MissingFileE sp
|
||||
Just res -> pure res
|
||||
|
||||
--------------------- UPDATES TO SERVER -------------------------
|
||||
|
||||
newtype PatchReq = PatchReq { patchValue :: Text } deriving(Eq, Show)
|
||||
instance FromJSON PatchReq where
|
||||
parseJSON = withObject "Patch Request" $ \o -> PatchReq <$> o .: "value"
|
||||
|
||||
newtype NullablePatchReq = NullablePatchReq { mpatchValue :: Maybe Text } deriving(Eq, Show)
|
||||
instance FromJSON NullablePatchReq where
|
||||
parseJSON = withObject "Nullable Patch Request" $ \o -> NullablePatchReq <$> o .:? "value"
|
||||
|
||||
patchNameR :: Handler ()
|
||||
patchNameR = patchFile serverNamePath
|
||||
|
||||
patchFile :: SystemPath -> Handler ()
|
||||
patchFile path = do
|
||||
settings <- getsYesod appSettings
|
||||
PatchReq val <- requireCheckJsonBody
|
||||
runM $ injectFilesystemBaseFromContext settings $ writeSystemPath path val
|
||||
|
||||
patchNullableFile :: SystemPath -> Handler ()
|
||||
patchNullableFile path = do
|
||||
settings <- getsYesod appSettings
|
||||
NullablePatchReq mVal <- requireCheckJsonBody
|
||||
runM $ injectFilesystemBaseFromContext settings $ case mVal of
|
||||
Just val -> writeSystemPath path $ T.strip val
|
||||
Nothing -> deleteSystemPath path
|
||||
76
agent/src/Handler/Wifi.hs
Normal file
76
agent/src/Handler/Wifi.hs
Normal file
@@ -0,0 +1,76 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Handler.Wifi where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Data.String.Interpolate.IsString
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Types
|
||||
import Yesod.Core
|
||||
|
||||
import Constants
|
||||
import Foundation
|
||||
import Handler.Types.V0.Wifi
|
||||
import Lib.Error
|
||||
import qualified Lib.External.WpaSupplicant as WpaSupplicant
|
||||
|
||||
getWifiR :: Handler WifiList
|
||||
getWifiR = WpaSupplicant.runWlan0 $ liftA2 WifiList WpaSupplicant.getCurrentNetwork WpaSupplicant.listNetworks
|
||||
|
||||
postWifiR :: Handler ()
|
||||
postWifiR = handleS9ErrT $ do
|
||||
AddWifiReq { addWifiSsid, addWifiPassword, addWifiCountry, skipConnect } <- requireCheckJsonBody
|
||||
unless (T.all isAscii addWifiSsid) $ throwE InvalidSsidE
|
||||
unless (T.all isAscii addWifiPassword) $ throwE InvalidPskE
|
||||
|
||||
_ <- liftIO . forkIO . WpaSupplicant.runWlan0 $ do
|
||||
lift $ withAgentVersionLog_ [i|Adding new WiFi network: '#{addWifiSsid}'|]
|
||||
WpaSupplicant.addNetwork addWifiSsid addWifiPassword addWifiCountry
|
||||
unless skipConnect $ do
|
||||
mCurrent <- WpaSupplicant.getCurrentNetwork
|
||||
connected <- WpaSupplicant.selectNetwork addWifiSsid addWifiCountry
|
||||
unless connected do
|
||||
lift $ withAgentVersionLog_ [i|Failed to add new WiFi network: '#{addWifiSsid}'|]
|
||||
WpaSupplicant.removeNetwork addWifiSsid
|
||||
case mCurrent of
|
||||
Nothing -> pure ()
|
||||
Just current -> void $ WpaSupplicant.selectNetwork current addWifiSsid
|
||||
sendResponseStatus status200 ()
|
||||
|
||||
|
||||
postWifiBySsidR :: Text -> Handler ()
|
||||
postWifiBySsidR ssid = handleS9ErrT $ do
|
||||
unless (T.all isAscii ssid) $ throwE InvalidSsidE
|
||||
|
||||
-- TODO: Front end never sends this on switching between networks. This means that we can only
|
||||
-- switch to US networks.
|
||||
country <- fromMaybe "US" <$> lookupGetParam "country"
|
||||
_ <- liftIO . forkIO . WpaSupplicant.runWlan0 $ do
|
||||
mCurrent <- WpaSupplicant.getCurrentNetwork
|
||||
connected <- WpaSupplicant.selectNetwork ssid country
|
||||
if connected
|
||||
then lift $ withAgentVersionLog_ [i|Successfully connected to WiFi: #{ssid}|]
|
||||
else do
|
||||
lift $ withAgentVersionLog_ [i|Failed to add new WiFi network: '#{ssid}'|]
|
||||
case mCurrent of
|
||||
Nothing -> lift $ withAgentVersionLog_ [i|No WiFi to revert to!|]
|
||||
Just current -> void $ WpaSupplicant.selectNetwork current country
|
||||
sendResponseStatus status200 ()
|
||||
|
||||
deleteWifiBySsidR :: Text -> Handler ()
|
||||
deleteWifiBySsidR ssid = handleS9ErrT $ do
|
||||
unless (T.all isAscii ssid) $ throwE InvalidSsidE
|
||||
WpaSupplicant.runWlan0 $ do
|
||||
current <- WpaSupplicant.getCurrentNetwork
|
||||
case current of
|
||||
Nothing -> deleteIt
|
||||
Just ssid' -> if ssid == ssid'
|
||||
then do
|
||||
eth0 <- WpaSupplicant.isConnectedToEthernet
|
||||
if eth0
|
||||
then deleteIt
|
||||
else lift $ throwE WifiOrphaningE
|
||||
else deleteIt
|
||||
where deleteIt = void $ WpaSupplicant.removeNetwork ssid
|
||||
Reference in New Issue
Block a user