diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 3581871..dadd33b 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 ) @@ -37,11 +39,11 @@ import Data.Aeson ( decode ) import qualified Data.Attoparsec.Text as Atto -import Data.ByteString.Base64 -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 @@ -63,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, getIcon, PkgRepo ) -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(..) @@ -109,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)] @@ -165,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 @@ -207,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 @@ -317,47 +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, Has PkgRepo 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 + runConduit $ bs .| CL.foldMap LBS.fromStrict icon <- loadIcon pkgVersion pkgId - pure $ PackageRes - { packageResIcon = encodeBase64 icon + 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 depVersion depId + pure (depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = encodeBase64 icon }) + ) + deps loadIcon :: (Monad m, MonadResource m, MonadReader r m, Has PkgRepo r) => Version -> PkgId -> m ByteString loadIcon version pkg = 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