adds index/deindex endpoints

cli/Main.hs

@@ -0,0 +1,7 @@
+module Main where
+import           Startlude                      ( IO
+                                                , pure
+                                                )
+
+main :: IO ()
+main = pure ()

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

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
+    pkgData <- from $ table @VersionRecord
-    where_ (pkgData ^. PkgRecordId `in_` valList (PkgRecordKey <$> pkgs))
+    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])
+                     (PkgId, [Entity VersionRecord])
-                     (Entity PkgRecord, [Entity VersionRecord], [Entity Category])
+                     (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
+collateVersions :: MonadUnliftIO m
-            => ConduitT (Entity PkgRecord) (Entity PkgRecord, [Entity VersionRecord]) (ReaderT SqlBackend m) ()
+                => ConduitT (Entity VersionRecord) (PkgId, [Entity VersionRecord]) (ReaderT SqlBackend m) ()
-zipVersions = awaitForever $ \pkg -> do
+collateVersions = awaitForever $ \v0 -> do
-    let appDbId = entityKey pkg
+    let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0
-    res <- lift $ select $ do
+    let pull = do
-        v <- from $ table @VersionRecord
+            mvn <- await
-        where_ $ v ^. VersionRecordPkgId ==. val appDbId
+            case mvn of
-        -- first value in list will be latest version
+                Nothing -> pure Nothing
-        orderBy [desc (v ^. VersionRecordNumber)]
+                Just vn -> do
-        pure v
+                    let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal vn
-    yield (pkg, res)
+                    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)

src/Handler/Admin.hs

@@ -1,6 +1,7 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE RecordWildCards #-}
 module Handler.Admin where
 
 import           Conduit                        ( (.|)

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

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

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
+                            -> ConduitT (PkgId, [Entity VersionRecord], [Entity Category]) PackageMetadata m ()
-                                   (Entity PkgRecord, [Entity VersionRecord], [Entity Category])
+filterLatestVersionFromSpec versionMap = awaitForever $ \(pkgId, vs, cats) -> do
-                                   PackageMetadata
-                                   m
-                                   ()
-filterLatestVersionFromSpec versionMap = awaitForever $ \(a, vs, cats) -> do
-    let pkgId = entityKey a
     -- 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