From 113d882f8c0de031f81e53df82ae796c19a1fa5a Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 28 Sep 2021 20:19:32 -0600 Subject: [PATCH] fixes extraction logic, found a bug in System.Process --- src/Lib/External/AppMgr.hs | 69 +++++++++++++++++++++++++++++++------- src/Lib/PkgRepository.hs | 16 ++++++--- 2 files changed, 67 insertions(+), 18 deletions(-) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index a49fb90..86dad17 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -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 diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 9c4a4e7..df331af 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -62,6 +62,7 @@ import Startlude ( ($) , MonadIO(liftIO) , MonadReader , Show + , SomeException(SomeException) , filter , find , for_ @@ -69,10 +70,12 @@ import Startlude ( ($) , headMay , not , partitionEithers + , print , pure , show , sortOn , throwIO + , void ) import System.FSNotify ( Event(Added) , eventPath @@ -89,6 +92,7 @@ import UnliftIO ( MonadUnliftIO , askRunInIO , async , mapConcurrently + , mapConcurrently_ , newEmptyMVar , onException , takeMVar @@ -101,6 +105,7 @@ import UnliftIO.Directory ( getFileSize , removeFile , renameFile ) +import UnliftIO.Exception ( handle ) import Yesod.Core.Content ( typeGif , typeJpeg , typePlain @@ -137,11 +142,10 @@ getBestVersion pkg spec = headMay . sortOn Down <$> getViableVersions pkg spec -- extract all package assets into their own respective files extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m () -extractPkg fp = (`onException` cleanup) $ do +extractPkg fp = handle @_ @SomeException cleanup $ do $logInfo [i|Extracting package: #{fp}|] PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask let pkgRoot = takeDirectory fp - -- let s9pk = pkgRoot show pkg <.> "s9pk" manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot "manifest.json") pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp @@ -165,11 +169,13 @@ extractPkg fp = (`onException` cleanup) $ do wait licenseTask where sinkIt fp source = runConduit $ source .| sinkFileCautious fp - cleanup = do + cleanup e = do + $logError $ show e let pkgRoot = takeDirectory fp fs <- listDirectory pkgRoot let toRemove = filter (not . (== ".s9pk") . takeExtension) fs - mapConcurrently (removeFile . (pkgRoot )) toRemove + mapConcurrently_ (removeFile . (pkgRoot )) toRemove + throwIO e watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => m (IO Bool) watchPkgRepoRoot = do @@ -181,7 +187,7 @@ watchPkgRepoRoot = do stop <- watchTree watchManager root onlyAdded $ \evt -> do let pkg = eventPath evt -- TODO: validate that package path is an actual s9pk and is in a correctly conforming path. - runInIO (extractPkg pkg) + void . forkIO $ runInIO (extractPkg pkg) takeMVar box stop pure $ tryPutMVar box ()