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

redefine appmgr calls, holes at call sites

Browse Source
This commit is contained in:
Keagan McClelland
2021-09-27 20:26:03 -06:00
parent 3b857c2896
commit 1fc3c2b678
5 changed files with 128 additions and 126 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
src/Handler/Apps.hs
View File

@@ -72,17 +72,18 @@ getSysR e = do
getAppManifestR :: PkgId -> Handler TypedContent getAppManifestR :: PkgId -> Handler TypedContent
getAppManifestR appId = do getAppManifestR appId = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings -- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
av <- getVersionFromQuery appsDir appExt >>= \case -- av <- getVersionFromQuery appsDir appExt >>= \case
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
addPackageHeader appMgrDir appDir appExt -- addPackageHeader appMgrDir appDir appExt
sourceManifest appMgrDir -- sourceManifest appMgrDir
appDir -- appDir
appExt -- appExt
(\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) -- (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS))
where appExt = Extension (show appId) :: Extension "s9pk" -- where appExt = Extension (show appId) :: Extension "s9pk"
_
getAppR :: Extension "s9pk" -> Handler TypedContent getAppR :: Extension "s9pk" -> Handler TypedContent
getAppR e = do getAppR e = do

109
src/Handler/Icons.hs
View File

@@ -39,62 +39,65 @@ ixt = toS $ toUpper <$> drop 1 ".png"
getIconsR :: PkgId -> Handler TypedContent getIconsR :: PkgId -> Handler TypedContent
getIconsR appId = do getIconsR appId = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings -- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
spec <- getVersionFromQuery appsDir ext >>= \case -- spec <- getVersionFromQuery appsDir ext >>= \case
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' <- sourceManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict) -- manifest' <- sourceManifest 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!"
$logError (show e) -- $logError (show e)
sendResponseStatus status500 ("Internal Server Error" :: Text) -- sendResponseStatus status500 ("Internal Server Error" :: Text)
Right a -> pure a -- Right a -> pure a
mimeType <- case serviceManifestIcon manifest of -- mimeType <- case serviceManifestIcon manifest of
Nothing -> pure typePng -- Nothing -> pure typePng
Just a -> do -- Just a -> do
let (_, iconExt) = splitExtension $ toS a -- let (_, iconExt) = splitExtension $ toS a
let x = toUpper <$> drop 1 iconExt -- let x = toUpper <$> drop 1 iconExt
case readMaybe $ toS x of -- case readMaybe $ toS x of
Nothing -> do -- Nothing -> do
$logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain." -- $logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain."
pure typePlain -- pure typePlain
Just iconType -> case iconType of -- Just iconType -> case iconType of
PNG -> pure typePng -- PNG -> pure typePng
SVG -> pure typeSvg -- SVG -> pure typeSvg
JPG -> pure typeJpeg -- JPG -> pure typeJpeg
JPEG -> pure typeJpeg -- JPEG -> pure typeJpeg
sourceIcon appMgrDir -- sourceIcon appMgrDir
(appDir </> show ext) -- (appDir </> show ext)
ext -- ext
(\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS)) -- (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS))
where ext = Extension (show appId) :: Extension "s9pk" -- where ext = Extension (show appId) :: Extension "s9pk"
_
getLicenseR :: PkgId -> Handler TypedContent getLicenseR :: PkgId -> Handler TypedContent
getLicenseR appId = do getLicenseR appId = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings -- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
spec <- getVersionFromQuery appsDir ext >>= \case -- spec <- getVersionFromQuery appsDir ext >>= \case
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
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec -- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
case servicePath of -- case servicePath of
Nothing -> notFound -- Nothing -> notFound
Just p -> -- Just p ->
sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) -- sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
where ext = Extension (show appId) :: Extension "s9pk" -- where ext = Extension (show appId) :: Extension "s9pk"
_
getInstructionsR :: PkgId -> Handler TypedContent getInstructionsR :: PkgId -> Handler TypedContent
getInstructionsR appId = do getInstructionsR appId = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings -- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
spec <- getVersionFromQuery appsDir ext >>= \case -- spec <- getVersionFromQuery appsDir ext >>= \case
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
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec -- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
case servicePath of -- case servicePath of
Nothing -> notFound -- Nothing -> notFound
Just p -> sourceInstructions appMgrDir -- Just p -> sourceInstructions appMgrDir
p -- p
ext -- ext
(\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) -- (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
where ext = Extension (show appId) :: Extension "s9pk" -- where ext = Extension (show appId) :: Extension "s9pk"
_

69
src/Handler/Marketplace.hs
View File

@@ -329,34 +329,35 @@ getServiceDetails :: (MonadUnliftIO m, Monad m, MonadError IOException m)
-> PkgId -> PkgId
-> m (Either Text ServiceRes) -> m (Either Text ServiceRes)
getServiceDetails settings metadata maybeVersion appId = do getServiceDetails settings metadata maybeVersion appId = do
packageMetadata <- case HM.lookup appId metadata of -- packageMetadata <- case HM.lookup appId metadata of
Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|] -- Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|]
Just m -> pure m -- Just m -> pure m
let (appsDir, appMgrDir) = ((</> "apps") . resourcesDir &&& staticBinDir) settings -- let (appsDir, appMgrDir) = ((</> "apps") . resourcesDir &&& staticBinDir) settings
let domain = registryHostname settings -- let domain = registryHostname settings
version <- case maybeVersion of -- version <- case maybeVersion of
Nothing -> do -- Nothing -> do
-- grab first value, which will be the latest version -- -- grab first value, which will be the latest version
case fst packageMetadata of -- case fst packageMetadata of
[] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId -- [] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId
x : _ -> pure x -- x : _ -> pure x
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' <- sourceManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict)) -- manifest' <- sourceManifest 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
d <- liftIO -- d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata)
$ mapConcurrently (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m) -- (HM.toList $ serviceManifestDependencies m)
pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] -- pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|]
, serviceResManifest = decode $ manifest' -- pass through raw JSON Value -- , serviceResManifest = decode $ manifest' -- pass through raw JSON Value
, serviceResCategories = snd packageMetadata -- , serviceResCategories = snd packageMetadata
, serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] -- , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|]
, serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] -- , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|]
, serviceResVersions = sortOn Down $ fst packageMetadata -- , serviceResVersions = fst packageMetadata
, serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d -- , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d
} -- }
_
mapDependencyMetadata :: (MonadIO m) mapDependencyMetadata :: (MonadIO m)
=> Text => Text
@@ -380,13 +381,13 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do
} }
) )
decodeInstructions :: (MonadUnliftIO m, MonadHandler m, MonadThrow m) => FilePath -> FilePath -> S9PK -> m Text -- decodeInstructions :: (MonadUnliftIO m, MonadHandler m, MonadThrow m) => FilePath -> FilePath -> S9PK -> m Text
decodeInstructions appmgrPath depPath package = do -- decodeInstructions appmgrPath depPath package = do
sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) -- sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8))
decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m Text -- decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m Text
decodeLicense appmgrPath depPath package = -- decodeLicense appmgrPath depPath package =
sourceLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) -- sourceLicense 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

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

@@ -56,31 +56,31 @@ readProcessInheritStderr a b c sink = do
$ System.Process.Typed.proc a b $ System.Process.Typed.proc a b
withProcessTerm_ pc $ \p -> sink (getStdout p) withProcessTerm_ pc $ \p -> sink (getStdout p)
sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
sourceManifest appmgrPath appPath e@(Extension appId) sink = do sourceManifest appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath </> show e] "" let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "manifest", pkgFile] ""
appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{appId}|] (eceExitCode ece)) appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece))
sourceIcon :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceIcon :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
sourceIcon appmgrPath appPath (Extension icon) sink = do sourceIcon appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", pkgFile] ""
appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] (eceExitCode ece) appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece)
getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> m ByteString getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> m ByteString
getPackageHash appmgrPath appPath e@(Extension appId) = do getPackageHash appmgrPath pkgFile = do
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] "" let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", pkgFile] ""
appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id)
`catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] (eceExitCode ece) `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece)
sourceInstructions :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceInstructions :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
sourceInstructions appmgrPath appPath (Extension appId) sink = do sourceInstructions appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", pkgFile] ""
appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] (eceExitCode ece) appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)
sourceLicense :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceLicense :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
sourceLicense appmgrPath appPath (Extension appId) sink = do sourceLicense appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", pkgFile] ""
appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{appId}|] (eceExitCode ece) appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece)
sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a
sinkMem c = runConduit $ c .| CL.foldMap id sinkMem c = runConduit $ c .| CL.foldMap id

13
src/Lib/PkgRepository.hs
View File

@@ -108,17 +108,14 @@ extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m)
extractPkg pkg v = (`onException` cleanup) $ do extractPkg pkg v = (`onException` cleanup) $ do
$logInfo [i|Extracting package: #{pkg}@#{v}|] $logInfo [i|Extracting package: #{pkg}@#{v}|]
PkgRepo { pkgRepoFileRoot = root, pkgRepoAppMgrBin = appmgr } <- ask PkgRepo { pkgRepoFileRoot = root, pkgRepoAppMgrBin = appmgr } <- ask
let s9pk = Extension @"s9pk" $ show pkg
let pkgRoot = root </> show pkg </> show v let pkgRoot = root </> show pkg </> show v
$logInfo [i|#{s9pk}|] let s9pk = pkgRoot </> show pkg <.> "s9pk"
$logInfo [i|#{pkgRoot}|] manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr s9pk $ sinkIt
manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr pkgRoot s9pk $ sinkIt
(pkgRoot </> "manifest.json") (pkgRoot </> "manifest.json")
instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr pkgRoot s9pk $ sinkIt instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr s9pk $ sinkIt
(pkgRoot </> "instructions.md") (pkgRoot </> "instructions.md")
licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr pkgRoot s9pk $ sinkIt licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr s9pk $ sinkIt (pkgRoot </> "license.md")
(pkgRoot </> "license.md") iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr s9pk $ sinkIt (pkgRoot </> "icon.tmp")
iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr pkgRoot s9pk $ sinkIt (pkgRoot </> "icon.tmp")
wait manifestTask wait manifestTask
eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot </> "manifest.json")) eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot </> "manifest.json"))
case eManifest of case eManifest of