mirror of
https://github.com/Start9Labs/start-os.git
synced 2026-04-01 21:13:09 +00:00
0.2.5 initial commit
Makefile incomplete
This commit is contained in:
Aiden McClelland
469
agent/src/Lib/Algebra/Domain/AppMgr.hs
Normal file
469
agent/src/Lib/Algebra/Domain/AppMgr.hs
Normal file
@@ -0,0 +1,469 @@
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- because of my sheer laziness in dealing with conditional data
|
||||
{-# OPTIONS_GHC -fno-show-valid-hole-fits #-} -- to not make dev'ing this module cripplingly slow
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneKindSignatures #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
module Lib.Algebra.Domain.AppMgr
|
||||
( module Lib.Algebra.Domain.AppMgr
|
||||
, module Lib.Algebra.Domain.AppMgr.Types
|
||||
, module Lib.Algebra.Domain.AppMgr.TH
|
||||
)
|
||||
where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Control.Algebra
|
||||
import Control.Effect.Error
|
||||
import Control.Effect.TH
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types ( Parser )
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.Singletons.Prelude hiding ( Error )
|
||||
import Data.Singletons.Prelude.Either
|
||||
import qualified Data.String as String
|
||||
import Exinst
|
||||
|
||||
import Lib.Algebra.Domain.AppMgr.Types
|
||||
import Lib.Algebra.Domain.AppMgr.TH
|
||||
import Lib.Error
|
||||
import Lib.External.AppManifest
|
||||
import Lib.TyFam.ConditionalData
|
||||
import Lib.Types.Core ( AppId(..)
|
||||
, AppContainerStatus(..)
|
||||
)
|
||||
import Lib.Types.NetAddress
|
||||
import Lib.Types.Emver
|
||||
import Control.Monad.Trans.Class ( MonadTrans )
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import System.Process.Typed
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Control.Monad.Base ( MonadBase(..) )
|
||||
import Control.Monad.Fail ( MonadFail(fail) )
|
||||
import Control.Monad.Trans.Resource ( MonadResource(..) )
|
||||
import Control.Monad.Trans.Control ( defaultLiftBaseWith
|
||||
, defaultRestoreM
|
||||
, MonadTransControl(..)
|
||||
, MonadBaseControl(..)
|
||||
)
|
||||
import qualified Data.ByteString.Char8 as C8
|
||||
|
||||
|
||||
type InfoRes :: Either OnlyInfoFlag [IncludeInfoFlag] -> Type
|
||||
data InfoRes a = InfoRes
|
||||
{ infoResTitle :: Include (IsRight a) Text
|
||||
, infoResVersion :: Include (IsRight a) Version
|
||||
, infoResTorAddress :: Include (IsRight a) (Maybe TorAddress)
|
||||
, infoResIsConfigured :: Include (IsRight a) Bool
|
||||
, infoResIsRecoverable :: Include (IsRight a) Bool
|
||||
, infoResNeedsRestart :: Include (IsRight a) Bool
|
||||
, infoResConfig :: Include (Either_ (DefaultEqSym1 'OnlyConfig) (ElemSym1 'IncludeConfig) a) Value
|
||||
, infoResDependencies
|
||||
:: Include
|
||||
(Either_ (DefaultEqSym1 'OnlyDependencies) (ElemSym1 'IncludeDependencies) a)
|
||||
(HM.HashMap AppId DependencyInfo)
|
||||
, infoResManifest
|
||||
:: Include (Either_ (DefaultEqSym1 'OnlyManifest) (ElemSym1 'IncludeManifest) a) (Some1 AppManifest)
|
||||
, infoResStatus :: Include (Either_ (DefaultEqSym1 'OnlyStatus) (ElemSym1 'IncludeStatus) a) AppContainerStatus
|
||||
}
|
||||
instance SingI (a :: Either OnlyInfoFlag [IncludeInfoFlag]) => FromJSON (InfoRes a) where
|
||||
parseJSON = withObject "AppMgr Info/List Response" $ \o -> do
|
||||
let recurse :: forall (a :: [IncludeInfoFlag]) . SingI a => Value -> Parser (InfoRes ( 'Right a))
|
||||
recurse = parseJSON @(InfoRes ( 'Right a))
|
||||
let infoResConfig = ()
|
||||
let infoResDependencies = ()
|
||||
let infoResManifest = ()
|
||||
let infoResStatus = ()
|
||||
case sing @a of
|
||||
SLeft f -> do
|
||||
let infoResTitle = ()
|
||||
let infoResVersion = ()
|
||||
let infoResTorAddress = ()
|
||||
let infoResIsConfigured = ()
|
||||
let infoResIsRecoverable = ()
|
||||
let infoResNeedsRestart = ()
|
||||
case f of
|
||||
SOnlyConfig -> let infoResConfig = (Object o) in pure InfoRes { .. }
|
||||
SOnlyDependencies -> parseJSON (Object o) >>= \infoResDependencies -> pure InfoRes { .. }
|
||||
SOnlyManifest -> parseJSON (Object o) >>= \infoResManifest -> pure InfoRes { .. }
|
||||
SOnlyStatus -> o .: "status" >>= \infoResStatus -> pure InfoRes { .. }
|
||||
SRight ls -> do
|
||||
infoResTitle <- o .: "title"
|
||||
infoResVersion <- o .: "version"
|
||||
infoResTorAddress <- TorAddress <<$>> o .: "tor-address"
|
||||
infoResIsConfigured <- o .: "configured"
|
||||
infoResIsRecoverable <- o .:? "recoverable" .!= False
|
||||
infoResNeedsRestart <- o .:? "needs-restart" .!= False
|
||||
let base = (InfoRes { .. } :: InfoRes ( 'Right '[]))
|
||||
case ls of
|
||||
SNil -> pure base
|
||||
SCons SIncludeConfig (rest :: Sing b) -> do
|
||||
InfoRes {..} <- withSingI rest $ recurse @b (Object o)
|
||||
infoResConfig <- o .: "config"
|
||||
pure InfoRes { .. }
|
||||
SCons SIncludeDependencies (rest :: Sing b) -> do
|
||||
InfoRes {..} <- withSingI rest $ recurse @b (Object o)
|
||||
infoResDependencies <- o .: "dependencies"
|
||||
pure InfoRes { .. }
|
||||
SCons SIncludeManifest (rest :: Sing b) -> do
|
||||
InfoRes {..} <- withSingI rest $ recurse @b (Object o)
|
||||
infoResManifest <- o .: "manifest"
|
||||
pure InfoRes { .. }
|
||||
SCons SIncludeStatus (rest :: Sing b) -> do
|
||||
InfoRes {..} <- withSingI rest $ recurse @b (Object o)
|
||||
infoResStatus <- o .: "status"
|
||||
pure InfoRes { .. }
|
||||
|
||||
data DependencyInfo = DependencyInfo
|
||||
{ dependencyInfoVersionSpec :: VersionRange
|
||||
, dependencyInfoReasonOptional :: Maybe Text
|
||||
, dependencyInfoDescription :: Maybe Text
|
||||
, dependencyInfoConfigRules :: [ConfigRule]
|
||||
, dependencyInfoRequired :: Bool
|
||||
, dependencyInfoError :: Maybe DependencyViolation
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON DependencyInfo where
|
||||
parseJSON = withObject "AppMgr DependencyInfo" $ \o -> do
|
||||
dependencyInfoVersionSpec <- o .: "version"
|
||||
dependencyInfoReasonOptional <- o .: "optional"
|
||||
dependencyInfoDescription <- o .: "description"
|
||||
dependencyInfoConfigRules <- o .: "config"
|
||||
dependencyInfoRequired <- o .: "required"
|
||||
dependencyInfoError <- o .:? "error"
|
||||
pure DependencyInfo { .. }
|
||||
|
||||
data ConfigRule = ConfigRule
|
||||
{ configRuleRule :: Text
|
||||
, configRuleDescription :: Text
|
||||
, configRuleSuggestions :: [ConfigRuleSuggestion]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON ConfigRule where
|
||||
parseJSON = withObject "AppMgr Config Rule" $ \o -> do
|
||||
configRuleRule <- o .: "rule"
|
||||
configRuleDescription <- o .: "description"
|
||||
configRuleSuggestions <- o .: "suggestions"
|
||||
pure ConfigRule { .. }
|
||||
data ConfigRuleSuggestion
|
||||
= SuggestionPush Text Value
|
||||
| SuggestionSet Text Target
|
||||
| SuggestionDelete Text
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON ConfigRuleSuggestion where
|
||||
parseJSON = withObject "AppMgr ConfigRule Suggestion" $ \o -> do
|
||||
let push = do
|
||||
o' <- o .: "PUSH"
|
||||
t <- o' .: "to"
|
||||
v <- o' .: "value"
|
||||
pure $ SuggestionPush t v
|
||||
let set = do
|
||||
o' <- o .: "SET"
|
||||
v <- o' .: "var"
|
||||
t <- parseJSON (Object o')
|
||||
pure $ SuggestionSet v t
|
||||
let delete = SuggestionDelete <$> o .: "DELETE"
|
||||
push <|> set <|> delete
|
||||
|
||||
data Target
|
||||
= To Text
|
||||
| ToValue Value
|
||||
| ToEntropy Text Word16
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON Target where
|
||||
parseJSON = withObject "Suggestion SET Target" $ \o -> do
|
||||
(To <$> o .: "to") <|> (ToValue <$> o .: "to-value") <|> do
|
||||
o' <- o .: "to-entropy"
|
||||
ToEntropy <$> o' .: "charset" <*> o' .: "len"
|
||||
|
||||
data DependencyError
|
||||
= Violation DependencyViolation
|
||||
| PointerUpdateError Text
|
||||
| Other Text
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON DependencyError where
|
||||
parseJSON v = (Violation <$> parseJSON v) <|> case v of
|
||||
Object o -> (PointerUpdateError <$> o .: "pointer-update-error") <|> (Other <$> o .: "other")
|
||||
other -> fail $ "Invalid DependencyError. Expected Object, got " <> (show other)
|
||||
|
||||
data DependencyViolation
|
||||
= NotInstalled
|
||||
| NotRunning
|
||||
| InvalidVersion VersionRange Version
|
||||
| UnsatisfiedConfig [Text]
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON DependencyViolation where
|
||||
parseJSON (String "not-installed") = pure NotInstalled
|
||||
parseJSON (String "not-running" ) = pure NotRunning
|
||||
parseJSON (Object o) =
|
||||
let version = do
|
||||
o' <- o .: "incorrect-version"
|
||||
s <- o' .: "expected"
|
||||
v <- o' .: "received"
|
||||
pure $ InvalidVersion s v
|
||||
config = UnsatisfiedConfig <$> o .: "config-unsatisfied"
|
||||
in version <|> config
|
||||
parseJSON other = fail $ "Invalid Dependency Violation" <> show other
|
||||
|
||||
data AutoconfigureRes = AutoconfigureRes
|
||||
{ autoconfigureConfigRes :: ConfigureRes
|
||||
, autoconfigureChanged :: HM.HashMap AppId Value
|
||||
}
|
||||
instance FromJSON AutoconfigureRes where
|
||||
parseJSON = withObject "AppMgr AutoconfigureRes" $ \o -> do
|
||||
autoconfigureConfigRes <- parseJSON (Object o)
|
||||
autoconfigureChanged <- o .: "changed"
|
||||
pure AutoconfigureRes { .. }
|
||||
|
||||
data ConfigureRes = ConfigureRes
|
||||
{ configureResNeedsRestart :: [AppId]
|
||||
, configureResStopped :: HM.HashMap AppId (AppId, DependencyError) -- TODO: Consider making this nested hashmaps
|
||||
}
|
||||
deriving Eq
|
||||
instance FromJSON ConfigureRes where
|
||||
parseJSON = withObject "AppMgr ConfigureRes" $ \o -> do
|
||||
configureResNeedsRestart <- o .: "needs-restart"
|
||||
configureResStopped' <- o .: "stopped"
|
||||
configureResStopped <- for
|
||||
configureResStopped'
|
||||
\v -> do
|
||||
depId <- v .: "dependency"
|
||||
depError <- v .: "error"
|
||||
pure (depId, depError)
|
||||
pure ConfigureRes { .. }
|
||||
|
||||
newtype BreakageMap = BreakageMap { unBreakageMap :: HM.HashMap AppId (AppId, DependencyError) }
|
||||
instance FromJSON BreakageMap where
|
||||
parseJSON = withObject "Breakage Map" $ \o -> do
|
||||
fmap (BreakageMap . HM.fromList) $ for (HM.toList o) $ \(k, v) -> do
|
||||
case v of
|
||||
Object v' -> do
|
||||
depId <- v' .: "dependency"
|
||||
depError <- v' .: "error"
|
||||
pure (AppId k, (depId, depError))
|
||||
otherwise -> fail $ "Expected Breakage Object, got" <> show otherwise
|
||||
|
||||
data AppMgr (m :: Type -> Type) k where
|
||||
-- Backup ::_
|
||||
CheckDependencies ::LocalOnly -> AppId -> Maybe VersionRange -> AppMgr m (HM.HashMap AppId DependencyInfo)
|
||||
Configure ::DryRun -> AppId -> Maybe Value -> AppMgr m ConfigureRes
|
||||
Autoconfigure ::DryRun -> AppId -> AppId -> AppMgr m AutoconfigureRes
|
||||
-- Disks ::_
|
||||
Info ::Sing (flags :: Either OnlyInfoFlag [IncludeInfoFlag]) -> AppId -> AppMgr m (Maybe (InfoRes flags))
|
||||
InfoRaw ::OnlyInfoFlag -> AppId -> AppMgr m (Maybe Text)
|
||||
-- Inspect ::_
|
||||
Install ::NoCache -> AppId -> Maybe VersionRange -> AppMgr m ()
|
||||
Instructions ::AppId -> AppMgr m (Maybe Text)
|
||||
List ::Sing ('Right (flags :: [IncludeInfoFlag])) -> AppMgr m (HM.HashMap AppId (InfoRes ('Right flags)))
|
||||
-- Logs ::_
|
||||
-- Notifications ::_
|
||||
-- Pack ::_
|
||||
Remove ::Either DryRun Purge -> AppId -> AppMgr m BreakageMap
|
||||
Restart ::AppId -> AppMgr m ()
|
||||
-- SelfUpdate ::_
|
||||
-- Semver ::_
|
||||
Start ::AppId -> AppMgr m ()
|
||||
Stop ::DryRun -> AppId -> AppMgr m BreakageMap
|
||||
-- Tor ::_
|
||||
Update ::DryRun -> AppId -> Maybe VersionRange -> AppMgr m BreakageMap
|
||||
-- Verify ::_
|
||||
makeSmartConstructors ''AppMgr
|
||||
|
||||
newtype AppMgrCliC m a = AppMgrCliC { runAppMgrCliC :: m a }
|
||||
deriving newtype (Functor, Applicative, Monad, MonadIO)
|
||||
instance MonadTrans AppMgrCliC where
|
||||
lift = AppMgrCliC
|
||||
instance MonadResource m => MonadResource (AppMgrCliC m) where
|
||||
liftResourceT = lift . liftResourceT
|
||||
instance MonadBase IO m => MonadBase IO (AppMgrCliC m) where
|
||||
liftBase = AppMgrCliC . liftBase
|
||||
instance MonadTransControl AppMgrCliC where
|
||||
type StT AppMgrCliC a = a
|
||||
liftWith f = AppMgrCliC $ f $ runAppMgrCliC
|
||||
restoreT = AppMgrCliC
|
||||
instance MonadBaseControl IO m => MonadBaseControl IO (AppMgrCliC m) where
|
||||
type StM (AppMgrCliC m) a = StM m a
|
||||
liftBaseWith = defaultLiftBaseWith
|
||||
restoreM = defaultRestoreM
|
||||
|
||||
instance (Has (Error S9Error) sig m, Algebra sig m, MonadIO m) => Algebra (AppMgr :+: sig) (AppMgrCliC m) where
|
||||
alg hdl sig ctx = case sig of
|
||||
(L (CheckDependencies (LocalOnly b) appId version)) -> do
|
||||
let local = if b then ("--local-only" :) else id
|
||||
args = "check-dependencies" : local [versionSpec version (show appId), "--json"]
|
||||
(ec, out) <- readProcessInheritStderr "appmgr" args ""
|
||||
res <- case ec of
|
||||
ExitSuccess -> case eitherDecodeStrict out of
|
||||
Left e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
|
||||
Right x -> pure x
|
||||
ExitFailure 6 -> throwError $ NotFoundE "appId@version" (versionSpec version (show appId))
|
||||
ExitFailure n -> throwError $ AppMgrE "check-dependencies" n
|
||||
pure $ ctx $> res
|
||||
(L (Configure (DryRun b) appId cfg)) -> do
|
||||
let dryrun = if b then ("--dry-run" :) else id
|
||||
let input = case cfg of
|
||||
Nothing -> ""
|
||||
Just x -> LBS.toStrict $ encode x
|
||||
let args = "configure" : dryrun [show appId, "--json", "--stdin"]
|
||||
(ec, out, e) <- readProcessWithExitCode' "appmgr" args input
|
||||
res <- case ec of
|
||||
ExitSuccess -> case eitherDecodeStrict out of
|
||||
Left e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
|
||||
Right x -> pure x
|
||||
ExitFailure 4 -> throwError $ (AppMgrInvalidConfigE . decodeUtf8) e -- doesn't match spec
|
||||
ExitFailure 5 -> throwError $ (AppMgrInvalidConfigE . decodeUtf8) e -- doesn't match rules
|
||||
ExitFailure n -> throwError $ AppMgrE "configure" n
|
||||
pure $ ctx $> res
|
||||
(L (Autoconfigure (DryRun dry) dependent dependency)) -> do
|
||||
let flags = (if dry then ("--dry-run" :) else id) . ("--json" :)
|
||||
let args = "autoconfigure-dependency" : flags [show dependent, show dependency]
|
||||
(ec, out) <- readProcessInheritStderr "appmgr" args ""
|
||||
res <- case ec of
|
||||
ExitSuccess -> case eitherDecodeStrict out of
|
||||
Left e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
|
||||
Right a -> pure a
|
||||
ExitFailure n -> throwError $ AppMgrE "autoconfigure-dependency" n
|
||||
pure $ ctx $> res
|
||||
(L (Info fs appId)) -> do
|
||||
let args = case fromSing fs of
|
||||
Left o -> ["info", genExclusiveFlag o, show appId, "--json"]
|
||||
Right ls -> "info" : ((genInclusiveFlag <$> ls) <> [show appId, "--json"])
|
||||
(ec, out) <- readProcessInheritStderr "appmgr" args ""
|
||||
res <- case ec of
|
||||
ExitSuccess -> case withSingI fs $ eitherDecodeStrict out of
|
||||
Left e -> throwError $ AppMgrParseE (show args) (decodeUtf8 out) e
|
||||
Right x -> pure $ Just x
|
||||
ExitFailure 6 -> pure Nothing
|
||||
ExitFailure n -> throwError $ AppMgrE "info" n
|
||||
pure $ ctx $> res
|
||||
(L (InfoRaw f appId)) -> do
|
||||
let args = ["info", genExclusiveFlag f, show appId, "--json"]
|
||||
(ec, out) <- readProcessInheritStderr "appmgr" args ""
|
||||
res <- case ec of
|
||||
ExitSuccess -> pure (Just $ decodeUtf8 out)
|
||||
ExitFailure 6 -> pure Nothing
|
||||
ExitFailure n -> throwError $ AppMgrE "info (raw)" n
|
||||
pure $ ctx $> res
|
||||
(L (Install (NoCache b) appId version)) -> do
|
||||
let nocache = if b then ("--no-cache" :) else id
|
||||
let versionSpec :: (IsString a, Semigroup a, ConvertText String a) => a -> a
|
||||
versionSpec = case version of
|
||||
Nothing -> id
|
||||
Just x -> (<> [i|@#{x}|])
|
||||
let args = "install" : nocache [versionSpec (show appId)]
|
||||
(ec, _) <- readProcessInheritStderr "appmgr" args ""
|
||||
case ec of
|
||||
ExitSuccess -> pure ctx
|
||||
ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
|
||||
ExitFailure n -> throwError $ AppMgrE "install" n
|
||||
(L (Instructions appId)) -> do
|
||||
(ec, out) <- readProcessInheritStderr "appmgr" ["instructions", show appId] ""
|
||||
case ec of
|
||||
ExitSuccess -> pure $ ctx $> Just (decodeUtf8 out)
|
||||
ExitFailure 6 -> pure $ ctx $> Nothing
|
||||
ExitFailure n -> throwError $ AppMgrE "instructions" n
|
||||
(L (List (SRight flags))) -> do
|
||||
let renderedFlags = (genInclusiveFlag <$> fromSing flags) <> ["--json"]
|
||||
let args = "list" : renderedFlags
|
||||
(ec, out) <- readProcessInheritStderr "appmgr" args ""
|
||||
res <- case ec of
|
||||
ExitSuccess -> case withSingI flags $ eitherDecodeStrict out of
|
||||
Left e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
|
||||
Right x -> pure x
|
||||
ExitFailure n -> throwError $ AppMgrE "list" n
|
||||
pure $ ctx $> res
|
||||
(L (Remove dryorpurge appId)) -> do
|
||||
let args = "remove" : case dryorpurge of
|
||||
Left (DryRun True) -> ["--dry-run", show appId, "--json"]
|
||||
Right (Purge True) -> ["--purge", show appId, "--json"]
|
||||
_ -> [show appId]
|
||||
(ec, out) <- readProcessInheritStderr "appmgr" args ""
|
||||
res <- case ec of
|
||||
ExitSuccess -> case eitherDecodeStrict out of
|
||||
Left e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
|
||||
Right x -> pure x
|
||||
ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
|
||||
ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
|
||||
pure $ ctx $> res
|
||||
(L (Restart appId)) -> do
|
||||
(ec, _) <- readProcessInheritStderr "appmgr" ["restart", show appId] ""
|
||||
case ec of
|
||||
ExitSuccess -> pure ctx
|
||||
ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
|
||||
ExitFailure n -> throwError $ AppMgrE "restart" n
|
||||
(L (Start appId)) -> do
|
||||
(ec, _) <- readProcessInheritStderr "appmgr" ["start", show appId] ""
|
||||
case ec of
|
||||
ExitSuccess -> pure ctx
|
||||
ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
|
||||
ExitFailure n -> throwError $ AppMgrE "start" n
|
||||
(L (Stop (DryRun dry) appId)) -> do
|
||||
let args = "stop" : (if dry then ("--dry-run" :) else id) [show appId, "--json"]
|
||||
(ec, out) <- readProcessInheritStderr "appmgr" args ""
|
||||
case ec of
|
||||
ExitSuccess -> case eitherDecodeStrict out of
|
||||
Left e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
|
||||
Right x -> pure $ ctx $> x
|
||||
ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
|
||||
ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
|
||||
(L (Update (DryRun dry) appId version)) -> do
|
||||
let args = "update" : (if dry then ("--dry-run" :) else id) [versionSpec version (show appId), "--json"]
|
||||
(ec, out) <- readProcessInheritStderr "appmgr" args ""
|
||||
case ec of
|
||||
ExitSuccess ->
|
||||
let output = if not dry then fromMaybe "" $ lastMay (C8.lines out) else out
|
||||
in case eitherDecodeStrict output of
|
||||
Left e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
|
||||
Right x -> pure $ ctx $> x
|
||||
ExitFailure 6 ->
|
||||
throwError $ NotFoundE "appId@version" ([i|#{appId}#{maybe "" (('@':) . show) version}|])
|
||||
ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
|
||||
R other -> AppMgrCliC $ alg (runAppMgrCliC . hdl) other ctx
|
||||
where
|
||||
versionSpec :: (IsString a, Semigroup a, ConvertText String a) => Maybe VersionRange -> a -> a
|
||||
versionSpec v = case v of
|
||||
Nothing -> id
|
||||
Just x -> (<> [i|@#{x}|])
|
||||
{-# INLINE alg #-}
|
||||
|
||||
genInclusiveFlag :: IncludeInfoFlag -> String
|
||||
genInclusiveFlag = \case
|
||||
IncludeConfig -> "-c"
|
||||
IncludeDependencies -> "-d"
|
||||
IncludeManifest -> "-m"
|
||||
IncludeStatus -> "-s"
|
||||
|
||||
genExclusiveFlag :: OnlyInfoFlag -> String
|
||||
genExclusiveFlag = \case
|
||||
OnlyConfig -> "-C"
|
||||
OnlyDependencies -> "-D"
|
||||
OnlyManifest -> "-M"
|
||||
OnlyStatus -> "-S"
|
||||
|
||||
readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString)
|
||||
readProcessInheritStderr a b c = liftIO $ do
|
||||
let pc =
|
||||
setStdin (byteStringInput $ LBS.fromStrict c)
|
||||
$ setStderr inherit
|
||||
$ setEnvInherit
|
||||
$ setStdout byteStringOutput
|
||||
$ (System.Process.Typed.proc a b)
|
||||
withProcessWait pc
|
||||
$ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (fmap LBS.toStrict $ getStdout process)
|
||||
|
||||
readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
|
||||
readProcessWithExitCode' a b c = liftIO $ do
|
||||
let pc =
|
||||
setStdin (byteStringInput $ LBS.fromStrict c)
|
||||
$ setStderr byteStringOutput
|
||||
$ setEnvInherit
|
||||
$ setStdout byteStringOutput
|
||||
$ (System.Process.Typed.proc a b)
|
||||
withProcessWait pc $ \process -> atomically $ liftA3 (,,)
|
||||
(waitExitCodeSTM process)
|
||||
(fmap LBS.toStrict $ getStdout process)
|
||||
(fmap LBS.toStrict $ getStderr process)
|
||||
Reference in New Issue
Block a user