From 692de4e90749d31a78ba687cc0ea4411853de469 Mon Sep 17 00:00:00 2001 From: Lucy C <12953208+elvece@users.noreply.github.com> Date: Tue, 8 Feb 2022 13:11:05 -0700 Subject: [PATCH] Feature/encode icons (#91) * base64 encode icon in package response * adds icons to dependencies * swap arguments for loadIcon * remove redundant constraint Co-authored-by: Keagan McClelland --- package.yaml | 1 + src/Handler/Marketplace.hs | 140 +++++++++++++++++++------------ src/Handler/Types/Marketplace.hs | 2 +- 3 files changed, 89 insertions(+), 54 deletions(-) diff --git a/package.yaml b/package.yaml index 4941855..9330f17 100644 --- a/package.yaml +++ b/package.yaml @@ -14,6 +14,7 @@ default-extensions: dependencies: - base >=4.12 && <5 + - base64 - aeson - ansi-terminal - attoparsec diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 0b8da0c..e899c49 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -25,7 +25,9 @@ import Conduit ( (.|) , sourceFile , takeC ) -import Control.Monad.Logger ( MonadLogger, logWarn ) +import Control.Monad.Logger ( MonadLogger + , logWarn + ) import Control.Monad.Reader.Has ( Has , ask ) @@ -36,10 +38,12 @@ import Data.Aeson ( decode , eitherDecodeStrict ) import qualified Data.Attoparsec.Text as Atto -import Data.ByteArray.Encoding ( Base(Base16) + +import Data.ByteArray.Encoding ( Base(..) , convertToBase ) -import qualified Data.ByteString.Lazy as BS +import Data.ByteString.Base64 +import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit.List as CL import qualified Data.HashMap.Strict as HM import Data.List ( head @@ -61,31 +65,36 @@ import Database.Esqueleto.Experimental , select , table ) -import Database.Marketplace ( getPkgData - , searchServices - , zipVersions - , fetchAllAppVersions +import Database.Marketplace ( fetchAllAppVersions , fetchLatestApp - , getPkgDependencyData, zipDependencyVersions, zipCategories + , getPkgData + , getPkgDependencyData + , searchServices + , zipCategories + , zipDependencyVersions + , zipVersions ) import Database.Persist ( PersistUniqueRead(getBy) , insertUnique ) import Foundation ( Handler - , RegistryCtx(appSettings, appConnPool), Route (IconsR, InstructionsR, LicenseR) + , RegistryCtx(appConnPool, appSettings) + , Route(InstructionsR, LicenseR) ) import Handler.Types.Marketplace -import Lib.Error ( S9Error(..) - ) -import Lib.PkgRepository ( getManifest ) -import Lib.Types.AppIndex ( PkgId(PkgId) +import Lib.Error ( S9Error(..) ) +import Lib.PkgRepository ( PkgRepo + , getIcon + , getManifest ) +import Lib.Types.AppIndex ( PkgId(PkgId) ) import Lib.Types.AppIndex ( ) import Lib.Types.Category ( CategoryTitle(..) ) import Lib.Types.Emver ( Version + , VersionRange , parseRange , parseVersion - , satisfies, VersionRange + , satisfies ) import Model ( Category(..) , EntityField(..) @@ -107,31 +116,32 @@ import UnliftIO.Async ( concurrently , mapConcurrently ) import UnliftIO.Directory ( listDirectory ) -import Util.Shared ( getVersionSpecFromQuery +import Util.Shared ( filterDependencyBestVersion + , filterDependencyOsCompatible , filterLatestVersionFromSpec , filterPkgOsCompatible - , filterDependencyOsCompatible - , filterDependencyBestVersion + , getVersionSpecFromQuery ) import Yesod.Core ( MonadResource + , RenderRoute(renderRoute) , TypedContent , YesodRequest(..) , addHeader , getRequest + , getYesod , getsYesod , lookupGetParam , respondSource , sendChunkBS , sendResponseStatus , typeOctet - , getYesod, RenderRoute (renderRoute) ) import Yesod.Persist ( YesodDB ) import Yesod.Persist.Core ( YesodPersist(runDB) ) getInfoR :: Handler InfoRes getInfoR = do - name <- getsYesod $ marketplaceName . appSettings + name <- getsYesod $ marketplaceName . appSettings allCategories <- runDB $ select $ do cats <- from $ table @Category orderBy [desc (cats ^. CategoryPriority)] @@ -163,8 +173,8 @@ getReleaseNotesR = do case lookup "id" getParameters of Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "") Just package -> do - appConnPool <- appConnPool <$> getYesod - versionRecords <- runDB $ fetchAllAppVersions appConnPool (PkgId package) + appConnPool <- appConnPool <$> getYesod + versionRecords <- runDB $ fetchAllAppVersions appConnPool (PkgId package) pure $ constructReleaseNotesApiRes versionRecords where constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes @@ -205,7 +215,7 @@ getVersionLatestR = do getParameters <- reqGetParams <$> getRequest case lookup "ids" getParameters of Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") - Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of + Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) Right p -> do let packageList = (, Nothing) <$> p @@ -315,42 +325,66 @@ getPackageListR = do $logWarn (show e) sendResponseStatus status400 e Right v -> pure $ Just v - getPackageDependencies :: (MonadIO m, MonadLogger m) => (Version -> Bool) -> PackageMetadata -> ReaderT SqlBackend m (Key PkgRecord, [Category], [Version], Version, [(Key PkgRecord, Text, Version)]) - getPackageDependencies osPredicate PackageMetadata { packageMetadataPkgRecord = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion} = do - let pkgId = entityKey pkg - let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions - let pkgCategories' = entityVal <$> pkgCategories - pkgDepInfo <- getPkgDependencyData pkgId pkgVersion - pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo - let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions - res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo - pure $ (pkgId, pkgCategories', pkgVersions', pkgVersion, res) - constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r) => (Key PkgRecord, [Category], [Version], Version, [(Key PkgRecord, Text, Version)]) -> m PackageRes + getPackageDependencies :: (MonadIO m, MonadLogger m) + => (Version -> Bool) + -> PackageMetadata + -> ReaderT + SqlBackend + m + ( Key PkgRecord + , [Category] + , [Version] + , Version + , [(Key PkgRecord, Text, Version)] + ) + getPackageDependencies osPredicate PackageMetadata { packageMetadataPkgRecord = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion } + = do + let pkgId = entityKey pkg + let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions + let pkgCategories' = entityVal <$> pkgCategories + pkgDepInfo <- getPkgDependencyData pkgId pkgVersion + pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo + let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions + res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo + pure $ (pkgId, pkgCategories', pkgVersions', pkgVersion, res) + constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) + => ( Key PkgRecord + , [Category] + , [Version] + , Version + , [(Key PkgRecord, Text, Version)] + ) + -> m PackageRes constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do settings <- ask @_ @_ @AppSettings let pkgId = unPkgRecordKey pkgKey manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs -> - runConduit $ bs .| CL.foldMap BS.fromStrict - pure $ PackageRes - { packageResIcon = basicRender $ IconsR pkgId + runConduit $ bs .| CL.foldMap LBS.fromStrict + icon <- loadIcon pkgId pkgVersion + deps <- constructDependenciesApiRes dependencies + pure $ PackageRes { packageResIcon = encodeBase64 icon -- pass through raw JSON Value, we have checked its correct parsing above - , packageResManifest = unsafeFromJust . decode $ manifest - , packageResCategories = categoryName <$> pkgCategories - , packageResInstructions = basicRender $ InstructionsR pkgId - , packageResLicense = basicRender $ LicenseR pkgId - , packageResVersions = pkgVersions - , packageResDependencies = HM.fromList $ constructDependenciesApiRes dependencies - } - constructDependenciesApiRes :: [(Key PkgRecord, Text, Version)] - -> [(PkgId, DependencyRes)] - constructDependenciesApiRes deps = fmap (\(depKey, depTitle, depVersion) -> do + , packageResManifest = unsafeFromJust . decode $ manifest + , packageResCategories = categoryName <$> pkgCategories + , packageResInstructions = basicRender $ InstructionsR pkgId + , packageResLicense = basicRender $ LicenseR pkgId + , packageResVersions = pkgVersions + , packageResDependencies = HM.fromList deps + } + constructDependenciesApiRes :: (MonadResource m, MonadReader r m, Has PkgRepo r) + => [(Key PkgRecord, Text, Version)] + -> m [(PkgId, DependencyRes)] + constructDependenciesApiRes deps = traverse + (\(depKey, depTitle, depVersion) -> do let depId = unPkgRecordKey depKey - (depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = (basicRender $ IconsR depId) <> [i|?spec==#{depVersion}|]})) deps + icon <- loadIcon depId depVersion + pure (depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = encodeBase64 icon }) + ) + deps + loadIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString + loadIcon pkg version = do + (_, _, src) <- getIcon pkg version + runConduit $ src .| CL.foldMap id basicRender :: RenderRoute a => Route a -> Text -basicRender = TL.toStrict - . TB.toLazyText - . fold - . fmap (mappend (TB.singleton '/') . TB.fromText) - . fst - . renderRoute +basicRender = TL.toStrict . TB.toLazyText . fold . fmap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute diff --git a/src/Handler/Types/Marketplace.hs b/src/Handler/Types/Marketplace.hs index 9f471fb..e3d4bff 100644 --- a/src/Handler/Types/Marketplace.hs +++ b/src/Handler/Types/Marketplace.hs @@ -69,7 +69,7 @@ instance FromJSON PackageRes where pure PackageRes { .. } data DependencyRes = DependencyRes { dependencyResTitle :: Text -- TODO switch to `Text` to display actual title in Marketplace. Confirm with FE that this will not break loading. Perhaps return title and id? - , dependencyResIcon :: URL + , dependencyResIcon :: Text } deriving (Eq, Show) instance ToJSON DependencyRes where