diff --git a/cli/Main.hs b/cli/Main.hs new file mode 100644 index 0000000..8fae644 --- /dev/null +++ b/cli/Main.hs @@ -0,0 +1,7 @@ +module Main where +import Startlude ( IO + , pure + ) + +main :: IO () +main = pure () diff --git a/package.yaml b/package.yaml index 3928e26..3f8d1c1 100644 --- a/package.yaml +++ b/package.yaml @@ -43,6 +43,7 @@ dependencies: - memory - monad-logger - monad-logger-extras + - monad-loops - parallel - persistent - persistent-postgresql @@ -102,7 +103,19 @@ executables: when: - condition: flag(library-only) buildable: false - + embassy-publish: + source-dirs: cli + main: Main.hs + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -fdefer-typed-holes + dependencies: + - start9-registry + when: + - condition: flag(library-only) + buildable: false tests: start9-registry-test: source-dirs: test diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index f8872d1..e393f89 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -9,8 +9,11 @@ import Conduit ( ConduitT , MonadResource , MonadUnliftIO , awaitForever + , leftover , yield ) +import Control.Monad.Loops ( unfoldM ) +import Data.Conduit ( await ) import Database.Esqueleto.Experimental ( (%) , (&&.) @@ -90,10 +93,10 @@ searchServices (Just category) query = selectSource $ do orderBy [desc (services ^. VersionRecordUpdatedAt)] pure services -getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) () +getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () getPkgData pkgs = selectSource $ do - pkgData <- from $ table @PkgRecord - where_ (pkgData ^. PkgRecordId `in_` valList (PkgRecordKey <$> pkgs)) + pkgData <- from $ table @VersionRecord + where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) pure pkgData getPkgDependencyData :: MonadIO m @@ -115,33 +118,34 @@ getPkgDependencyData pkgId pkgVersion = select $ do zipCategories :: MonadUnliftIO m => ConduitT - (Entity PkgRecord, [Entity VersionRecord]) - (Entity PkgRecord, [Entity VersionRecord], [Entity Category]) + (PkgId, [Entity VersionRecord]) + (PkgId, [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) + where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg)) pure cat yield (pkg, vers, raw) -zipVersions :: MonadUnliftIO m - => ConduitT (Entity PkgRecord) (Entity PkgRecord, [Entity VersionRecord]) (ReaderT SqlBackend m) () -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 (pkg, res) +collateVersions :: MonadUnliftIO m + => ConduitT (Entity VersionRecord) (PkgId, [Entity VersionRecord]) (ReaderT SqlBackend m) () +collateVersions = awaitForever $ \v0 -> do + let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0 + let pull = do + mvn <- await + case mvn of + Nothing -> pure Nothing + Just vn -> do + let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal vn + if pkg == pkg' then pure (Just vn) else leftover vn $> Nothing + ls <- unfoldM pull + yield (pkg, v0 : ls) zipDependencyVersions :: (Monad m, MonadIO m) => (Entity PkgDependency, Entity PkgRecord) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index e24cf79..67e59d2 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} module Handler.Admin where import Conduit ( (.|) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 6f8c7f2..cae1bbe 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -5,6 +5,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant <$>" #-} module Handler.Marketplace where @@ -66,14 +68,14 @@ import Database.Esqueleto.Experimental , select , table ) -import Database.Marketplace ( fetchAllAppVersions +import Database.Marketplace ( collateVersions + , fetchAllAppVersions , fetchLatestApp , getPkgData , getPkgDependencyData , searchServices , zipCategories , zipDependencyVersions - , zipVersions ) import Database.Persist ( PersistUniqueRead(getBy) , insertUnique @@ -98,7 +100,7 @@ import Lib.Types.Emver ( Version import Model ( Category(..) , EntityField(..) , EosHash(EosHash, eosHashHash) - , Key(unPkgRecordKey) + , Key(PkgRecordKey, unPkgRecordKey) , OsVersion(..) , PkgRecord(..) , Unique(UniqueVersion) @@ -194,7 +196,7 @@ getEosR = do spec <- getVersionSpecFromQuery root <- getsYesod $ ( "eos") . resourcesDir . appSettings subdirs <- listDirectory root - let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs + let (failures, successes) = partitionEithers $ Atto.parseOnly parseVersion . T.pack <$> subdirs for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] let mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes case mVersion of @@ -254,7 +256,7 @@ getPackageListR = do runDB $ runConduit $ searchServices category query - .| zipVersions + .| collateVersions .| zipCategories -- empty list since there are no requested packages in this case .| filterLatestVersionFromSpec [] @@ -269,7 +271,7 @@ getPackageListR = do -- TODO could probably be better with sequenceConduits . runConduit $ getPkgData (packageReqId <$> packages') - .| zipVersions + .| collateVersions .| zipCategories .| filterLatestVersionFromSpec vMap .| filterPkgOsCompatible osPredicate @@ -343,16 +345,16 @@ getPackageListR = do , Version , [(Key PkgRecord, Text, Version)] ) - getPackageDependencies osPredicate PackageMetadata { packageMetadataPkgRecord = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion } + getPackageDependencies osPredicate PackageMetadata { packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion } = do - let pkgId = entityKey pkg + let pkgId = PkgRecordKey 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) + pure (pkgId, pkgCategories', pkgVersions', pkgVersion, res) constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) => ( Key PkgRecord , [Category] @@ -392,4 +394,4 @@ getPackageListR = do 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 . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute diff --git a/src/Handler/Types/Marketplace.hs b/src/Handler/Types/Marketplace.hs index 9669a5a..9ece0bf 100644 --- a/src/Handler/Types/Marketplace.hs +++ b/src/Handler/Types/Marketplace.hs @@ -129,7 +129,7 @@ instance FromJSON PackageReq where packageReqVersion <- o .: "version" pure PackageReq { .. } data PackageMetadata = PackageMetadata - { packageMetadataPkgRecord :: Entity PkgRecord + { packageMetadataPkgId :: PkgId , packageMetadataPkgVersionRecords :: [Entity VersionRecord] , packageMetadataPkgCategories :: [Entity Category] , packageMetadataPkgVersion :: Version diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index c6b924d..95bc6a4 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -26,7 +26,6 @@ import Data.String.Interpolate.IsString import Database.Esqueleto.Experimental ( Entity , Key - , entityKey , entityVal ) import Foundation @@ -40,7 +39,6 @@ import Lib.PkgRepository ( PkgRepo import Lib.Types.AppIndex ( PkgId ) import Lib.Types.Emver import Model ( Category - , Key(unPkgRecordKey) , PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange) , PkgRecord , VersionRecord(..) @@ -99,10 +97,10 @@ orThrow action other = action >>= \case filterPkgOsCompatible :: Monad m => (Version -> Bool) -> ConduitT PackageMetadata PackageMetadata m () filterPkgOsCompatible p = awaitForever - $ \PackageMetadata { packageMetadataPkgRecord = pkg, packageMetadataPkgVersionRecords = versions, packageMetadataPkgCategories = cats, packageMetadataPkgVersion = requestedVersion } -> + $ \PackageMetadata { packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = versions, packageMetadataPkgCategories = cats, packageMetadataPkgVersion = requestedVersion } -> do let compatible = filter (p . versionRecordOsVersion . entityVal) versions - unless (null compatible) $ yield PackageMetadata { packageMetadataPkgRecord = pkg + unless (null compatible) $ yield PackageMetadata { packageMetadataPkgId = pkg , packageMetadataPkgVersionRecords = compatible , packageMetadataPkgCategories = cats , packageMetadataPkgVersion = requestedVersion @@ -119,18 +117,13 @@ filterDependencyOsCompatible p PackageDependencyMetadata { packageDependencyMeta filterLatestVersionFromSpec :: (Monad m, MonadLogger m) => [(PkgId, VersionRange)] - -> ConduitT - (Entity PkgRecord, [Entity VersionRecord], [Entity Category]) - PackageMetadata - m - () -filterLatestVersionFromSpec versionMap = awaitForever $ \(a, vs, cats) -> do - let pkgId = entityKey a + -> ConduitT (PkgId, [Entity VersionRecord], [Entity Category]) PackageMetadata m () +filterLatestVersionFromSpec versionMap = awaitForever $ \(pkgId, vs, cats) -> do -- if no packages are specified, the VersionRange is implicitly `*` - let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) versionMap + let spec = fromMaybe Any $ lookup pkgId versionMap case headMay . sortOn Down $ filter (`satisfies` spec) $ fmap (versionRecordNumber . entityVal) vs of Nothing -> $logInfo [i|No version for #{pkgId} satisfying #{spec}|] - Just v -> yield $ PackageMetadata { packageMetadataPkgRecord = a + Just v -> yield $ PackageMetadata { packageMetadataPkgId = pkgId , packageMetadataPkgVersionRecords = vs , packageMetadataPkgCategories = cats , packageMetadataPkgVersion = v