mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
redefine appmgr calls, holes at call sites
This commit is contained in:
Keagan McClelland
@@ -72,17 +72,18 @@ getSysR e = do
|
||||
|
||||
getAppManifestR :: PkgId -> Handler TypedContent
|
||||
getAppManifestR appId = do
|
||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
av <- getVersionFromQuery appsDir appExt >>= \case
|
||||
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
Just v -> pure v
|
||||
let appDir = (<> "/") . (</> show av) . (</> show appId) $ appsDir
|
||||
addPackageHeader appMgrDir appDir appExt
|
||||
sourceManifest appMgrDir
|
||||
appDir
|
||||
appExt
|
||||
(\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS))
|
||||
where appExt = Extension (show appId) :: Extension "s9pk"
|
||||
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
-- av <- getVersionFromQuery appsDir appExt >>= \case
|
||||
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
-- Just v -> pure v
|
||||
-- let appDir = (<> "/") . (</> show av) . (</> show appId) $ appsDir
|
||||
-- addPackageHeader appMgrDir appDir appExt
|
||||
-- sourceManifest appMgrDir
|
||||
-- appDir
|
||||
-- appExt
|
||||
-- (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS))
|
||||
-- where appExt = Extension (show appId) :: Extension "s9pk"
|
||||
_
|
||||
|
||||
getAppR :: Extension "s9pk" -> Handler TypedContent
|
||||
getAppR e = do
|
||||
|
||||
@@ -39,62 +39,65 @@ ixt = toS $ toUpper <$> drop 1 ".png"
|
||||
|
||||
getIconsR :: PkgId -> Handler TypedContent
|
||||
getIconsR appId = do
|
||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
spec <- getVersionFromQuery appsDir ext >>= \case
|
||||
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
Just v -> pure v
|
||||
let appDir = (<> "/") . (</> show spec) . (</> show appId) $ appsDir
|
||||
manifest' <- sourceManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict)
|
||||
manifest <- case eitherDecode manifest' of
|
||||
Left e -> do
|
||||
$logError "could not parse service manifest!"
|
||||
$logError (show e)
|
||||
sendResponseStatus status500 ("Internal Server Error" :: Text)
|
||||
Right a -> pure a
|
||||
mimeType <- case serviceManifestIcon manifest of
|
||||
Nothing -> pure typePng
|
||||
Just a -> do
|
||||
let (_, iconExt) = splitExtension $ toS a
|
||||
let x = toUpper <$> drop 1 iconExt
|
||||
case readMaybe $ toS x of
|
||||
Nothing -> do
|
||||
$logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain."
|
||||
pure typePlain
|
||||
Just iconType -> case iconType of
|
||||
PNG -> pure typePng
|
||||
SVG -> pure typeSvg
|
||||
JPG -> pure typeJpeg
|
||||
JPEG -> pure typeJpeg
|
||||
sourceIcon appMgrDir
|
||||
(appDir </> show ext)
|
||||
ext
|
||||
(\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS))
|
||||
where ext = Extension (show appId) :: Extension "s9pk"
|
||||
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
-- spec <- getVersionFromQuery appsDir ext >>= \case
|
||||
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
-- Just v -> pure v
|
||||
-- let appDir = (<> "/") . (</> show spec) . (</> show appId) $ appsDir
|
||||
-- manifest' <- sourceManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict)
|
||||
-- manifest <- case eitherDecode manifest' of
|
||||
-- Left e -> do
|
||||
-- $logError "could not parse service manifest!"
|
||||
-- $logError (show e)
|
||||
-- sendResponseStatus status500 ("Internal Server Error" :: Text)
|
||||
-- Right a -> pure a
|
||||
-- mimeType <- case serviceManifestIcon manifest of
|
||||
-- Nothing -> pure typePng
|
||||
-- Just a -> do
|
||||
-- let (_, iconExt) = splitExtension $ toS a
|
||||
-- let x = toUpper <$> drop 1 iconExt
|
||||
-- case readMaybe $ toS x of
|
||||
-- Nothing -> do
|
||||
-- $logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain."
|
||||
-- pure typePlain
|
||||
-- Just iconType -> case iconType of
|
||||
-- PNG -> pure typePng
|
||||
-- SVG -> pure typeSvg
|
||||
-- JPG -> pure typeJpeg
|
||||
-- JPEG -> pure typeJpeg
|
||||
-- sourceIcon appMgrDir
|
||||
-- (appDir </> show ext)
|
||||
-- ext
|
||||
-- (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS))
|
||||
-- where ext = Extension (show appId) :: Extension "s9pk"
|
||||
_
|
||||
|
||||
getLicenseR :: PkgId -> Handler TypedContent
|
||||
getLicenseR appId = do
|
||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
spec <- getVersionFromQuery appsDir ext >>= \case
|
||||
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
Just v -> pure v
|
||||
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
|
||||
case servicePath of
|
||||
Nothing -> notFound
|
||||
Just p ->
|
||||
sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
|
||||
where ext = Extension (show appId) :: Extension "s9pk"
|
||||
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
-- spec <- getVersionFromQuery appsDir ext >>= \case
|
||||
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
-- Just v -> pure v
|
||||
-- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
|
||||
-- case servicePath of
|
||||
-- Nothing -> notFound
|
||||
-- Just p ->
|
||||
-- sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
|
||||
-- where ext = Extension (show appId) :: Extension "s9pk"
|
||||
_
|
||||
|
||||
getInstructionsR :: PkgId -> Handler TypedContent
|
||||
getInstructionsR appId = do
|
||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
spec <- getVersionFromQuery appsDir ext >>= \case
|
||||
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
Just v -> pure v
|
||||
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
|
||||
case servicePath of
|
||||
Nothing -> notFound
|
||||
Just p -> sourceInstructions appMgrDir
|
||||
p
|
||||
ext
|
||||
(\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
|
||||
where ext = Extension (show appId) :: Extension "s9pk"
|
||||
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
-- spec <- getVersionFromQuery appsDir ext >>= \case
|
||||
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
-- Just v -> pure v
|
||||
-- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
|
||||
-- case servicePath of
|
||||
-- Nothing -> notFound
|
||||
-- Just p -> sourceInstructions appMgrDir
|
||||
-- p
|
||||
-- ext
|
||||
-- (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
|
||||
-- where ext = Extension (show appId) :: Extension "s9pk"
|
||||
_
|
||||
|
||||
@@ -329,34 +329,35 @@ getServiceDetails :: (MonadUnliftIO m, Monad m, MonadError IOException m)
|
||||
-> PkgId
|
||||
-> m (Either Text ServiceRes)
|
||||
getServiceDetails settings metadata maybeVersion appId = do
|
||||
packageMetadata <- case HM.lookup appId metadata of
|
||||
Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|]
|
||||
Just m -> pure m
|
||||
let (appsDir, appMgrDir) = ((</> "apps") . resourcesDir &&& staticBinDir) settings
|
||||
let domain = registryHostname settings
|
||||
version <- case maybeVersion of
|
||||
Nothing -> do
|
||||
-- grab first value, which will be the latest version
|
||||
case fst packageMetadata of
|
||||
[] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId
|
||||
x : _ -> pure x
|
||||
Just v -> pure v
|
||||
let appDir = (<> "/") . (</> show version) . (</> show appId) $ appsDir
|
||||
let appExt = Extension (show appId) :: Extension "s9pk"
|
||||
manifest' <- sourceManifest 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
|
||||
d <- liftIO
|
||||
$ mapConcurrently (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m)
|
||||
pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|]
|
||||
, serviceResManifest = decode $ manifest' -- pass through raw JSON Value
|
||||
, serviceResCategories = snd packageMetadata
|
||||
, serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|]
|
||||
, serviceResLicense = [i|https://#{domain}/package/license/#{appId}|]
|
||||
, serviceResVersions = sortOn Down $ fst packageMetadata
|
||||
, serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d
|
||||
}
|
||||
-- packageMetadata <- case HM.lookup appId metadata of
|
||||
-- Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|]
|
||||
-- Just m -> pure m
|
||||
-- let (appsDir, appMgrDir) = ((</> "apps") . resourcesDir &&& staticBinDir) settings
|
||||
-- let domain = registryHostname settings
|
||||
-- version <- case maybeVersion of
|
||||
-- Nothing -> do
|
||||
-- -- grab first value, which will be the latest version
|
||||
-- case fst packageMetadata of
|
||||
-- [] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId
|
||||
-- x : _ -> pure x
|
||||
-- Just v -> pure v
|
||||
-- let appDir = (<> "/") . (</> show version) . (</> show appId) $ appsDir
|
||||
-- let appExt = Extension (show appId) :: Extension "s9pk"
|
||||
-- manifest' <- sourceManifest 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
|
||||
-- d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata)
|
||||
-- (HM.toList $ serviceManifestDependencies m)
|
||||
-- pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|]
|
||||
-- , serviceResManifest = decode $ manifest' -- pass through raw JSON Value
|
||||
-- , serviceResCategories = snd packageMetadata
|
||||
-- , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|]
|
||||
-- , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|]
|
||||
-- , serviceResVersions = fst packageMetadata
|
||||
-- , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d
|
||||
-- }
|
||||
_
|
||||
|
||||
mapDependencyMetadata :: (MonadIO m)
|
||||
=> Text
|
||||
@@ -380,13 +381,13 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do
|
||||
}
|
||||
)
|
||||
|
||||
decodeInstructions :: (MonadUnliftIO m, MonadHandler m, MonadThrow m) => FilePath -> FilePath -> S9PK -> m Text
|
||||
decodeInstructions appmgrPath depPath package = do
|
||||
sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8))
|
||||
-- decodeInstructions :: (MonadUnliftIO m, MonadHandler m, MonadThrow m) => FilePath -> FilePath -> S9PK -> m Text
|
||||
-- decodeInstructions appmgrPath depPath package = do
|
||||
-- sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8))
|
||||
|
||||
decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m Text
|
||||
decodeLicense appmgrPath depPath package =
|
||||
sourceLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8))
|
||||
-- decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m Text
|
||||
-- decodeLicense appmgrPath depPath package =
|
||||
-- sourceLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8))
|
||||
|
||||
fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes)
|
||||
fetchAllAppVersions appId = do
|
||||
|
||||
40
src/Lib/External/AppMgr.hs
vendored
40
src/Lib/External/AppMgr.hs
vendored
@@ -56,31 +56,31 @@ readProcessInheritStderr a b c sink = do
|
||||
$ System.Process.Typed.proc a b
|
||||
withProcessTerm_ pc $ \p -> sink (getStdout p)
|
||||
|
||||
sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r
|
||||
sourceManifest 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))
|
||||
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))
|
||||
|
||||
sourceIcon :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r
|
||||
sourceIcon 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)
|
||||
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)
|
||||
|
||||
getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> m ByteString
|
||||
getPackageHash appmgrPath appPath e@(Extension appId) = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] ""
|
||||
getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> m ByteString
|
||||
getPackageHash appmgrPath pkgFile = do
|
||||
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 #{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 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)
|
||||
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)
|
||||
|
||||
sourceLicense :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r
|
||||
sourceLicense 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)
|
||||
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)
|
||||
|
||||
sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a
|
||||
sinkMem c = runConduit $ c .| CL.foldMap id
|
||||
|
||||
@@ -108,17 +108,14 @@ extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m)
|
||||
extractPkg pkg v = (`onException` cleanup) $ do
|
||||
$logInfo [i|Extracting package: #{pkg}@#{v}|]
|
||||
PkgRepo { pkgRepoFileRoot = root, pkgRepoAppMgrBin = appmgr } <- ask
|
||||
let s9pk = Extension @"s9pk" $ show pkg
|
||||
let pkgRoot = root </> show pkg </> show v
|
||||
$logInfo [i|#{s9pk}|]
|
||||
$logInfo [i|#{pkgRoot}|]
|
||||
manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr pkgRoot s9pk $ sinkIt
|
||||
let s9pk = pkgRoot </> show pkg <.> "s9pk"
|
||||
manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr s9pk $ sinkIt
|
||||
(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")
|
||||
licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr pkgRoot s9pk $ sinkIt
|
||||
(pkgRoot </> "license.md")
|
||||
iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr pkgRoot s9pk $ sinkIt (pkgRoot </> "icon.tmp")
|
||||
licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr s9pk $ sinkIt (pkgRoot </> "license.md")
|
||||
iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr s9pk $ sinkIt (pkgRoot </> "icon.tmp")
|
||||
wait manifestTask
|
||||
eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot </> "manifest.json"))
|
||||
case eManifest of
|
||||
|
||||
Reference in New Issue
Block a user