changes appmgr calls to be conduit sources.

src/Handler/Apps.hs

@@ -31,16 +31,16 @@ import           System.Posix.Files             ( fileSize
 import           Yesod.Core
 import           Yesod.Persist.Core
 
+import           Database.Queries
 import           Foundation
+import           Lib.Error
+import           Lib.External.AppMgr
 import           Lib.Registry
 import           Lib.Types.AppIndex
 import           Lib.Types.Emver
 import           Lib.Types.FileSystem
-import           Lib.Error
-import           Lib.External.AppMgr
-import           Settings
-import           Database.Queries
 import           Network.Wai                    ( Request(requestHeaderUserAgent) )
+import           Settings
 import           Util.Shared
 
 pureLog :: Show a => a -> Handler a
@@ -78,9 +78,11 @@ getAppManifestR appId = do
         Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
         Just v  -> pure v
     let appDir = (<> "/") . (</> show av) . (</> show appId) $ appsDir
-    manifest <- handleS9ErrT $ getManifest appMgrDir appDir appExt
     addPackageHeader appMgrDir appDir appExt
-    pure $ TypedContent "application/json" (toContent manifest)
+    getManifest appMgrDir
+                appDir
+                appExt
+                (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS))
     where appExt = Extension (show appId) :: Extension "s9pk"
 
 getAppConfigR :: AppIdentifier -> Handler TypedContent
@@ -92,8 +94,8 @@ getAppConfigR appId = do
         Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
         Just v  -> pure v
     let appDir = (<> "/") . (</> show av) . (</> show appId) $ appsDir
-    config <- handleS9ErrT $ getConfig appMgrDir appDir appExt
     addPackageHeader appMgrDir appDir appExt
+    config <- getConfig appMgrDir appDir appExt (\bsSource -> _)
     pure $ TypedContent "application/json" (toContent config)
     where appExt = Extension (show appId) :: Extension "s9pk"
 

src/Handler/Icons.hs

@@ -13,6 +13,11 @@ import           Yesod.Core
 
 import           Data.Aeson
 import qualified Data.ByteString.Lazy          as BS
+import           Data.Conduit                   ( (.|)
+                                                , awaitForever
+                                                , runConduit
+                                                )
+import qualified Data.Conduit.List             as CL
 import           Foundation
 import           Lib.Error
 import           Lib.External.AppMgr
@@ -40,7 +45,7 @@ getIconsR appId = do
         Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
         Just v  -> pure v
     let appDir = (<> "/") . (</> show spec) . (</> show appId) $ appsDir
-    manifest' <- handleS9ErrT $ getManifest appMgrDir appDir ext
+    manifest' <- getManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict)
     manifest  <- case eitherDecode manifest' of
         Left e -> do
             $logError "could not parse service manifest!"
@@ -61,10 +66,10 @@ getIconsR appId = do
                     SVG  -> pure typeSvg
                     JPG  -> pure typeJpeg
                     JPEG -> pure typeJpeg
-    respondSource mimeType (sendChunkBS =<< BS.toStrict <$> handleS9ErrT (getIcon appMgrDir (appDir </> show ext) ext))
-    -- (_, Just hout, _, _) <- liftIO (createProcess $ iconBs { std_out = CreatePipe })
-    -- respondSource typePlain (runConduit $ yieldMany () [iconBs])
-    -- respondSource typePlain $ sourceHandle hout .| awaitForever sendChunkBS
+    getIcon appMgrDir
+            (appDir </> show ext)
+            ext
+            (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS))
     where ext = Extension (show appId) :: Extension "s9pk"
 
 getLicenseR :: AppIdentifier -> Handler TypedContent
@@ -76,8 +81,8 @@ getLicenseR appId = do
     servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
     case servicePath of
         Nothing -> notFound
-        Just p  -> do
-            respondSource typePlain (sendChunkBS =<< BS.toStrict <$> handleS9ErrT (getLicense appMgrDir p ext))
+        Just p ->
+            getLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
     where ext = Extension (show appId) :: Extension "s9pk"
 
 getInstructionsR :: AppIdentifier -> Handler TypedContent
@@ -89,6 +94,8 @@ getInstructionsR appId = do
     servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
     case servicePath of
         Nothing -> notFound
-        Just p  -> do
-            respondSource typePlain (sendChunkBS =<< BS.toStrict <$> handleS9ErrT (getInstructions appMgrDir p ext))
+        Just p  -> getInstructions appMgrDir
+                                   p
+                                   ext
+                                   (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
     where ext = Extension (show appId) :: Extension "s9pk"

src/Handler/Marketplace.hs

@@ -11,8 +11,13 @@
 {-# LANGUAGE DeriveAnyClass #-}
 
 module Handler.Marketplace where
+import           Conduit                        ( (.|)
+                                                , MonadThrow
+                                                , mapC
+                                                )
 import           Data.Aeson
 import qualified Data.ByteString.Lazy          as BS
+import qualified Data.Conduit.Text             as CT
 import qualified Data.HashMap.Strict           as HM
 import           Data.List
 import qualified Data.List.NonEmpty            as NE
@@ -388,7 +393,7 @@ getPackageListR = do
                         Just v -> do
                             pure $ Right (Just v, appId)
 
-getServiceDetails :: (MonadIO m, Monad m, MonadError IOException m)
+getServiceDetails :: (MonadUnliftIO m, Monad m, MonadError IOException m)
                   => AppSettings
                   -> (HM.HashMap AppIdentifier ([Version], [CategoryTitle]))
                   -> Maybe Version
@@ -409,7 +414,7 @@ getServiceDetails settings metadata maybeVersion appId = do
         Just v -> pure v
     let appDir = (<> "/") . (</> show version) . (</> show appId) $ appsDir
     let appExt = Extension (show appId) :: Extension "s9pk"
-    manifest' <- handleS9ErrNuclear $ getManifest appMgrDir appDir appExt
+    manifest' <- getManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict))
     case eitherDecode $ manifest' of
         Left  e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e
         Right m -> do
@@ -447,24 +452,30 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do
                          }
         )
 
-decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL
-decodeIcon appmgrPath depPath e@(Extension icon) = do
-    icon' <- handleS9ErrT $ getIcon appmgrPath depPath e
-    case eitherDecode icon' of
-        Left e' -> do
-            $logInfo $ T.pack e'
-            sendResponseStatus status400 e'
-        Right (i' :: URL) -> pure $ i' <> T.pack icon
+-- decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL
+-- decodeIcon appmgrPath depPath e@(Extension icon) = do
+--     icon' <- handleS9ErrT $ getIcon appmgrPath depPath e
+--     case eitherDecode icon' of
+--         Left e' -> do
+--             $logInfo $ T.pack e'
+--             sendResponseStatus status400 e'
+--         Right (i' :: URL) -> pure $ i' <> T.pack icon
 
-decodeInstructions :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m Text
+decodeInstructions :: (MonadUnliftIO m, MonadHandler m, KnownSymbol a, MonadThrow m)
+                   => FilePath
+                   -> FilePath
+                   -> Extension a
+                   -> m Text
 decodeInstructions appmgrPath depPath package = do
-    instructions <- handleS9ErrT $ getInstructions appmgrPath depPath package
-    pure $ decodeUtf8 $ BS.toStrict instructions
+    getInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8))
 
-decodeLicense :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m Text
-decodeLicense appmgrPath depPath package = do
-    license <- handleS9ErrT $ getLicense appmgrPath depPath package
-    pure $ decodeUtf8 $ BS.toStrict license
+decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m, KnownSymbol a)
+              => FilePath
+              -> FilePath
+              -> Extension a
+              -> m Text
+decodeLicense appmgrPath depPath package =
+    getLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8))
 
 fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes)
 fetchAllAppVersions appId = do

src/Lib/Error.hs

@@ -5,15 +5,15 @@ module Lib.Error where
 
 import           Startlude
 
+import           Data.String.Interpolate.IsString
 import           Network.HTTP.Types
 import           Yesod.Core
-import           Data.String.Interpolate.IsString
 
 type S9ErrT m = ExceptT S9Error m
 
 data S9Error =
       PersistentE Text
-    | AppMgrE Text Int
+    | AppMgrE Text ExitCode
     | NotFoundE Text
     deriving (Show, Eq)
 

src/Lib/External/AppMgr.hs

@@ -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

src/Settings.hs

@@ -24,7 +24,6 @@ import           System.FilePath                ( (</>) )
 import           Yesod.Default.Config2          ( configSettingsYml )
 
 import           Lib.Types.Emver
-import           Network.Wai                    ( FilePart )
 import           Orphans.Emver                  ( )
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,

src/Util/Shared.hs

@@ -8,13 +8,11 @@ import qualified Data.Text                     as T
 import           Network.HTTP.Types
 import           Yesod.Core
 
+import           Data.Semigroup
 import           Foundation
+import           Lib.External.AppMgr
 import           Lib.Registry
 import           Lib.Types.Emver
-import           Data.Semigroup
-import           Lib.External.AppMgr
-import           Lib.Error
-import qualified Data.ByteString.Lazy          as BS
 
 getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version)
 getVersionFromQuery rootDir ext = do
@@ -36,7 +34,7 @@ getBestVersion rootDir ext spec = do
     let best         = getMax <$> foldMap (Just . Max . fst . unRegisteredAppVersion) satisfactory
     pure best
 
-addPackageHeader :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m ()
+addPackageHeader :: (MonadUnliftIO m, MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m ()
 addPackageHeader appMgrDir appDir appExt = do
-    packageHash <- handleS9ErrT $ getPackageHash appMgrDir appDir appExt
-    addHeader "X-S9PK-HASH" $ decodeUtf8 $ BS.toStrict packageHash
+    packageHash <- getPackageHash appMgrDir appDir appExt
+    addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash