Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-04-01 20:44:15 +00:00
Code Issues Packages Projects Releases Wiki Activity

fixes extraction logic, found a bug in System.Process

Browse Source
This commit is contained in:
Keagan McClelland
2021-09-28 20:19:32 -06:00
parent 427c31c886
commit 37c9a2bf6f
2 changed files with 67 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files

69
src/Lib/External/AppMgr.hs vendored
View File

@@ -10,7 +10,11 @@
module Lib.External.AppMgr where
import Startlude hiding ( catch )
import Startlude hiding ( bracket
, catch
, finally
, handle
)
import qualified Data.ByteString.Lazy as LBS
import Data.String.Interpolate.IsString
@@ -22,11 +26,25 @@ import Conduit ( (.|)
)
import qualified Data.Conduit.List as CL
import Data.Conduit.Process.Typed
import GHC.IO.Exception ( IOErrorType(NoSuchThing)
, IOException
( IOError
, ioe_description
, ioe_errno
, ioe_filename
, ioe_handle
, ioe_location
, ioe_type
)
)
import Lib.Error
import System.FilePath ( (</>) )
import UnliftIO ( MonadUnliftIO
, catch
)
import UnliftIO ( bracket )
import UnliftIO ( finally )
import UnliftIO.Exception ( handle )
readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
readProcessWithExitCode' a b c = liftIO $ do
@@ -41,45 +59,70 @@ readProcessWithExitCode' a b c = liftIO $ do
(LBS.toStrict <$> getStdout process)
(LBS.toStrict <$> getStderr process)
readProcessInheritStderr :: MonadUnliftIO m
readProcessInheritStderr :: forall m a
. 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
readProcessInheritStderr a b c sink = handle help $ do
let pc =
setStdin (byteStringInput $ LBS.fromStrict c)
$ setEnvInherit
$ setStderr (useHandleOpen stderr)
$ setStdout createSource
$ System.Process.Typed.proc a b
withProcessTerm_ pc $ \p -> sink (getStdout p)
withProcessTerm' pc $ \p -> sink (getStdout p)
where
withProcessTerm' :: (MonadUnliftIO m)
=> ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a)
-> m a
withProcessTerm' cfg = bracket (startProcess cfg) $ \p -> do
stopProcess p
`catch` (\e -> if ioe_type e == NoSuchThing && ioe_description e == "No child processes"
then pure ()
else throwIO e
)
help e@IOError {..} = do
print $ ioe_handle
print $ ioe_type
print $ ioe_location
print $ ioe_description
print $ ioe_errno
print $ ioe_filename
throwIO e
sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
sourceManifest appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "manifest", pkgFile] ""
appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece))
appmgr sink `catch` \ece ->
print ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece))
sourceIcon :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
sourceIcon appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", pkgFile] ""
appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece)
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "icon", pkgFile] ""
appmgr sink
`catch` \ece -> print ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece))
getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> m ByteString
getPackageHash appmgrPath pkgFile = do
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", pkgFile] ""
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "hash", pkgFile] ""
appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id)
`catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece)
`catch` \ece -> print ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece))
sourceInstructions :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
sourceInstructions appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", pkgFile] ""
appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "instructions", pkgFile] ""
appmgr sink `catch` \ece ->
print ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece))
sourceLicense :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
sourceLicense appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", pkgFile] ""
appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece)
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "license", pkgFile] ""
appmgr sink
`catch` \ece -> print ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece))
sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a
sinkMem c = runConduit $ c .| CL.foldMap id