Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

changes appmgr calls to be conduit sources.

Browse Source
This commit is contained in:
Keagan McClelland
2021-09-27 10:07:00 -06:00
parent 857fcde913
commit 164089ff88
7 changed files with 135 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
src/Handler/Apps.hs
View File

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

25
src/Handler/Icons.hs
View File

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

45
src/Handler/Marketplace.hs
View File

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

4
src/Lib/Error.hs
View File

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

117
src/Lib/External/AppMgr.hs vendored
View File

@@ -10,14 +10,25 @@
module Lib.External.AppMgr where module Lib.External.AppMgr where
import Startlude import Startlude hiding ( catch )
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
import System.Process.Typed hiding ( createPipe ) 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.Error
import Lib.Registry import Lib.Registry
import System.FilePath ( (</>) )
import UnliftIO ( MonadUnliftIO
, catch
)
readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString) readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
readProcessWithExitCode' a b c = liftIO $ do readProcessWithExitCode' a b c = liftIO $ do
@@ -32,56 +43,78 @@ readProcessWithExitCode' a b c = liftIO $ do
(LBS.toStrict <$> getStdout process) (LBS.toStrict <$> getStdout process)
(LBS.toStrict <$> getStderr process) (LBS.toStrict <$> getStderr process)
readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, LBS.ByteString) readProcessInheritStderr :: MonadUnliftIO m
readProcessInheritStderr a b c = liftIO $ do => 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 = let pc =
setStdin (byteStringInput $ LBS.fromStrict c) setStdin (byteStringInput $ LBS.fromStrict c)
$ setStderr inherit
$ setEnvInherit $ setEnvInherit
$ setStdout byteStringOutput $ setStdout createSource
$ System.Process.Typed.proc a b $ 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 :: (MonadUnliftIO m, MonadThrow m, KnownSymbol a)
getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do => FilePath
(ec, out) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") -> FilePath
["inspect", "config", appPath <> show e, "--json"] -> 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 appmgr sink `catch` \ece -> throwIO (AppMgrE [i|inspect config #{appId} \--json|] (eceExitCode ece))
ExitSuccess -> pure $ LBS.toStrict out
ExitFailure n -> throwE $ AppMgrE [i|info config #{appId} \--json|] n
getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getManifest :: (MonadUnliftIO m, KnownSymbol a)
getManifest appmgrPath appPath e@(Extension appId) = do => FilePath
(!ec, !bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] "" -> FilePath
case ec of -> Extension a
ExitSuccess -> pure bs -> (ConduitT () ByteString m () -> m r)
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n -> 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 :: (MonadUnliftIO m, KnownSymbol a)
getIcon appmgrPath appPath (Extension icon) = do => FilePath
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" -> FilePath
case ec of -> Extension a
ExitSuccess -> pure bs -> (ConduitT () ByteString m () -> m r)
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] n -> 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 getPackageHash appmgrPath appPath e@(Extension appId) = do
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] "" let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] ""
case ec of appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id)
ExitSuccess -> pure bs `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] (eceExitCode ece)
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] n
getInstructions :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getInstructions :: (MonadUnliftIO m, KnownSymbol a)
getInstructions appmgrPath appPath (Extension appId) = do => FilePath
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" -> FilePath
case ec of -> Extension a
ExitSuccess -> pure bs -> (ConduitT () ByteString m () -> m r)
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] n -> 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 :: (MonadUnliftIO m, KnownSymbol a)
getLicense appmgrPath appPath (Extension appId) = do => FilePath
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" -> FilePath
case ec of -> Extension a
ExitSuccess -> pure bs -> (ConduitT () ByteString m () -> m r)
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect license #{appId}|] n -> 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

1
src/Settings.hs
View File

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

12
src/Util/Shared.hs
View File

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