diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index bbbc9bb..b901df7 100644 --- a/src/Handler/Apps.hs +++ b/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" diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 138e8cf..056c58e 100644 --- a/src/Handler/Icons.hs +++ b/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" diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index e920565..61567e2 100644 --- a/src/Handler/Marketplace.hs +++ b/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 diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index e9a01e7..f743558 100644 --- a/src/Lib/Error.hs +++ b/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) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 3ca9ec0..56628e8 100644 --- a/src/Lib/External/AppMgr.hs +++ b/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 diff --git a/src/Settings.hs b/src/Settings.hs index da08761..f6b9ed8 100644 --- a/src/Settings.hs +++ b/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, diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 582f53b..7788608 100644 --- a/src/Util/Shared.hs +++ b/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