mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-30 19:54:47 +00:00
changes appmgr calls to be conduit sources.
This commit is contained in:
Keagan McClelland
117
src/Lib/External/AppMgr.hs
vendored
117
src/Lib/External/AppMgr.hs
vendored
@@ -10,14 +10,25 @@
|
||||
|
||||
module Lib.External.AppMgr where
|
||||
|
||||
import Startlude
|
||||
import Startlude hiding ( catch )
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.String.Interpolate.IsString
|
||||
import System.Process.Typed hiding ( createPipe )
|
||||
|
||||
import Conduit ( (.|)
|
||||
, ConduitT
|
||||
, MonadThrow
|
||||
, runConduit
|
||||
)
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Data.Conduit.Process.Typed
|
||||
import Lib.Error
|
||||
import Lib.Registry
|
||||
import System.FilePath ( (</>) )
|
||||
import UnliftIO ( MonadUnliftIO
|
||||
, catch
|
||||
)
|
||||
|
||||
readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
|
||||
readProcessWithExitCode' a b c = liftIO $ do
|
||||
@@ -32,56 +43,78 @@ readProcessWithExitCode' a b c = liftIO $ do
|
||||
(LBS.toStrict <$> getStdout process)
|
||||
(LBS.toStrict <$> getStderr process)
|
||||
|
||||
readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, LBS.ByteString)
|
||||
readProcessInheritStderr a b c = liftIO $ do
|
||||
readProcessInheritStderr :: MonadUnliftIO m
|
||||
=> String
|
||||
-> [String]
|
||||
-> ByteString
|
||||
-> (ConduitT () ByteString m () -> m a) -- this is because we can't clean up the process in the unCPS'ed version of this
|
||||
-> m a
|
||||
readProcessInheritStderr a b c sink = do
|
||||
let pc =
|
||||
setStdin (byteStringInput $ LBS.fromStrict c)
|
||||
$ setStderr inherit
|
||||
$ setEnvInherit
|
||||
$ setStdout byteStringOutput
|
||||
$ setStdout createSource
|
||||
$ System.Process.Typed.proc a b
|
||||
withProcessWait pc $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (getStdout process)
|
||||
withProcessTerm_ pc $ \p -> sink (getStdout p)
|
||||
|
||||
getConfig :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m Text
|
||||
getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do
|
||||
(ec, out) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk")
|
||||
["inspect", "config", appPath <> show e, "--json"]
|
||||
getConfig :: (MonadUnliftIO m, MonadThrow m, KnownSymbol a)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> Extension a
|
||||
-> (ConduitT () ByteString m () -> m r)
|
||||
-> m r
|
||||
getConfig appmgrPath appPath e@(Extension appId) sink = do
|
||||
let
|
||||
appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk")
|
||||
["inspect", "config", appPath </> show e, "--json"]
|
||||
""
|
||||
case ec of
|
||||
ExitSuccess -> pure $ LBS.toStrict out
|
||||
ExitFailure n -> throwE $ AppMgrE [i|info config #{appId} \--json|] n
|
||||
appmgr sink `catch` \ece -> throwIO (AppMgrE [i|inspect config #{appId} \--json|] (eceExitCode ece))
|
||||
|
||||
getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString
|
||||
getManifest appmgrPath appPath e@(Extension appId) = do
|
||||
(!ec, !bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] ""
|
||||
case ec of
|
||||
ExitSuccess -> pure bs
|
||||
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n
|
||||
getManifest :: (MonadUnliftIO m, KnownSymbol a)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> Extension a
|
||||
-> (ConduitT () ByteString m () -> m r)
|
||||
-> m r
|
||||
getManifest appmgrPath appPath e@(Extension appId) sink = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath </> show e] ""
|
||||
appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{appId}|] (eceExitCode ece))
|
||||
|
||||
getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString
|
||||
getIcon appmgrPath appPath (Extension icon) = do
|
||||
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] ""
|
||||
case ec of
|
||||
ExitSuccess -> pure bs
|
||||
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] n
|
||||
getIcon :: (MonadUnliftIO m, KnownSymbol a)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> Extension a
|
||||
-> (ConduitT () ByteString m () -> m r)
|
||||
-> m r
|
||||
getIcon appmgrPath appPath (Extension icon) sink = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] ""
|
||||
appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] (eceExitCode ece)
|
||||
|
||||
getPackageHash :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString
|
||||
getPackageHash :: (MonadUnliftIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m ByteString
|
||||
getPackageHash appmgrPath appPath e@(Extension appId) = do
|
||||
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] ""
|
||||
case ec of
|
||||
ExitSuccess -> pure bs
|
||||
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] n
|
||||
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] ""
|
||||
appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id)
|
||||
`catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] (eceExitCode ece)
|
||||
|
||||
getInstructions :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString
|
||||
getInstructions appmgrPath appPath (Extension appId) = do
|
||||
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] ""
|
||||
case ec of
|
||||
ExitSuccess -> pure bs
|
||||
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] n
|
||||
getInstructions :: (MonadUnliftIO m, KnownSymbol a)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> Extension a
|
||||
-> (ConduitT () ByteString m () -> m r)
|
||||
-> m r
|
||||
getInstructions appmgrPath appPath (Extension appId) sink = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] ""
|
||||
appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] (eceExitCode ece)
|
||||
|
||||
getLicense :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString
|
||||
getLicense appmgrPath appPath (Extension appId) = do
|
||||
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] ""
|
||||
case ec of
|
||||
ExitSuccess -> pure bs
|
||||
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect license #{appId}|] n
|
||||
getLicense :: (MonadUnliftIO m, KnownSymbol a)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> Extension a
|
||||
-> (ConduitT () ByteString m () -> m r)
|
||||
-> m r
|
||||
getLicense appmgrPath appPath (Extension appId) sink = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] ""
|
||||
appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{appId}|] (eceExitCode ece)
|
||||
|
||||
sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a
|
||||
sinkMem c = runConduit $ c .| CL.foldMap id
|
||||
|
||||
Reference in New Issue
Block a user