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

Feature/encode icons (#91)

Browse Source 
* base64 encode icon in package response

* adds icons to dependencies

* swap arguments for loadIcon

* remove redundant constraint

Co-authored-by: Keagan McClelland <keagan.mcclelland@gmail.com>
This commit is contained in:
Lucy C
2022-02-08 13:11:05 -07:00
committed by Keagan McClelland
parent f0b958e6df
commit 14d7adc0c9
3 changed files with 89 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
package.yaml
View File

@@ -14,6 +14,7 @@ default-extensions:
dependencies: dependencies:
- base >=4.12 && <5 - base >=4.12 && <5
- base64
- aeson - aeson
- ansi-terminal - ansi-terminal
- attoparsec - attoparsec

140
src/Handler/Marketplace.hs
View File

@@ -25,7 +25,9 @@ import Conduit ( (.|)
, sourceFile , sourceFile
, takeC , takeC
) )
import Control.Monad.Logger ( MonadLogger, logWarn ) import Control.Monad.Logger ( MonadLogger
, logWarn
)
import Control.Monad.Reader.Has ( Has import Control.Monad.Reader.Has ( Has
, ask , ask
) )
@@ -36,10 +38,12 @@ import Data.Aeson ( decode
, eitherDecodeStrict , eitherDecodeStrict
) )
import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.Text as Atto
import Data.ByteArray.Encoding ( Base(Base16)
import Data.ByteArray.Encoding ( Base(..)
, convertToBase , 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.Conduit.List as CL
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import Data.List ( head import Data.List ( head
@@ -61,31 +65,36 @@ import Database.Esqueleto.Experimental
, select , select
, table , table
) )
import Database.Marketplace ( getPkgData import Database.Marketplace ( fetchAllAppVersions
, searchServices
, zipVersions
, fetchAllAppVersions
, fetchLatestApp , fetchLatestApp
, getPkgDependencyData, zipDependencyVersions, zipCategories , getPkgData
, getPkgDependencyData
, searchServices
, zipCategories
, zipDependencyVersions
, zipVersions
) )
import Database.Persist ( PersistUniqueRead(getBy) import Database.Persist ( PersistUniqueRead(getBy)
, insertUnique , insertUnique
) )
import Foundation ( Handler import Foundation ( Handler
, RegistryCtx(appSettings, appConnPool), Route (IconsR, InstructionsR, LicenseR) , RegistryCtx(appConnPool, appSettings)
, Route(InstructionsR, LicenseR)
) )
import Handler.Types.Marketplace import Handler.Types.Marketplace
import Lib.Error ( S9Error(..) import Lib.Error ( S9Error(..) )
) import Lib.PkgRepository ( PkgRepo
import Lib.PkgRepository ( getManifest ) , getIcon
import Lib.Types.AppIndex ( PkgId(PkgId) , getManifest
) )
import Lib.Types.AppIndex ( PkgId(PkgId) )
import Lib.Types.AppIndex ( ) import Lib.Types.AppIndex ( )
import Lib.Types.Category ( CategoryTitle(..) ) import Lib.Types.Category ( CategoryTitle(..) )
import Lib.Types.Emver ( Version import Lib.Types.Emver ( Version
, VersionRange
, parseRange , parseRange
, parseVersion , parseVersion
, satisfies, VersionRange , satisfies
) )
import Model ( Category(..) import Model ( Category(..)
, EntityField(..) , EntityField(..)
@@ -107,31 +116,32 @@ import UnliftIO.Async ( concurrently
, mapConcurrently , mapConcurrently
) )
import UnliftIO.Directory ( listDirectory ) import UnliftIO.Directory ( listDirectory )
import Util.Shared ( getVersionSpecFromQuery import Util.Shared ( filterDependencyBestVersion
, filterDependencyOsCompatible
, filterLatestVersionFromSpec , filterLatestVersionFromSpec
, filterPkgOsCompatible , filterPkgOsCompatible
, filterDependencyOsCompatible , getVersionSpecFromQuery
, filterDependencyBestVersion
) )
import Yesod.Core ( MonadResource import Yesod.Core ( MonadResource
, RenderRoute(renderRoute)
, TypedContent , TypedContent
, YesodRequest(..) , YesodRequest(..)
, addHeader , addHeader
, getRequest , getRequest
, getYesod
, getsYesod , getsYesod
, lookupGetParam , lookupGetParam
, respondSource , respondSource
, sendChunkBS , sendChunkBS
, sendResponseStatus , sendResponseStatus
, typeOctet , typeOctet
, getYesod, RenderRoute (renderRoute)
) )
import Yesod.Persist ( YesodDB ) import Yesod.Persist ( YesodDB )
import Yesod.Persist.Core ( YesodPersist(runDB) ) import Yesod.Persist.Core ( YesodPersist(runDB) )
getInfoR :: Handler InfoRes getInfoR :: Handler InfoRes
getInfoR = do getInfoR = do
name <- getsYesod $ marketplaceName . appSettings name <- getsYesod $ marketplaceName . appSettings
allCategories <- runDB $ select $ do allCategories <- runDB $ select $ do
cats <- from $ table @Category cats <- from $ table @Category
orderBy [desc (cats ^. CategoryPriority)] orderBy [desc (cats ^. CategoryPriority)]
@@ -163,8 +173,8 @@ getReleaseNotesR = do
case lookup "id" getParameters of case lookup "id" getParameters of
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "<MISSING>") Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "<MISSING>")
Just package -> do Just package -> do
appConnPool <- appConnPool <$> getYesod appConnPool <- appConnPool <$> getYesod
versionRecords <- runDB $ fetchAllAppVersions appConnPool (PkgId package) versionRecords <- runDB $ fetchAllAppVersions appConnPool (PkgId package)
pure $ constructReleaseNotesApiRes versionRecords pure $ constructReleaseNotesApiRes versionRecords
where where
constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes
@@ -205,7 +215,7 @@ getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest getParameters <- reqGetParams <$> getRequest
case lookup "ids" getParameters of case lookup "ids" getParameters of
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>") Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>")
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) Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
Right p -> do Right p -> do
let packageList = (, Nothing) <$> p let packageList = (, Nothing) <$> p
@@ -315,42 +325,66 @@ getPackageListR = do
$logWarn (show e) $logWarn (show e)
sendResponseStatus status400 e sendResponseStatus status400 e
Right v -> pure $ Just v 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 :: (MonadIO m, MonadLogger m)
getPackageDependencies osPredicate PackageMetadata { packageMetadataPkgRecord = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion} = do => (Version -> Bool)
let pkgId = entityKey pkg -> PackageMetadata
let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions -> ReaderT
let pkgCategories' = entityVal <$> pkgCategories SqlBackend
pkgDepInfo <- getPkgDependencyData pkgId pkgVersion m
pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo ( Key PkgRecord
let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions , [Category]
res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo , [Version]
pure $ (pkgId, pkgCategories', pkgVersions', pkgVersion, res) , Version
constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r) => (Key PkgRecord, [Category], [Version], Version, [(Key PkgRecord, Text, Version)]) -> m PackageRes , [(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 constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do
settings <- ask @_ @_ @AppSettings settings <- ask @_ @_ @AppSettings
let pkgId = unPkgRecordKey pkgKey let pkgId = unPkgRecordKey pkgKey
manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs -> manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs ->
runConduit $ bs .| CL.foldMap BS.fromStrict runConduit $ bs .| CL.foldMap LBS.fromStrict
pure $ PackageRes icon <- loadIcon pkgId pkgVersion
{ packageResIcon = basicRender $ IconsR pkgId deps <- constructDependenciesApiRes dependencies
pure $ PackageRes { packageResIcon = encodeBase64 icon
-- pass through raw JSON Value, we have checked its correct parsing above -- pass through raw JSON Value, we have checked its correct parsing above
, packageResManifest = unsafeFromJust . decode $ manifest , packageResManifest = unsafeFromJust . decode $ manifest
, packageResCategories = categoryName <$> pkgCategories , packageResCategories = categoryName <$> pkgCategories
, packageResInstructions = basicRender $ InstructionsR pkgId , packageResInstructions = basicRender $ InstructionsR pkgId
, packageResLicense = basicRender $ LicenseR pkgId , packageResLicense = basicRender $ LicenseR pkgId
, packageResVersions = pkgVersions , packageResVersions = pkgVersions
, packageResDependencies = HM.fromList $ constructDependenciesApiRes dependencies , packageResDependencies = HM.fromList deps
} }
constructDependenciesApiRes :: [(Key PkgRecord, Text, Version)] constructDependenciesApiRes :: (MonadResource m, MonadReader r m, Has PkgRepo r)
-> [(PkgId, DependencyRes)] => [(Key PkgRecord, Text, Version)]
constructDependenciesApiRes deps = fmap (\(depKey, depTitle, depVersion) -> do -> m [(PkgId, DependencyRes)]
constructDependenciesApiRes deps = traverse
(\(depKey, depTitle, depVersion) -> do
let depId = unPkgRecordKey depKey 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 :: RenderRoute a => Route a -> Text
basicRender = TL.toStrict basicRender = TL.toStrict . TB.toLazyText . fold . fmap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute
. TB.toLazyText
. fold
. fmap (mappend (TB.singleton '/') . TB.fromText)
. fst
. renderRoute

2
src/Handler/Types/Marketplace.hs
View File

@@ -69,7 +69,7 @@ instance FromJSON PackageRes where
pure PackageRes { .. } pure PackageRes { .. }
data DependencyRes = DependencyRes 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? { 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) deriving (Eq, Show)
instance ToJSON DependencyRes where instance ToJSON DependencyRes where