diff --git a/src/Application.hs b/src/Application.hs index ffa7c46..cd52fcc 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -132,13 +132,14 @@ makeFoundation appSettings = do mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation") logFunc = messageLoggerSource tempFoundation appLogger - stop <- runLoggingT (runReaderT watchPkgRepoRoot appSettings) logFunc createDirectoryIfMissing True (errorLogRoot appSettings) -- Create the database connection pool pool <- flip runLoggingT logFunc $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) + stop <- runLoggingT (runReaderT (watchPkgRepoRoot pool) appSettings) logFunc + -- Preform database migration using application logging settings runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index 4e3d9d3..a87ea80 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -14,6 +14,7 @@ import Database.Esqueleto.Experimental ( (%) , (&&.) , (++.) + , (:&)(..) , (==.) , (^.) , desc @@ -25,37 +26,28 @@ import Database.Esqueleto.Experimental , orderBy , select , selectSource + , table , val , valList , where_ , (||.) - , Value(unValue) ) -import Database.Esqueleto.Experimental - ( (:&)(..) - , table - ) -import Lib.Types.AppIndex ( VersionInfo(..) - , PkgId +import qualified Database.Persist as P +import Database.Persist.Postgresql + hiding ( (==.) + , getJust + , selectSource + , (||.) ) +import Lib.Types.AppIndex ( PkgId ) import Lib.Types.Category -import Lib.Types.Emver ( Version - , VersionRange - ) +import Lib.Types.Emver ( Version ) import Model import Startlude hiding ( (%) , from , on , yield ) -import qualified Data.HashMap.Internal.Strict as HM -import Handler.Types.Marketplace ( ReleaseNotes(ReleaseNotes) ) -import qualified Database.Persist as P -import Database.Persist.Postgresql - hiding ( (||.) - , selectSource - , (==.) - ) searchServices :: (MonadResource m, MonadIO m) => Maybe CategoryTitle @@ -101,46 +93,69 @@ getPkgData pkgs = selectSource $ do where_ (pkgData ^. PkgRecordId `in_` valList (PkgRecordKey <$> pkgs)) pure pkgData +getPkgDependencyData :: MonadIO m + => Key PkgRecord + -> Version + -> ReaderT SqlBackend m ([(Entity PkgDependency, Entity PkgRecord)]) +getPkgDependencyData pkgId pkgVersion = select $ do + pd <- from + (do + (pkgDepRecord :& depPkgRecord) <- + from + $ table @PkgDependency + `innerJoin` table @PkgRecord + `on` (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId) + where_ (pkgDepRecord ^. PkgDependencyPkgId ==. (val pkgId)) + where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion) + pure (pkgDepRecord, depPkgRecord) + ) + pure pd + +zipCategories :: MonadUnliftIO m + => ConduitT + (Entity PkgRecord, [Entity VersionRecord]) + (Entity PkgRecord, [Entity VersionRecord], [Entity Category]) + (ReaderT SqlBackend m) + () +zipCategories = awaitForever $ \(pkg, vers) -> do + let pkgDbId = entityKey pkg + raw <- lift $ select $ do + (sc :& cat) <- + from + $ table @PkgCategory + `innerJoin` table @Category + `on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) + where_ (sc ^. PkgCategoryPkgId ==. val pkgDbId) + pure cat + yield (pkg, vers, raw) + zipVersions :: MonadUnliftIO m => ConduitT (Entity PkgRecord) (Entity PkgRecord, [Entity VersionRecord]) (ReaderT SqlBackend m) () -zipVersions = awaitForever $ \i -> do - let appDbId = entityKey i +zipVersions = awaitForever $ \pkg -> do + let appDbId = entityKey pkg res <- lift $ select $ do v <- from $ table @VersionRecord where_ $ v ^. VersionRecordPkgId ==. val appDbId + -- first value in list will be latest version + orderBy [desc (v ^. VersionRecordNumber)] pure v - yield (i, res) + yield (pkg, res) -filterOsCompatible :: Monad m - => (Version -> Bool) - -> ConduitT - (Entity PkgRecord, [Entity VersionRecord], VersionRange) - (Entity PkgRecord, [Entity VersionRecord], VersionRange) - m - () -filterOsCompatible p = awaitForever $ \(app, versions, requestedVersion) -> do - let compatible = filter (p . versionRecordOsVersion . entityVal) versions - when (not $ null compatible) $ yield (app, compatible, requestedVersion) +zipDependencyVersions :: (Monad m, MonadIO m) + => (Entity PkgDependency, Entity PkgRecord) + -> ReaderT SqlBackend m (Entity PkgDependency, Entity PkgRecord, [Entity VersionRecord]) +zipDependencyVersions (pkgDepRecord, depRecord) = do + let pkgDbId = entityKey $ depRecord + depVers <- select $ do + v <- from $ table @VersionRecord + where_ $ v ^. VersionRecordPkgId ==. val pkgDbId + pure v + pure $ (pkgDepRecord, depRecord, depVers) - -fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m ([VersionInfo], ReleaseNotes) +fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord] fetchAllAppVersions appConnPool appId = do entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool - let vers = entityVal <$> entityAppVersions - let vv = mapSVersionToVersionInfo vers - let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv - pure $ (sortOn (Down . versionInfoVersion) vv, mappedVersions) - where - mapSVersionToVersionInfo :: [VersionRecord] -> [VersionInfo] - mapSVersionToVersionInfo sv = do - (\v -> VersionInfo { versionInfoVersion = versionRecordNumber v - , versionInfoReleaseNotes = versionRecordReleaseNotes v - , versionInfoDependencies = HM.empty - , versionInfoOsVersion = versionRecordOsVersion v - , versionInfoInstallAlert = Nothing - } - ) - <$> sv + pure $ entityVal <$> entityAppVersions fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord)) fetchLatestApp appId = fmap headMay . sortResults . select $ do @@ -152,19 +167,3 @@ fetchLatestApp appId = fmap headMay . sortResults . select $ do where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId)) pure (service, version) where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd) - - -fetchAppCategories :: MonadIO m => [PkgId] -> ReaderT SqlBackend m (HM.HashMap PkgId [Category]) -fetchAppCategories appIds = do - raw <- select $ do - (sc :& app :& cat) <- - from - $ table @PkgCategory - `innerJoin` table @PkgRecord - `on` (\(sc :& app) -> sc ^. PkgCategoryPkgId ==. app ^. PkgRecordId) - `innerJoin` table @Category - `on` (\(sc :& _ :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) - where_ (sc ^. PkgCategoryPkgId `in_` valList (PkgRecordKey <$> appIds)) - pure (app ^. PkgRecordId, cat) - let ls = fmap (first (unPkgRecordKey . unValue) . second (pure . entityVal)) raw - pure $ HM.fromListWith (++) ls diff --git a/src/Foundation.hs b/src/Foundation.hs index 44e1393..4d4db48 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Foundation where import Startlude hiding ( Handler ) @@ -75,9 +76,6 @@ instance Has AppSettings RegistryCtx where extract = appSettings update f ctx = ctx { appSettings = f (appSettings ctx) } - - - setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 9e1be6d..96da839 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -25,21 +25,11 @@ import Conduit ( (.|) , sinkList , sourceFile , takeC - , MonadUnliftIO - ) -import Control.Monad.Except.CoHas ( liftEither ) - -import Control.Parallel.Strategies ( parMap - , rpar + ) import Crypto.Hash ( SHA256 ) import Crypto.Hash.Conduit ( hashFile ) -import Data.Aeson ( (.:) - , FromJSON(parseJSON) - , KeyValue((.=)) - , ToJSON(toJSON) - , Value(String) - , decode +import Data.Aeson ( decode , eitherDecode , eitherDecodeStrict ) @@ -54,7 +44,6 @@ import Data.List ( head , lookup , sortOn ) -import Data.Semigroup ( Max(Max, getMax) ) import Data.String.Interpolate.IsString ( i ) import qualified Data.Text as T @@ -68,15 +57,13 @@ import Database.Esqueleto.Experimental , select , table ) -import Database.Marketplace ( filterOsCompatible - , getPkgData +import Database.Marketplace ( getPkgData , searchServices , zipVersions , fetchAllAppVersions , fetchLatestApp - , fetchAppCategories + , getPkgDependencyData, zipDependencyVersions, zipCategories ) -import qualified Database.Persist as P import Database.Persist ( PersistUniqueRead(getBy) , insertUnique ) @@ -84,17 +71,16 @@ import Foundation ( Handler , RegistryCtx(appSettings, appConnPool) ) import Lib.Error ( S9Error(..) - , toStatus + ) import Lib.PkgRepository ( getManifest ) import Lib.Types.AppIndex ( PkgId(PkgId) - , PackageDependency(packageDependencyVersion) - , PackageManifest(packageManifestDependencies) + + ) import Lib.Types.AppIndex ( ) import Lib.Types.Category ( CategoryTitle(..) ) -import Lib.Types.Emver ( (<||) - , Version +import Lib.Types.Emver ( Version , VersionRange(Any) , parseRange , parseVersion @@ -103,7 +89,7 @@ import Lib.Types.Emver ( (<||) import Model ( Category(..) , EntityField(..) , EosHash(EosHash, eosHashHash) - , Key(PkgRecordKey, unPkgRecordKey) + , Key(unPkgRecordKey) , OsVersion(..) , PkgRecord(..) , Unique(UniqueVersion) @@ -120,7 +106,7 @@ import UnliftIO.Async ( concurrently , mapConcurrently ) import UnliftIO.Directory ( listDirectory ) -import Util.Shared ( getVersionSpecFromQuery ) +import Util.Shared ( getVersionSpecFromQuery, filterLatestVersionFromSpec, filterPkgOsCompatible, filterDependencyOsCompatible, filterDependencyBestVersion ) import Yesod.Core ( MonadResource , TypedContent , YesodRequest(..) @@ -136,13 +122,7 @@ import Yesod.Core ( MonadResource ) import Yesod.Persist ( YesodDB ) import Yesod.Persist.Core ( YesodPersist(runDB) ) -import Data.Tuple.Extra hiding ( second - , first - , (&&&) - ) import Control.Monad.Logger -import Database.Persist.Sql ( runSqlPool ) -import Database.Persist.Postgresql ( ConnectionPool ) import Control.Monad.Reader.Has ( Has , ask ) @@ -182,8 +162,12 @@ getReleaseNotesR = do Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "") Just package -> do appConnPool <- appConnPool <$> getYesod - (_, notes) <- runDB $ fetchAllAppVersions appConnPool (PkgId package) - pure notes + versionRecords <- runDB $ fetchAllAppVersions appConnPool (PkgId package) + pure $ constructReleaseNotesApiRes versionRecords + where + constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes + constructReleaseNotesApiRes vers = do + ReleaseNotes $ HM.fromList $ sortOn (Down) $ (versionRecordNumber &&& versionRecordReleaseNotes) <$> vers getEosR :: Handler TypedContent getEosR = do @@ -213,6 +197,7 @@ getEosR = do void $ insertUnique (EosHash v t) -- lazily populate pure t +-- TODO refactor with conduit getVersionLatestR :: Handler VersionLatestRes getVersionLatestR = do getParameters <- reqGetParams <$> getRequest @@ -240,13 +225,6 @@ getPackageListR = do Nothing -> const True Just v -> flip satisfies v pkgIds <- getPkgIdsQuery - -- deep info - -- generate data from db - -- filter os - -- filter from request - -- shallow info - generate get deps - -- transformations - -- assemble api response filteredPackages <- case pkgIds of Nothing -> do -- query for all @@ -258,8 +236,11 @@ getPackageListR = do $ runConduit $ searchServices category query .| zipVersions - .| mapC (\(a, vs) -> (,,) a vs Any) - .| filterOsCompatible osPredicate + .| zipCategories + -- if no packages are specified, the VersionRange is implicitly `*` + .| mapC (\(a, vs, cats) -> (a, vs, cats,Any)) + .| filterLatestVersionFromSpec + .| filterPkgOsCompatible osPredicate -- pages start at 1 for some reason. TODO: make pages start at 0 .| (dropC (limit' * (page - 1)) *> takeC limit') .| sinkList @@ -267,26 +248,21 @@ getPackageListR = do -- for each item in list get best available from version range let vMap = (packageReqId &&& packageReqVersion) <$> packages' runDB + -- TODO could probably be better with sequenceConduits . runConduit $ getPkgData (packageReqId <$> packages') .| zipVersions - .| mapC - (\(a, vs) -> - let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) vMap - in (a, filter ((<|| spec) . versionRecordNumber . entityVal) vs, spec) - ) - .| filterOsCompatible osPredicate + .| zipCategories + .| mapC (\(a, vs, cats) -> do + let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) vMap + (a, vs, cats, spec) + ) + .| filterLatestVersionFromSpec + .| filterPkgOsCompatible osPredicate .| sinkList - (keys, packageMetadata) <- runDB $ createPackageMetadata filteredPackages - appConnPool <- appConnPool <$> getYesod - serviceDetailResult <- mapConcurrently (getServiceDetails osPredicate appConnPool packageMetadata) keys - let (errors, res) = partitionEithers serviceDetailResult - case errors of - x : xs -> do - -- log all errors but just throw first error until Validation implemented - TODO https://hackage.haskell.org/package/validation - for_ xs (\e -> $logWarn [i|Get package list errors: #{e}|]) - sendResponseStatus (toStatus x) x - [] -> pure $ PackageListRes res + -- NOTE: if a package's dependencies do not meet the system requirements, it is currently omitted from the list + pkgsWithDependencies <- runDB $ mapConcurrently (getPackageDependencies osPredicate) filteredPackages + PackageListRes <$> mapConcurrently constructPackageListApiRes pkgsWithDependencies where defaults = PackageListDefaults { packageListOrder = DESC @@ -342,104 +318,36 @@ getPackageListR = do $logWarn (show e) sendResponseStatus status400 e Right v -> pure $ Just v - -mergeDupes :: ([Version], VersionRange) -> ([Version], VersionRange) -> ([Version], VersionRange) -mergeDupes (vs, vr) (vs', _) = (,) ((++) vs vs') vr - -createPackageMetadata :: (MonadReader r m, MonadIO m) - => [(Entity PkgRecord, [Entity VersionRecord], VersionRange)] - -> ReaderT - SqlBackend - m - ([PkgId], HM.HashMap PkgId (([Version], VersionRange), [CategoryTitle])) -createPackageMetadata pkgs = do - let keys = unPkgRecordKey . entityKey . fst3 <$> pkgs - cats <- fetchAppCategories keys - let vers = - pkgs - <&> first3 (unPkgRecordKey . entityKey) - <&> second3 (sortOn Down . fmap (versionRecordNumber . entityVal)) - <&> (\(a, vs, vr) -> (,) a $ (,) vs vr) - & HM.fromListWith mergeDupes - pure $ (keys, HM.intersectionWith (,) vers (categoryName <<$>> cats)) - -getServiceDetails :: (MonadResource m, MonadReader r m, MonadLogger m, Has AppSettings r, MonadUnliftIO m) - => (Version -> Bool) - -> ConnectionPool - -> (HM.HashMap PkgId (([Version], VersionRange), [CategoryTitle])) - -> PkgId - -> m (Either S9Error PackageRes) -getServiceDetails osPredicate appConnPool metadata pkg = runExceptT $ do - settings <- ask - packageMetadata <- case HM.lookup pkg metadata of - Nothing -> liftEither . Left $ NotFoundE [i|#{pkg} not found.|] - Just m -> pure m - let domain = registryHostname settings - let versionInfo = fst $ (HM.!) metadata pkg - version <- case snd versionInfo of - Any -> do - -- grab first value, which will be the latest version - case fst versionInfo of - [] -> liftEither . Left $ NotFoundE $ [i|No latest version found for #{pkg}|] - x : _ -> pure x - spec -> case headMay . sortOn Down $ filter (`satisfies` spec) $ fst versionInfo of - Nothing -> liftEither . Left $ NotFoundE [i|No version for #{pkg} satisfying #{spec}|] - Just v -> pure v - manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs -> - runConduit $ bs .| CL.foldMap BS.fromStrict - case eitherDecode manifest of - Left _ -> liftEither . Left $ AssetParseE [i|#{pkg}:manifest|] (decodeUtf8 $ BS.toStrict manifest) - Right m -> do - let depVerList = (fst &&& (packageDependencyVersion . snd)) <$> (HM.toList $ packageManifestDependencies m) - (_, depMetadata) <- lift $ runSqlPool (createPackageMetadata =<< getDependencies depVerList) appConnPool - let (errors, deps) = partitionEithers $ parMap - rpar - (mapDependencyMetadata domain $ (HM.union depMetadata metadata)) - (HM.toList $ packageManifestDependencies m) - case errors of - _ : xs -> liftEither . Left $ DepMetadataE xs - [] -> pure $ PackageRes { packageResIcon = [i|https://#{domain}/package/icon/#{pkg}|] - -- pass through raw JSON Value, we have checked its correct parsing above - , packageResManifest = unsafeFromJust . decode $ manifest - , packageResCategories = snd packageMetadata - , packageResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|] - , packageResLicense = [i|https://#{domain}/package/license/#{pkg}|] - , packageResVersions = fst . fst $ packageMetadata - , packageResDependencies = HM.fromList deps - } - where - getDependencies :: (MonadResource m, MonadUnliftIO m) - => [(PkgId, VersionRange)] - -> ReaderT SqlBackend m [(Entity PkgRecord, [Entity VersionRecord], VersionRange)] - getDependencies deps = - runConduit - $ getPkgData (fst <$> deps) - .| zipVersions - .| mapC - (\(a, vs) -> - let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) deps - in (a, filter ((<|| spec) . versionRecordNumber . entityVal) vs, spec) - ) - .| filterOsCompatible osPredicate - .| sinkList - -mapDependencyMetadata :: Text - -> HM.HashMap PkgId (([Version], VersionRange), [CategoryTitle]) - -> (PkgId, PackageDependency) - -> Either Text (PkgId, DependencyRes) -mapDependencyMetadata domain metadata (appId, depInfo) = do - depMetadata <- case HM.lookup appId metadata of - Nothing -> Left [i|dependency metadata for #{appId} not found.|] - Just m -> pure m - -- get best version from VersionRange of dependency - let satisfactory = filter (<|| packageDependencyVersion depInfo) (fst . fst $ depMetadata) - let best = getMax <$> foldMap (Just . Max) satisfactory - version <- case best of - Nothing -> Left [i|No satisfactory version for dependent package #{appId}|] - Just v -> pure v - pure - ( appId - , DependencyRes { dependencyResTitle = appId - , dependencyResIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|] + getPackageDependencies :: (MonadIO m, MonadLogger m) => (Version -> Bool) -> (Entity PkgRecord, [Entity VersionRecord], [Entity Category], Version) -> ReaderT SqlBackend m (Key PkgRecord, [Category], [Version], Version, [(Key PkgRecord, Text, Version)]) + getPackageDependencies osPredicate (pkg, pkgVersions, pkgCategories, 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 :: (Monad m, MonadResource m, MonadReader r m, Has AppSettings r) => (Key PkgRecord, [Category], [Version], Version, [(Key PkgRecord, Text, Version)]) -> m PackageRes + constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do + settings <- ask + let pkgId = unPkgRecordKey pkgKey + let domain = registryHostname settings + manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs -> + runConduit $ bs .| CL.foldMap BS.fromStrict + pure $ PackageRes { packageResIcon = [i|https://#{domain}/package/icon/#{pkgId}|] + -- pass through raw JSON Value, we have checked its correct parsing above + , packageResManifest = unsafeFromJust . decode $ manifest + , packageResCategories = categoryName <$> pkgCategories + , packageResInstructions = [i|https://#{domain}/package/instructions/#{pkgId}|] + , packageResLicense = [i|https://#{domain}/package/license/#{pkgId}|] + , packageResVersions = pkgVersions + , packageResDependencies = HM.fromList $ constructDependenciesApiRes domain dependencies } - ) + constructDependenciesApiRes :: Text + -> [(Key PkgRecord, Text, Version)] + -> [(PkgId, DependencyRes)] + constructDependenciesApiRes domain deps = fmap (\(depKey, depTitle, depVersion) -> do + let depId = unPkgRecordKey depKey + (depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = [i|https://#{domain}/package/icon/#{depId}?spec==#{depVersion}|]})) deps + diff --git a/src/Handler/Types/Marketplace.hs b/src/Handler/Types/Marketplace.hs index 8aad326..3a9c148 100644 --- a/src/Handler/Types/Marketplace.hs +++ b/src/Handler/Types/Marketplace.hs @@ -1,15 +1,16 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} + module Handler.Types.Marketplace where -import Lib.Types.Category ( CategoryTitle ) import Data.Aeson +import qualified Data.HashMap.Internal.Strict as HM +import Lib.Types.AppIndex ( PkgId ) +import Lib.Types.Category ( CategoryTitle ) +import Lib.Types.Emver ( Version + , VersionRange + ) import Startlude import Yesod -import qualified Data.HashMap.Internal.Strict as HM -import Lib.Types.Emver ( VersionRange - , Version - ) -import Lib.Types.AppIndex ( PkgId ) type URL = Text @@ -22,12 +23,12 @@ instance ToContent CategoryRes where instance ToTypedContent CategoryRes where toTypedContent = toTypedContent . toJSON data PackageRes = PackageRes - { packageResIcon :: URL - , packageResManifest :: Data.Aeson.Value -- PackageManifest - , packageResCategories :: [CategoryTitle] - , packageResInstructions :: URL - , packageResLicense :: URL - , packageResVersions :: [Version] + { packageResIcon :: URL + , packageResManifest :: Data.Aeson.Value -- PackageManifest + , packageResCategories :: [CategoryTitle] + , packageResInstructions :: URL + , packageResLicense :: URL + , packageResVersions :: [Version] , packageResDependencies :: HM.HashMap PkgId DependencyRes } deriving (Show, Generic) @@ -60,7 +61,7 @@ instance FromJSON PackageRes where packageResDependencies <- o .: "dependency-metadata" pure PackageRes { .. } data DependencyRes = DependencyRes - { dependencyResTitle :: PkgId + { 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 } deriving (Eq, Show) diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index acc85bf..5c9e9a6 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -8,7 +8,6 @@ import Startlude import Data.String.Interpolate.IsString import Network.HTTP.Types import Yesod.Core -import qualified Data.Text as T type S9ErrT m = ExceptT S9Error m @@ -18,7 +17,6 @@ data S9Error = | NotFoundE Text | InvalidParamsE Text Text | AssetParseE Text Text - | DepMetadataE [Text] deriving (Show, Eq) instance Exception S9Error @@ -31,9 +29,6 @@ toError = \case NotFoundE e -> Error NOT_FOUND [i|#{e}|] InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|] AssetParseE asset found -> Error PARSE_ERROR [i|Could not parse #{asset}: #{found}|] - DepMetadataE errs -> do - let errorText = T.concat errs - Error NOT_FOUND [i|#{errorText}|] data ErrorCode = DATABASE_ERROR @@ -69,4 +64,3 @@ toStatus = \case NotFoundE _ -> status404 InvalidParamsE _ _ -> status400 AssetParseE _ _ -> status500 - DepMetadataE _ -> status404 diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 185a127..672fdc8 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -31,19 +31,33 @@ import qualified Data.Attoparsec.Text as Atto import Data.ByteString ( readFile , writeFile ) +import qualified Data.HashMap.Strict as HM import Data.String.Interpolate.IsString ( i ) import qualified Data.Text as T +import Data.Time ( getCurrentTime ) +import Database.Esqueleto.Experimental + ( ConnectionPool + , insertUnique + , runSqlPool + ) import Lib.Error ( S9Error(NotFoundE) ) import qualified Lib.External.AppMgr as AppMgr -import Lib.Types.AppIndex ( PkgId(..) - , PackageManifest(packageManifestIcon) +import Lib.Types.AppIndex ( PackageManifest + ( packageManifestIcon + , packageManifestId + , packageManifestVersion + ) + , PkgId(..) + , packageDependencyVersion + , packageManifestDependencies ) import Lib.Types.Emver ( Version , VersionRange , parseVersion , satisfies ) +import Model import Startlude ( ($) , (&&) , (.) @@ -62,14 +76,18 @@ import Startlude ( ($) , MonadReader , Show , SomeException(..) + , Traversable(traverse) , filter , find + , first , for_ + , fst , headMay , not , partitionEithers , pure , show + , snd , sortOn , throwIO , void @@ -111,7 +129,6 @@ import Yesod.Core.Content ( typeGif , typeSvg ) import Yesod.Core.Types ( ContentType ) - data ManifestParseException = ManifestParseException FilePath deriving Show instance Exception ManifestParseException @@ -143,10 +160,28 @@ getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) -> m (Maybe Version) getBestVersion pkg spec = headMay . sortOn Down <$> getViableVersions pkg spec --- TODO add loadDependencies +loadPkgDependencies :: MonadUnliftIO m => ConnectionPool -> PackageManifest -> m () +loadPkgDependencies appConnPool manifest = do + let pkgId = packageManifestId manifest + let pkgVersion = packageManifestVersion manifest + let deps = packageManifestDependencies manifest + time <- liftIO getCurrentTime + let deps' = first PkgRecordKey <$> HM.toList deps + _ <- traverse + (\d -> + (runSqlPool + ( insertUnique + $ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d) + ) + appConnPool + ) + ) + deps' + pure () + -- extract all package assets into their own respective files -extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m () -extractPkg fp = handle @_ @SomeException cleanup $ do +extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () +extractPkg pool fp = handle @_ @SomeException cleanup $ do $logInfo [i|Extracting package: #{fp}|] PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask let pkgRoot = takeDirectory fp @@ -169,6 +204,7 @@ extractPkg fp = handle @_ @SomeException cleanup $ do Just x -> case takeExtension (T.unpack x) of "" -> "png" other -> other + loadPkgDependencies pool manifest liftIO $ renameFile (pkgRoot "icon.tmp") (pkgRoot iconDest) hash <- wait pkgHashTask liftIO $ writeFile (pkgRoot "hash.bin") hash @@ -184,8 +220,8 @@ extractPkg fp = handle @_ @SomeException cleanup $ do mapConcurrently_ (removeFile . (pkgRoot )) toRemove throwIO e -watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => m (IO Bool) -watchPkgRepoRoot = do +watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool) +watchPkgRepoRoot pool = do $logInfo "Starting FSNotify Watch Manager" root <- asks pkgRepoFileRoot runInIO <- askRunInIO @@ -195,7 +231,7 @@ watchPkgRepoRoot = do let pkg = eventPath evt -- TODO: validate that package path is an actual s9pk and is in a correctly conforming path. void . forkIO $ runInIO $ do - (extractPkg pkg) + (extractPkg pool pkg) takeMVar box stop pure $ tryPutMVar box () diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index a12f296..f45d97a 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -17,7 +17,6 @@ import Data.Aeson ( (.:) , ToJSON(..) , ToJSONKey(..) , withObject - , eitherDecode ) import qualified Data.ByteString.Lazy as BS import Data.Functor.Contravariant ( contramap ) @@ -77,7 +76,6 @@ data VersionInfo = VersionInfo } deriving (Eq, Show) --- TODO rename to PackageDependencyInfo data PackageDependency = PackageDependency { packageDependencyOptional :: Maybe Text , packageDependencyVersion :: VersionRange diff --git a/src/Model.hs b/src/Model.hs index 745def9..48472c4 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -17,7 +17,6 @@ import Lib.Types.Category import Lib.Types.Emver import Orphans.Emver ( ) import Startlude -import Yesod.Persist ( PersistFilter(Eq) ) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| PkgRecord @@ -92,13 +91,14 @@ ErrorLogRecord message Text incidents Word32 UniqueLogRecord epoch commitHash sourceFile line target level message + PkgDependency createdAt UTCTime pkgId PkgRecordId pkgVersion Version depId PkgRecordId depVersionRange VersionRange - UniquePkgVersion pkgId pkgVersion + UniquePkgDepVersion pkgId pkgVersion depId deriving Eq deriving Show |] diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 0892f15..2a0ae29 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -1,20 +1,45 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} module Util.Shared where -import Startlude hiding ( Handler ) +import Startlude hiding ( Handler + , yield + ) import qualified Data.Text as T import Network.HTTP.Types import Yesod.Core +import Conduit ( ConduitT + , awaitForever + , yield + ) import Control.Monad.Reader.Has ( Has ) +import Data.Semigroup ( Max(Max) + , getMax + ) +import Data.String.Interpolate.IsString + ( i ) +import Database.Esqueleto.Experimental + ( Entity + , Key + , entityKey + , entityVal + ) import Foundation import Lib.PkgRepository ( PkgRepo , getHash ) import Lib.Types.AppIndex ( PkgId ) import Lib.Types.Emver +import Model ( Category + , PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange) + , PkgRecord(pkgRecordTitle) + , VersionRecord(versionRecordNumber, versionRecordOsVersion) + , pkgDependencyPkgId + ) getVersionSpecFromQuery :: Handler VersionRange getVersionSpecFromQuery = do @@ -32,3 +57,53 @@ orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a orThrow action other = action >>= \case Nothing -> other Just x -> pure x + + +filterPkgOsCompatible :: Monad m + => (Version -> Bool) + -> ConduitT + (Entity PkgRecord, [Entity VersionRecord], [Entity Category], Version) + (Entity PkgRecord, [Entity VersionRecord], [Entity Category], Version) + m + () +filterPkgOsCompatible p = awaitForever $ \(app, versions, cats, requestedVersion) -> do + let compatible = filter (p . versionRecordOsVersion . entityVal) versions + when (not $ null compatible) $ yield (app, compatible, cats, requestedVersion) + +filterDependencyOsCompatible :: (Version -> Bool) + -> (Entity PkgDependency, Entity PkgRecord, [Entity VersionRecord]) + -> (Entity PkgDependency, Entity PkgRecord, [Entity VersionRecord]) +filterDependencyOsCompatible p (pkgDeps, pkg, versions) = do + let compatible = filter (p . versionRecordOsVersion . entityVal) versions + (pkgDeps, pkg, compatible) + +filterLatestVersionFromSpec :: (Monad m, MonadLogger m) + => ConduitT + (Entity PkgRecord, [Entity VersionRecord], [Entity Category], VersionRange) + (Entity PkgRecord, [Entity VersionRecord], [Entity Category], Version) + m + () +filterLatestVersionFromSpec = awaitForever $ \(a, vs, cats, spec) -> do + let pkgId = entityKey a + case headMay . sortOn Down $ filter (`satisfies` spec) $ fmap (versionRecordNumber . entityVal) vs of + Nothing -> $logInfo [i|No version for #{pkgId} satisfying #{spec}|] + Just v -> yield $ (,,,) a vs cats v + +-- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package) +filterDependencyBestVersion :: MonadLogger m + => (Entity PkgDependency, Entity PkgRecord, [Entity VersionRecord]) + -> m (Maybe (Key PkgRecord, Text, Version)) +filterDependencyBestVersion (pkgDepRecord, depPkgRecord, depVersions) = do + -- get best version from VersionRange of dependency + let pkgId = pkgDependencyPkgId $ entityVal pkgDepRecord + let depId = pkgDependencyDepId $ entityVal pkgDepRecord + let depTitle = pkgRecordTitle $ entityVal depPkgRecord + let satisfactory = filter (<|| (pkgDependencyDepVersionRange $ entityVal pkgDepRecord)) + (versionRecordNumber . entityVal <$> depVersions) + case getMax <$> foldMap (Just . Max) satisfactory of + -- QUESTION is this an acceptable transformation here? These are the only values that we care about after this filter. + Just bestVersion -> pure $ Just (depId, depTitle, bestVersion) + Nothing -> do + $logInfo [i|No satisfactory version of #{depId} for dependent package #{pkgId}|] + -- TODO it would be better if we could return the requirements for display + pure Nothing diff --git a/stack.yaml b/stack.yaml index 9739af5..14d4398 100644 --- a/stack.yaml +++ b/stack.yaml @@ -44,6 +44,7 @@ extra-deps: - esqueleto-3.5.1.0 - monad-logger-extras-0.1.1.1 - wai-request-spec-0.10.2.4 + - data-tree-print-0.1.0.2 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/test/Handler/AppSpec.hs b/test/Handler/AppSpec.hs index b798a09..8951849 100644 --- a/test/Handler/AppSpec.hs +++ b/test/Handler/AppSpec.hs @@ -3,21 +3,19 @@ module Handler.AppSpec ( spec - ) -where + ) where -import Startlude -import Database.Persist.Sql import Data.Maybe +import Database.Persist.Sql +import Startlude -import TestImport -import Model -import Handler.Marketplace -import Seed -import Lib.Types.AppIndex import Data.Aeson import Data.Either.Extra -import Handler.Marketplace ( PackageRes ) +import Handler.Types.Marketplace ( PackageRes(packageResDependencies, packageResManifest) ) +import Lib.Types.AppIndex +import Model +import Seed +import TestImport spec :: Spec spec = do @@ -92,13 +90,13 @@ spec = do setMethod "GET" setUrl ("/package/bitcoind.s9pk?spec==0.20.0" :: Text) statusIs 404 - xdescribe "GET /package/:pkgId with unknown package" $ withApp $ it "fails to get an unregistered app" $ do + describe "GET /package/:pkgId with unknown package" $ withApp $ it "fails to get an unregistered app" $ do _ <- seedBitcoinLndStack request $ do setMethod "GET" setUrl ("/package/tempapp.s9pk?spec=0.0.1" :: Text) statusIs 404 - xdescribe "GET /package/:pkgId with package at unknown version" + describe "GET /package/:pkgId with package at unknown version" $ withApp $ it "fails to get an unregistered app" $ do diff --git a/test/Seed.hs b/test/Seed.hs index ee831f9..90c202e 100644 --- a/test/Seed.hs +++ b/test/Seed.hs @@ -1,25 +1,27 @@ module Seed where -import Startlude ( ($) - , Applicative(pure) - , Maybe(Nothing, Just) - , getCurrentTime - , MonadIO(liftIO) - ) -import Database.Persist.Sql ( PersistStoreWrite(insert_, insertKey, insert) ) -import Model ( Key(PkgRecordKey) - , PkgRecord(PkgRecord) - , Category(Category) +import Database.Persist.Sql ( PersistStoreWrite(insert, insertKey, insert_) ) +import Model ( Category(Category) + , Key(PkgRecordKey) , PkgCategory(PkgCategory) + , PkgDependency(PkgDependency) + , PkgRecord(PkgRecord) , VersionRecord(VersionRecord) ) +import Startlude ( ($) + , Applicative(pure) + , Maybe(Just, Nothing) + , MonadIO(liftIO) + , getCurrentTime + ) -import TestImport ( runDBtest - , RegistryCtx +import Lib.Types.Category ( CategoryTitle(BITCOIN, FEATURED, LIGHTNING) ) +import Prelude ( read ) +import TestImport ( RegistryCtx , SIO , YesodExampleData + , runDBtest ) -import Lib.Types.Category ( CategoryTitle(LIGHTNING, FEATURED, BITCOIN) ) seedBitcoinLndStack :: SIO (YesodExampleData RegistryCtx) () seedBitcoinLndStack = do @@ -73,4 +75,14 @@ seedBitcoinLndStack = do _ <- runDBtest $ insert_ $ PkgCategory time (PkgRecordKey "lnd") btcCat _ <- runDBtest $ insert_ $ PkgCategory time (PkgRecordKey "bitcoind") btcCat _ <- runDBtest $ insert_ $ PkgCategory time (PkgRecordKey "btc-rpc-proxy") btcCat + _ <- runDBtest $ insert_ $ PkgDependency time + (PkgRecordKey "lnd") + "0.13.3.1" + (PkgRecordKey "bitcoind") + (read ">=0.21.1.2 <0.22.0") + _ <- runDBtest $ insert_ $ PkgDependency time + (PkgRecordKey "lnd") + "0.13.3.1" + (PkgRecordKey "btc-rpc-proxy") + (read ">=0.3.2.1 <0.4.0") pure ()