mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 10:21:51 +00:00
333 lines
12 KiB
Haskell
333 lines
12 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Database.Queries where
|
|
|
|
import Database.Persist.Sql (
|
|
PersistStoreRead (get),
|
|
PersistStoreWrite (insertKey, insert_, insertMany_, repsert),
|
|
SqlBackend,
|
|
)
|
|
import Lib.Types.Core (
|
|
PkgId, OsArch (X86_64, AARCH64),
|
|
)
|
|
import Lib.Types.Emver (Version)
|
|
import Model (
|
|
Key (PkgRecordKey, VersionRecordKey),
|
|
Metric (Metric),
|
|
PkgDependency (..),
|
|
PkgRecord (PkgRecord),
|
|
VersionRecord (VersionRecord), VersionPlatform (VersionPlatform), EntityField (VersionPlatformPkgId, VersionPlatformVersionNumber, VersionPlatformArch),
|
|
)
|
|
import Orphans.Emver ()
|
|
import Startlude (
|
|
ConvertText (toS),
|
|
Maybe (..),
|
|
MonadIO (..),
|
|
ReaderT,
|
|
SomeException,
|
|
getCurrentTime,
|
|
maybe,
|
|
($),
|
|
(.),
|
|
)
|
|
import System.FilePath (takeExtension)
|
|
import UnliftIO (
|
|
MonadUnliftIO,
|
|
try,
|
|
)
|
|
|
|
import Conduit (
|
|
ConduitT,
|
|
MonadResource,
|
|
awaitForever,
|
|
leftover,
|
|
yield,
|
|
)
|
|
import Control.Monad.Loops (unfoldM)
|
|
import Data.Conduit (await)
|
|
import Database.Esqueleto.Experimental (
|
|
PersistEntity,
|
|
SqlExpr,
|
|
Value,
|
|
asc,
|
|
desc,
|
|
from,
|
|
groupBy,
|
|
ilike,
|
|
in_,
|
|
innerJoin,
|
|
on,
|
|
orderBy,
|
|
select,
|
|
selectSource,
|
|
table,
|
|
val,
|
|
valList,
|
|
where_,
|
|
(%),
|
|
(&&.),
|
|
(++.),
|
|
(:&) (..),
|
|
(==.),
|
|
(^.),
|
|
(||.),
|
|
)
|
|
import Database.Persist qualified as P
|
|
import Database.Persist.Postgresql (
|
|
ConnectionPool,
|
|
Entity (entityVal),
|
|
runSqlPool,
|
|
)
|
|
import Lib.Types.Manifest (PackageManifest (..))
|
|
import Model (
|
|
Category,
|
|
EntityField (
|
|
CategoryId,
|
|
CategoryName,
|
|
PkgCategoryCategoryId,
|
|
PkgCategoryPkgId,
|
|
PkgDependencyPkgId,
|
|
PkgDependencyPkgVersion,
|
|
PkgRecordId,
|
|
VersionRecordDescLong,
|
|
VersionRecordDescShort,
|
|
VersionRecordNumber,
|
|
VersionRecordPkgId,
|
|
VersionRecordTitle,
|
|
VersionRecordUpdatedAt
|
|
),
|
|
Key (unPkgRecordKey),
|
|
PkgCategory,
|
|
VersionRecord (versionRecordNumber, versionRecordPkgId),
|
|
)
|
|
import Startlude (
|
|
Applicative (pure),
|
|
Bool,
|
|
Down (Down),
|
|
Eq ((==)),
|
|
Functor (fmap),
|
|
Monad,
|
|
Text,
|
|
headMay,
|
|
snd,
|
|
sortOn,
|
|
($>),
|
|
(<$>),
|
|
)
|
|
|
|
|
|
serviceQuerySource ::
|
|
(MonadResource m, MonadIO m) =>
|
|
Maybe Text ->
|
|
Text ->
|
|
Maybe OsArch ->
|
|
ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
|
|
serviceQuerySource mCat query mOsArch = selectSource $ do
|
|
case mOsArch of
|
|
Just osArch -> do
|
|
service <- case mCat of
|
|
Nothing -> do
|
|
(service :& vp) <- from $ table @VersionRecord
|
|
`innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service))
|
|
where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber)
|
|
where_ (vp ^. VersionPlatformArch ==. val osArch)
|
|
where_ $ queryInMetadata query service
|
|
pure service
|
|
Just category -> do
|
|
(service :& _ :& cat :& vp) <-
|
|
from $
|
|
table @VersionRecord
|
|
`innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId)
|
|
`innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b))
|
|
`innerJoin` table @VersionPlatform `on` (\(service :& _ :& _ :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service))
|
|
-- if there is a cateogry, only search in category
|
|
-- weight title, short, long (bitcoin should equal Bitcoin Core)
|
|
where_ $ cat ^. CategoryName ==. val category &&. queryInMetadata query service
|
|
where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber)
|
|
where_ (vp ^. VersionPlatformArch ==. val osArch)
|
|
pure service
|
|
groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber)
|
|
orderBy
|
|
[ asc (service ^. VersionRecordPkgId)
|
|
, desc (service ^. VersionRecordNumber)
|
|
, desc (service ^. VersionRecordUpdatedAt)
|
|
]
|
|
pure service
|
|
Nothing -> do
|
|
service <- case mCat of
|
|
Nothing -> do
|
|
service <- from $ table @VersionRecord
|
|
where_ $ queryInMetadata query service
|
|
pure service
|
|
Just category -> do
|
|
(service :& _ :& cat) <-
|
|
from $
|
|
table @VersionRecord
|
|
`innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId)
|
|
`innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b))
|
|
-- if there is a cateogry, only search in category
|
|
-- weight title, short, long (bitcoin should equal Bitcoin Core)
|
|
where_ $ cat ^. CategoryName ==. val category &&. queryInMetadata query service
|
|
pure service
|
|
groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber)
|
|
orderBy
|
|
[ asc (service ^. VersionRecordPkgId)
|
|
, desc (service ^. VersionRecordNumber)
|
|
, desc (service ^. VersionRecordUpdatedAt)
|
|
]
|
|
pure service
|
|
|
|
queryInMetadata :: Text -> SqlExpr (Entity VersionRecord) -> (SqlExpr (Value Bool))
|
|
queryInMetadata query service =
|
|
(service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
|
|
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
|
|
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
|
|
|
|
|
|
getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> Maybe OsArch -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
|
|
getPkgDataSource pkgs mOsArch = selectSource $ do
|
|
case mOsArch of
|
|
Just osArch -> do
|
|
(pkgData :& vp) <- from $ table @VersionRecord
|
|
`innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service))
|
|
where_ (pkgData ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber)
|
|
where_ (vp ^. VersionPlatformArch ==. val osArch)
|
|
where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
|
|
pure pkgData
|
|
Nothing -> do
|
|
pkgData <- from $ table @VersionRecord
|
|
where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
|
|
pure pkgData
|
|
|
|
|
|
getPkgDependencyData ::
|
|
MonadIO m =>
|
|
PkgId ->
|
|
Version ->
|
|
ReaderT SqlBackend m [PkgDependency]
|
|
getPkgDependencyData pkgId pkgVersion = fmap (fmap entityVal) $
|
|
select $
|
|
from $ do
|
|
pkgDepRecord <- from $ table @PkgDependency
|
|
where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val (PkgRecordKey pkgId))
|
|
where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion)
|
|
pure pkgDepRecord
|
|
|
|
|
|
(===) ::
|
|
(PersistEntity val1, PersistEntity val2, P.PersistField typ) =>
|
|
EntityField val1 typ ->
|
|
EntityField val2 typ ->
|
|
(SqlExpr (Entity val1) :& SqlExpr (Entity val2)) ->
|
|
SqlExpr (Value Bool)
|
|
(===) a' b' (a :& b) = a ^. a' ==. b ^. b'
|
|
|
|
|
|
getCategoriesFor ::
|
|
MonadUnliftIO m =>
|
|
PkgId ->
|
|
ReaderT SqlBackend m [Category]
|
|
getCategoriesFor pkg = fmap (fmap entityVal) $
|
|
select $ do
|
|
(sc :& cat) <-
|
|
from $
|
|
table @PkgCategory
|
|
`innerJoin` table @Category `on` (PkgCategoryCategoryId === CategoryId)
|
|
where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg))
|
|
pure cat
|
|
|
|
|
|
collateVersions ::
|
|
MonadUnliftIO m =>
|
|
ConduitT (Entity VersionRecord) (PkgId, [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, fmap entityVal $ v0 : ls)
|
|
|
|
|
|
getDependencyVersions ::
|
|
(Monad m, MonadIO m) =>
|
|
PkgDependency ->
|
|
ReaderT SqlBackend m [VersionRecord]
|
|
getDependencyVersions pkgDepRecord = do
|
|
let pkgDbId = pkgDependencyDepId pkgDepRecord
|
|
depVers <- select $ do
|
|
v <- from $ table @VersionRecord
|
|
where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
|
|
pure v
|
|
pure $ entityVal <$> depVers
|
|
|
|
|
|
fetchAllPkgVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
|
|
fetchAllPkgVersions appConnPool appId = do
|
|
entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
|
|
pure $ entityVal <$> entityAppVersions
|
|
|
|
|
|
fetchAppVersion :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m (Maybe VersionRecord)
|
|
fetchAppVersion pkgId version = get (VersionRecordKey (PkgRecordKey pkgId) version)
|
|
|
|
|
|
fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
|
|
fetchLatestApp appId = fmap headMay . sortResults . select $ do
|
|
(service :& version) <-
|
|
from $
|
|
table @PkgRecord
|
|
`innerJoin` table @VersionRecord
|
|
`on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
|
|
where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId))
|
|
pure (service, version)
|
|
where
|
|
sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd)
|
|
|
|
|
|
createMetric :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m ()
|
|
createMetric appId version = do
|
|
time <- liftIO getCurrentTime
|
|
insert_ $ Metric time (PkgRecordKey appId) version
|
|
|
|
|
|
upsertPackageVersion :: (MonadUnliftIO m) => PackageManifest -> ReaderT SqlBackend m ()
|
|
upsertPackageVersion PackageManifest{..} = do
|
|
now <- liftIO getCurrentTime
|
|
let iconType = maybe "png" (toS . takeExtension . toS) packageManifestIcon
|
|
let pkgId = PkgRecordKey packageManifestId
|
|
let ins =
|
|
VersionRecord
|
|
now
|
|
(Just now)
|
|
pkgId
|
|
packageManifestVersion
|
|
packageManifestTitle
|
|
packageManifestDescriptionShort
|
|
packageManifestDescriptionLong
|
|
iconType
|
|
packageManifestReleaseNotes
|
|
packageManifestEosVersion
|
|
_res <- try @_ @SomeException $ insertKey pkgId (PkgRecord now (Just now))
|
|
repsert (VersionRecordKey pkgId packageManifestVersion) ins
|
|
|
|
upsertPackageVersionPlatform :: (MonadUnliftIO m) => PackageManifest -> ReaderT SqlBackend m ()
|
|
upsertPackageVersionPlatform PackageManifest{..} = do
|
|
now <- liftIO getCurrentTime
|
|
let pkgId = PkgRecordKey packageManifestId
|
|
let arches = [X86_64, AARCH64]
|
|
let records = createVersionPlatformRecord now pkgId packageManifestVersion <$> arches
|
|
insertMany_ records
|
|
where
|
|
createVersionPlatformRecord time id version = VersionPlatform
|
|
time
|
|
(Just time)
|
|
id
|
|
version |