fixes extraction logic, found a bug in System.Process

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] ""
+    let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "icon", pkgFile] ""
-    appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece)
+    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] ""
+    let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "instructions", pkgFile] ""
-    appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)
+    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] ""
+    let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "license", pkgFile] ""
-    appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece)
+    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

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 ()