mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
fixes extraction logic, found a bug in System.Process
This commit is contained in:
Keagan McClelland
69
src/Lib/External/AppMgr.hs
vendored
69
src/Lib/External/AppMgr.hs
vendored
@@ -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
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
Reference in New Issue
Block a user