mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
prune unused code
This commit is contained in:
Keagan McClelland
@@ -1,258 +0,0 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# HLINT ignore "Fuse on/on" #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
module Database.Marketplace where
|
||||
|
||||
import Conduit (
|
||||
ConduitT,
|
||||
MonadResource,
|
||||
MonadUnliftIO,
|
||||
awaitForever,
|
||||
leftover,
|
||||
yield,
|
||||
)
|
||||
import Control.Monad.Loops (unfoldM)
|
||||
import Data.Conduit (await)
|
||||
import Database.Esqueleto.Experimental (
|
||||
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 (entityKey, entityVal),
|
||||
PersistEntity (Key),
|
||||
SqlBackend,
|
||||
runSqlPool,
|
||||
)
|
||||
import Lib.Types.AppIndex (PkgId)
|
||||
import Lib.Types.Emver (Version)
|
||||
import Model (
|
||||
Category,
|
||||
EntityField (
|
||||
CategoryId,
|
||||
CategoryName,
|
||||
PkgCategoryCategoryId,
|
||||
PkgCategoryPkgId,
|
||||
PkgDependencyDepId,
|
||||
PkgDependencyPkgId,
|
||||
PkgDependencyPkgVersion,
|
||||
PkgRecordId,
|
||||
VersionRecordDescLong,
|
||||
VersionRecordDescShort,
|
||||
VersionRecordNumber,
|
||||
VersionRecordPkgId,
|
||||
VersionRecordTitle,
|
||||
VersionRecordUpdatedAt
|
||||
),
|
||||
Key (PkgRecordKey, unPkgRecordKey),
|
||||
PkgCategory,
|
||||
PkgDependency,
|
||||
PkgRecord,
|
||||
VersionRecord (versionRecordNumber, versionRecordPkgId),
|
||||
)
|
||||
import Startlude (
|
||||
Applicative (pure),
|
||||
Down (Down),
|
||||
Eq ((==)),
|
||||
Functor (fmap),
|
||||
Maybe (..),
|
||||
Monad,
|
||||
MonadIO,
|
||||
NonEmpty,
|
||||
ReaderT,
|
||||
Show,
|
||||
Text,
|
||||
headMay,
|
||||
snd,
|
||||
sortOn,
|
||||
($),
|
||||
($>),
|
||||
(.),
|
||||
(<$>),
|
||||
(<<$>>),
|
||||
)
|
||||
|
||||
|
||||
data PackageMetadata = PackageMetadata
|
||||
{ packageMetadataPkgId :: !PkgId
|
||||
, packageMetadataPkgVersionRecords :: !(NonEmpty VersionRecord)
|
||||
, packageMetadataPkgVersion :: !Version
|
||||
, packageMetadataPkgCategories :: ![Category]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
data PackageDependencyMetadata = PackageDependencyMetadata
|
||||
{ packageDependencyMetadataPkgDependencyRecord :: !(Entity PkgDependency)
|
||||
, packageDependencyMetadataDepPkgRecord :: !(Entity PkgRecord)
|
||||
, packageDependencyMetadataDepVersions :: ![Entity VersionRecord]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
serviceQuerySource ::
|
||||
(MonadResource m, MonadIO m) =>
|
||||
Maybe Text ->
|
||||
Text ->
|
||||
ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
|
||||
serviceQuerySource Nothing query = selectSource $ do
|
||||
service <- from $ table @VersionRecord
|
||||
where_
|
||||
( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
|
||||
)
|
||||
groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber)
|
||||
orderBy
|
||||
[ asc (service ^. VersionRecordPkgId)
|
||||
, desc (service ^. VersionRecordNumber)
|
||||
, desc (service ^. VersionRecordUpdatedAt)
|
||||
]
|
||||
pure service
|
||||
serviceQuerySource (Just category) query = selectSource $ do
|
||||
services <-
|
||||
from
|
||||
( do
|
||||
(service :& _ :& cat) <-
|
||||
from $
|
||||
table @VersionRecord
|
||||
`innerJoin` table @PkgCategory
|
||||
`on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId)
|
||||
`innerJoin` table @Category
|
||||
`on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
|
||||
-- if there is a cateogry, only search in category
|
||||
-- weight title, short, long (bitcoin should equal Bitcoin Core)
|
||||
where_ $
|
||||
cat
|
||||
^. CategoryName
|
||||
==. val category
|
||||
&&. ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
|
||||
)
|
||||
pure service
|
||||
)
|
||||
groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber)
|
||||
orderBy
|
||||
[ asc (services ^. VersionRecordPkgId)
|
||||
, desc (services ^. VersionRecordNumber)
|
||||
, desc (services ^. VersionRecordUpdatedAt)
|
||||
]
|
||||
pure services
|
||||
|
||||
|
||||
getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
|
||||
getPkgDataSource pkgs = selectSource $ do
|
||||
pkgData <- from $ table @VersionRecord
|
||||
where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
|
||||
pure pkgData
|
||||
|
||||
|
||||
getPkgDependencyData ::
|
||||
MonadIO m =>
|
||||
Key PkgRecord ->
|
||||
Version ->
|
||||
ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)]
|
||||
getPkgDependencyData pkgId pkgVersion = select $ do
|
||||
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)
|
||||
)
|
||||
|
||||
|
||||
getCategoriesFor ::
|
||||
MonadUnliftIO m =>
|
||||
PkgId ->
|
||||
ReaderT SqlBackend m [Category]
|
||||
getCategoriesFor pkg =
|
||||
entityVal <<$>> select do
|
||||
(sc :& cat) <-
|
||||
from $
|
||||
table @PkgCategory
|
||||
`innerJoin` table @Category
|
||||
`on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. 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)
|
||||
|
||||
|
||||
zipDependencyVersions ::
|
||||
(Monad m, MonadIO m) =>
|
||||
(Entity PkgDependency, Entity PkgRecord) ->
|
||||
ReaderT SqlBackend m PackageDependencyMetadata
|
||||
zipDependencyVersions (pkgDepRecord, depRecord) = do
|
||||
let pkgDbId = entityKey depRecord
|
||||
depVers <- select $ do
|
||||
v <- from $ table @VersionRecord
|
||||
where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
|
||||
pure v
|
||||
pure $
|
||||
PackageDependencyMetadata
|
||||
{ packageDependencyMetadataPkgDependencyRecord = pkgDepRecord
|
||||
, packageDependencyMetadataDepPkgRecord = depRecord
|
||||
, packageDependencyMetadataDepVersions = depVers
|
||||
}
|
||||
|
||||
|
||||
fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
|
||||
fetchAllAppVersions appConnPool appId = do
|
||||
entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
|
||||
pure $ entityVal <$> entityAppVersions
|
||||
|
||||
|
||||
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)
|
||||
@@ -1,65 +1,280 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Database.Queries where
|
||||
|
||||
import Database.Persist.Sql ( PersistStoreRead(get)
|
||||
, PersistStoreWrite(insertKey, insert_, repsert)
|
||||
, SqlBackend
|
||||
)
|
||||
import Lib.Types.AppIndex ( PackageManifest(..)
|
||||
, PkgId
|
||||
)
|
||||
import Lib.Types.Emver ( Version )
|
||||
import Model ( Key(PkgRecordKey, VersionRecordKey)
|
||||
, Metric(Metric)
|
||||
, PkgRecord(PkgRecord)
|
||||
, VersionRecord(VersionRecord)
|
||||
)
|
||||
import Orphans.Emver ( )
|
||||
import Startlude ( ($)
|
||||
, (.)
|
||||
, ConvertText(toS)
|
||||
, Maybe(..)
|
||||
, MonadIO(..)
|
||||
, ReaderT
|
||||
, SomeException
|
||||
, getCurrentTime
|
||||
, maybe
|
||||
)
|
||||
import System.FilePath ( takeExtension )
|
||||
import UnliftIO ( MonadUnliftIO
|
||||
, try
|
||||
)
|
||||
import Database.Persist.Sql (
|
||||
PersistStoreRead (get),
|
||||
PersistStoreWrite (insertKey, insert_, repsert),
|
||||
SqlBackend,
|
||||
)
|
||||
import Lib.Types.AppIndex (
|
||||
PackageManifest (..),
|
||||
PkgId,
|
||||
)
|
||||
import Lib.Types.Emver (Version)
|
||||
import Model (
|
||||
Key (PkgRecordKey, VersionRecordKey),
|
||||
Metric (Metric),
|
||||
PkgRecord (PkgRecord),
|
||||
VersionRecord (VersionRecord),
|
||||
)
|
||||
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 Model (
|
||||
Category,
|
||||
EntityField (
|
||||
CategoryId,
|
||||
CategoryName,
|
||||
PkgCategoryCategoryId,
|
||||
PkgCategoryPkgId,
|
||||
PkgDependencyPkgId,
|
||||
PkgDependencyPkgVersion,
|
||||
PkgRecordId,
|
||||
VersionRecordDescLong,
|
||||
VersionRecordDescShort,
|
||||
VersionRecordNumber,
|
||||
VersionRecordPkgId,
|
||||
VersionRecordTitle,
|
||||
VersionRecordUpdatedAt
|
||||
),
|
||||
Key (unPkgRecordKey),
|
||||
PkgCategory,
|
||||
PkgDependency (pkgDependencyPkgId),
|
||||
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 ->
|
||||
ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
|
||||
serviceQuerySource mCat query = selectSource $ 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] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
|
||||
getPkgDataSource pkgs = selectSource $ 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 = pkgDependencyPkgId pkgDepRecord
|
||||
depVers <- select $ do
|
||||
v <- from $ table @VersionRecord
|
||||
where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
|
||||
pure v
|
||||
pure $ entityVal <$> depVers
|
||||
|
||||
|
||||
fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
|
||||
fetchAllAppVersions appConnPool appId = do
|
||||
entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
|
||||
pure $ entityVal <$> entityAppVersions
|
||||
|
||||
fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe PkgRecord)
|
||||
fetchApp = get . PkgRecordKey
|
||||
|
||||
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
|
||||
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
|
||||
Nothing
|
||||
let pkgId = PkgRecordKey packageManifestId
|
||||
let ins =
|
||||
VersionRecord
|
||||
now
|
||||
(Just now)
|
||||
pkgId
|
||||
packageManifestVersion
|
||||
packageManifestTitle
|
||||
packageManifestDescriptionShort
|
||||
packageManifestDescriptionLong
|
||||
iconType
|
||||
packageManifestReleaseNotes
|
||||
packageManifestEosVersion
|
||||
Nothing
|
||||
_res <- try @_ @SomeException $ insertKey pkgId (PkgRecord now (Just now))
|
||||
repsert (VersionRecordKey pkgId packageManifestVersion) ins
|
||||
|
||||
@@ -1,128 +1,148 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Handler.Admin where
|
||||
|
||||
import Conduit ( (.|)
|
||||
, runConduit
|
||||
, sinkFile
|
||||
)
|
||||
import Control.Exception ( ErrorCall(ErrorCall) )
|
||||
import Control.Monad.Reader.Has ( ask )
|
||||
import Control.Monad.Trans.Maybe ( MaybeT(..) )
|
||||
import Data.Aeson ( (.:)
|
||||
, (.:?)
|
||||
, (.=)
|
||||
, FromJSON(parseJSON)
|
||||
, ToJSON
|
||||
, decodeFileStrict
|
||||
, object
|
||||
, withObject
|
||||
)
|
||||
import Data.HashMap.Internal.Strict ( HashMap
|
||||
, differenceWith
|
||||
, filter
|
||||
, fromListWith
|
||||
)
|
||||
import Data.List ( (\\)
|
||||
, null
|
||||
)
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Database.Persist ( Entity(entityKey)
|
||||
, PersistStoreRead(get)
|
||||
, PersistUniqueRead(getBy)
|
||||
, PersistUniqueWrite(deleteBy, insertUnique, upsert)
|
||||
, entityVal
|
||||
, insert_
|
||||
, selectList
|
||||
)
|
||||
import Database.Persist.Postgresql ( runSqlPoolNoTransaction )
|
||||
import Database.Queries ( upsertPackageVersion )
|
||||
import Foundation ( Handler
|
||||
, RegistryCtx(..)
|
||||
)
|
||||
import Handler.Util ( orThrow
|
||||
, sendResponseText
|
||||
)
|
||||
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot)
|
||||
, extractPkg
|
||||
, getManifestLocation
|
||||
, getPackages
|
||||
, getVersionsFor
|
||||
)
|
||||
import Lib.Types.AppIndex ( PackageManifest(..)
|
||||
, PkgId(unPkgId)
|
||||
)
|
||||
import Lib.Types.Emver ( Version(..) )
|
||||
import Model ( Category(..)
|
||||
, Key(AdminKey, PkgRecordKey, VersionRecordKey)
|
||||
, PkgCategory(PkgCategory)
|
||||
, Unique(UniqueName, UniquePkgCategory)
|
||||
, Upload(..)
|
||||
, VersionRecord(versionRecordNumber, versionRecordPkgId)
|
||||
, unPkgRecordKey
|
||||
)
|
||||
import Network.HTTP.Types ( status403
|
||||
, status404
|
||||
, status500
|
||||
)
|
||||
import Settings
|
||||
import Startlude ( ($)
|
||||
, (&&&)
|
||||
, (.)
|
||||
, (<$>)
|
||||
, (<<$>>)
|
||||
, (<>)
|
||||
, Applicative(pure)
|
||||
, Bool(..)
|
||||
, Eq
|
||||
, Int
|
||||
, Maybe(..)
|
||||
, Monad((>>=))
|
||||
, Show
|
||||
, SomeException(..)
|
||||
, Text
|
||||
, asum
|
||||
, fmap
|
||||
, fromMaybe
|
||||
, getCurrentTime
|
||||
, guarded
|
||||
, hush
|
||||
, isNothing
|
||||
, liftIO
|
||||
, not
|
||||
, replicate
|
||||
, show
|
||||
, throwIO
|
||||
, toS
|
||||
, traverse
|
||||
, void
|
||||
, when
|
||||
, zip
|
||||
)
|
||||
import System.FilePath ( (<.>)
|
||||
, (</>)
|
||||
)
|
||||
import UnliftIO ( try
|
||||
, withTempDirectory
|
||||
)
|
||||
import UnliftIO.Directory ( createDirectoryIfMissing
|
||||
, removePathForcibly
|
||||
, renameDirectory
|
||||
, renameFile
|
||||
)
|
||||
import Yesod ( ToJSON(..)
|
||||
, delete
|
||||
, getsYesod
|
||||
, logError
|
||||
, rawRequestBody
|
||||
, requireCheckJsonBody
|
||||
, runDB
|
||||
)
|
||||
import Yesod.Auth ( YesodAuth(maybeAuthId) )
|
||||
import Yesod.Core.Types ( JSONResponse(JSONResponse) )
|
||||
import Conduit (
|
||||
runConduit,
|
||||
sinkFile,
|
||||
(.|),
|
||||
)
|
||||
import Control.Exception (ErrorCall (ErrorCall))
|
||||
import Control.Monad.Reader.Has (ask)
|
||||
import Control.Monad.Trans.Maybe (MaybeT (..))
|
||||
import Data.Aeson (
|
||||
FromJSON (parseJSON),
|
||||
ToJSON,
|
||||
decodeFileStrict,
|
||||
object,
|
||||
withObject,
|
||||
(.:),
|
||||
(.:?),
|
||||
(.=),
|
||||
)
|
||||
import Data.HashMap.Internal.Strict (
|
||||
HashMap,
|
||||
differenceWith,
|
||||
filter,
|
||||
fromListWith,
|
||||
)
|
||||
import Data.List (
|
||||
null,
|
||||
(\\),
|
||||
)
|
||||
import Data.String.Interpolate.IsString (
|
||||
i,
|
||||
)
|
||||
import Database.Persist (
|
||||
Entity (entityKey),
|
||||
PersistStoreRead (get),
|
||||
PersistUniqueRead (getBy),
|
||||
PersistUniqueWrite (deleteBy, insertUnique, upsert),
|
||||
entityVal,
|
||||
insert_,
|
||||
selectList,
|
||||
)
|
||||
import Database.Persist.Postgresql (runSqlPoolNoTransaction)
|
||||
import Database.Queries (upsertPackageVersion)
|
||||
import Foundation (
|
||||
Handler,
|
||||
RegistryCtx (..),
|
||||
)
|
||||
import Handler.Util (
|
||||
orThrow,
|
||||
sendResponseText,
|
||||
)
|
||||
import Lib.PkgRepository (
|
||||
PkgRepo (PkgRepo, pkgRepoFileRoot),
|
||||
extractPkg,
|
||||
getManifestLocation,
|
||||
getPackages,
|
||||
getVersionsFor,
|
||||
)
|
||||
import Lib.Types.AppIndex (
|
||||
PackageManifest (..),
|
||||
PkgId (unPkgId),
|
||||
)
|
||||
import Lib.Types.Emver (Version (..))
|
||||
import Model (
|
||||
Category (..),
|
||||
Key (AdminKey, PkgRecordKey, VersionRecordKey),
|
||||
PkgCategory (PkgCategory),
|
||||
Unique (UniqueName, UniquePkgCategory),
|
||||
Upload (..),
|
||||
VersionRecord (versionRecordNumber, versionRecordPkgId),
|
||||
unPkgRecordKey,
|
||||
)
|
||||
import Network.HTTP.Types (
|
||||
status403,
|
||||
status404,
|
||||
status500,
|
||||
)
|
||||
import Settings
|
||||
import Startlude (
|
||||
Applicative (pure),
|
||||
Bool (..),
|
||||
Eq,
|
||||
Int,
|
||||
Maybe (..),
|
||||
Monad ((>>=)),
|
||||
Show,
|
||||
SomeException (..),
|
||||
Text,
|
||||
asum,
|
||||
fmap,
|
||||
fromMaybe,
|
||||
getCurrentTime,
|
||||
guarded,
|
||||
hush,
|
||||
isNothing,
|
||||
liftIO,
|
||||
not,
|
||||
replicate,
|
||||
show,
|
||||
throwIO,
|
||||
toS,
|
||||
traverse,
|
||||
void,
|
||||
when,
|
||||
zip,
|
||||
($),
|
||||
(&&&),
|
||||
(.),
|
||||
(.*),
|
||||
(<$>),
|
||||
(<<$>>),
|
||||
(<>),
|
||||
)
|
||||
import System.FilePath (
|
||||
(<.>),
|
||||
(</>),
|
||||
)
|
||||
import UnliftIO (
|
||||
try,
|
||||
withTempDirectory,
|
||||
)
|
||||
import UnliftIO.Directory (
|
||||
createDirectoryIfMissing,
|
||||
removePathForcibly,
|
||||
renameDirectory,
|
||||
renameFile,
|
||||
)
|
||||
import Yesod (
|
||||
ToJSON (..),
|
||||
delete,
|
||||
getsYesod,
|
||||
logError,
|
||||
rawRequestBody,
|
||||
requireCheckJsonBody,
|
||||
runDB,
|
||||
)
|
||||
import Yesod.Auth (YesodAuth (maybeAuthId))
|
||||
import Yesod.Core.Types (JSONResponse (JSONResponse))
|
||||
|
||||
|
||||
postPkgUploadR :: Handler ()
|
||||
postPkgUploadR = do
|
||||
@@ -131,14 +151,15 @@ postPkgUploadR = do
|
||||
withTempDirectory resourcesTemp "newpkg" $ \dir -> do
|
||||
let path = dir </> "temp" <.> "s9pk"
|
||||
runConduit $ rawRequestBody .| sinkFile path
|
||||
pool <- getsYesod appConnPool
|
||||
PkgRepo {..} <- ask
|
||||
res <- retry $ extractPkg pool path
|
||||
pool <- getsYesod appConnPool
|
||||
PkgRepo{..} <- ask
|
||||
res <- retry $ extractPkg pool path
|
||||
when (isNothing res) $ do
|
||||
$logError "Failed to extract package"
|
||||
sendResponseText status500 "Failed to extract package"
|
||||
PackageManifest {..} <- liftIO (decodeFileStrict (dir </> "manifest.json"))
|
||||
`orThrow` sendResponseText status500 "Failed to parse manifest.json"
|
||||
PackageManifest{..} <-
|
||||
liftIO (decodeFileStrict (dir </> "manifest.json"))
|
||||
`orThrow` sendResponseText status500 "Failed to parse manifest.json"
|
||||
renameFile path (dir </> (toS . unPkgId) packageManifestId <.> "s9pk")
|
||||
let targetPath = pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion
|
||||
removePathForcibly targetPath
|
||||
@@ -153,92 +174,100 @@ postPkgUploadR = do
|
||||
Just name -> do
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
|
||||
where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
|
||||
where
|
||||
retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
|
||||
|
||||
|
||||
data IndexPkgReq = IndexPkgReq
|
||||
{ indexPkgReqId :: !PkgId
|
||||
{ indexPkgReqId :: !PkgId
|
||||
, indexPkgReqVersion :: !Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON IndexPkgReq where
|
||||
parseJSON = withObject "Index Package Request" $ \o -> do
|
||||
indexPkgReqId <- o .: "id"
|
||||
indexPkgReqId <- o .: "id"
|
||||
indexPkgReqVersion <- o .: "version"
|
||||
pure IndexPkgReq { .. }
|
||||
pure IndexPkgReq{..}
|
||||
instance ToJSON IndexPkgReq where
|
||||
toJSON IndexPkgReq {..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion]
|
||||
toJSON IndexPkgReq{..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion]
|
||||
|
||||
|
||||
postPkgIndexR :: Handler ()
|
||||
postPkgIndexR = do
|
||||
IndexPkgReq {..} <- requireCheckJsonBody
|
||||
manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion
|
||||
man <- liftIO (decodeFileStrict manifest) `orThrow` sendResponseText
|
||||
status404
|
||||
[i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
|
||||
IndexPkgReq{..} <- requireCheckJsonBody
|
||||
manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion
|
||||
man <-
|
||||
liftIO (decodeFileStrict manifest)
|
||||
`orThrow` sendResponseText
|
||||
status404
|
||||
[i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
|
||||
pool <- getsYesod appConnPool
|
||||
runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing
|
||||
|
||||
|
||||
postPkgDeindexR :: Handler ()
|
||||
postPkgDeindexR = do
|
||||
IndexPkgReq {..} <- requireCheckJsonBody
|
||||
IndexPkgReq{..} <- requireCheckJsonBody
|
||||
runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion)
|
||||
|
||||
newtype PackageList = PackageList { unPackageList :: HashMap PkgId [Version] }
|
||||
|
||||
newtype PackageList = PackageList {unPackageList :: HashMap PkgId [Version]}
|
||||
instance FromJSON PackageList where
|
||||
parseJSON = fmap PackageList . parseJSON
|
||||
instance ToJSON PackageList where
|
||||
toJSON = toJSON . unPackageList
|
||||
|
||||
|
||||
getPkgDeindexR :: Handler (JSONResponse PackageList)
|
||||
getPkgDeindexR = do
|
||||
dbList <-
|
||||
runDB
|
||||
$ (unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber)
|
||||
. entityVal
|
||||
<<$>> selectList [] []
|
||||
runDB $
|
||||
(unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber)
|
||||
. entityVal
|
||||
<<$>> selectList [] []
|
||||
let inDb = fromListWith (<>) dbList
|
||||
pkgsOnDisk <- getPackages
|
||||
onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk
|
||||
onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk
|
||||
pure . JSONResponse . PackageList $ filter (not . null) $ differenceWith (guarded null .* (\\)) onDisk inDb
|
||||
|
||||
{-# INLINE (.*) #-}
|
||||
infixr 8 .*
|
||||
(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
|
||||
(.*) = (.) . (.)
|
||||
|
||||
data AddCategoryReq = AddCategoryReq
|
||||
{ addCategoryDescription :: !(Maybe Text)
|
||||
, addCategoryPriority :: !(Maybe Int)
|
||||
, addCategoryPriority :: !(Maybe Int)
|
||||
}
|
||||
instance FromJSON AddCategoryReq where
|
||||
parseJSON = withObject "AddCategoryReq" $ \o -> do
|
||||
addCategoryDescription <- o .:? "description"
|
||||
addCategoryPriority <- o .:? "priority"
|
||||
pure AddCategoryReq { .. }
|
||||
addCategoryPriority <- o .:? "priority"
|
||||
pure AddCategoryReq{..}
|
||||
instance ToJSON AddCategoryReq where
|
||||
toJSON AddCategoryReq {..} = object ["description" .= addCategoryDescription, "priority" .= addCategoryPriority]
|
||||
toJSON AddCategoryReq{..} = object ["description" .= addCategoryDescription, "priority" .= addCategoryPriority]
|
||||
|
||||
|
||||
postCategoryR :: Text -> Handler ()
|
||||
postCategoryR cat = do
|
||||
AddCategoryReq {..} <- requireCheckJsonBody
|
||||
now <- liftIO getCurrentTime
|
||||
AddCategoryReq{..} <- requireCheckJsonBody
|
||||
now <- liftIO getCurrentTime
|
||||
void . runDB $ upsert (Category now cat (fromMaybe "" addCategoryDescription) (fromMaybe 0 addCategoryPriority)) []
|
||||
|
||||
|
||||
deleteCategoryR :: Text -> Handler ()
|
||||
deleteCategoryR cat = runDB $ deleteBy (UniqueName cat)
|
||||
|
||||
|
||||
postPkgCategorizeR :: Text -> PkgId -> Handler ()
|
||||
postPkgCategorizeR cat pkg = runDB $ do
|
||||
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
|
||||
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
|
||||
_pkgEnt <- get (PkgRecordKey pkg) `orThrow` sendResponseText status404 [i|Package "#{pkg}" does not exist|]
|
||||
now <- liftIO getCurrentTime
|
||||
void $ insertUnique (PkgCategory now (PkgRecordKey pkg) (entityKey catEnt)) `orThrow` sendResponseText
|
||||
status403
|
||||
[i|Package "#{pkg}" is already assigned to category "#{cat}"|]
|
||||
now <- liftIO getCurrentTime
|
||||
void $
|
||||
insertUnique (PkgCategory now (PkgRecordKey pkg) (entityKey catEnt))
|
||||
`orThrow` sendResponseText
|
||||
status403
|
||||
[i|Package "#{pkg}" is already assigned to category "#{cat}"|]
|
||||
|
||||
|
||||
deletePkgCategorizeR :: Text -> PkgId -> Handler ()
|
||||
deletePkgCategorizeR cat pkg = runDB $ do
|
||||
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
|
||||
deleteBy (UniquePkgCategory (PkgRecordKey pkg) (entityKey catEnt))
|
||||
|
||||
|
||||
@@ -1,10 +1,11 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Handler.Package.V0.Index where
|
||||
|
||||
import Conduit (concatMapC, dropC, mapC, mapMC, runConduit, sinkList, takeC, (.|))
|
||||
import Control.Monad.Reader.Has (Functor (fmap), Has, Monad ((>>=)), MonadReader, ReaderT (runReaderT), ask)
|
||||
import Control.Monad.Reader.Has (Functor (fmap), Has, Monad ((>>=)), MonadReader, ReaderT (runReaderT), ask, lift)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..), Value, decode, eitherDecodeStrict, object, withObject, (.:), (.=))
|
||||
import Data.Attoparsec.Text qualified as Atto
|
||||
import Data.ByteString.Base64 (encodeBase64)
|
||||
@@ -15,24 +16,82 @@ import Data.HashMap.Strict qualified as HM
|
||||
import Data.List (lookup)
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Text qualified as T
|
||||
import Database.Marketplace (PackageMetadata (..), collateVersions, getCategoriesFor, getPkgDataSource, getPkgDependencyData, serviceQuerySource, zipDependencyVersions)
|
||||
import Database.Persist (Key)
|
||||
import Database.Persist.Sql (SqlBackend)
|
||||
import Database.Queries (
|
||||
collateVersions,
|
||||
getCategoriesFor,
|
||||
getDependencyVersions,
|
||||
getPkgDataSource,
|
||||
getPkgDependencyData,
|
||||
serviceQuerySource,
|
||||
)
|
||||
import Foundation (Handler, Route (InstructionsR, LicenseR))
|
||||
import Handler.Types.Api (ApiVersion (..))
|
||||
import Handler.Util (basicRender)
|
||||
import Lib.Conduit (filterDependencyBestVersion, filterDependencyOsCompatible, selectLatestVersionFromSpec)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (PkgRepo, getIcon, getManifest)
|
||||
import Lib.Types.AppIndex (PkgId)
|
||||
import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies)
|
||||
import Model (Category (..), Key (..), PkgRecord (..), VersionRecord (..))
|
||||
import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies, (<||))
|
||||
import Model (Category (..), Key (..), PkgDependency (..), VersionRecord (..))
|
||||
import Network.HTTP.Types (status400)
|
||||
import Protolude.Unsafe (unsafeFromJust)
|
||||
import Settings (AppSettings)
|
||||
import Startlude (Applicative ((*>)), Bifunctor (second), Bool (..), ByteString, Either (..), Eq, Generic, Int, Maybe (..), MonadIO, Num ((*), (-)), Read, Show, Text, Traversable (traverse), catMaybes, const, encodeUtf8, filter, flip, fromMaybe, id, nonEmpty, pure, readMaybe, show, snd, ($), (&&&), (.), (<$>), (<&>))
|
||||
import UnliftIO (mapConcurrently)
|
||||
import Yesod (MonadLogger, MonadResource, ToContent (..), ToTypedContent (..), YesodPersist (runDB), lookupGetParam, sendResponseStatus)
|
||||
import Startlude (
|
||||
Applicative ((*>)),
|
||||
Bifunctor (..),
|
||||
Bool (..),
|
||||
ByteString,
|
||||
ConvertText (toS),
|
||||
Down (..),
|
||||
Either (..),
|
||||
Eq (..),
|
||||
Generic,
|
||||
Int,
|
||||
Maybe (..),
|
||||
MonadIO,
|
||||
NonEmpty,
|
||||
Num ((*), (-)),
|
||||
Show,
|
||||
Text,
|
||||
Traversable (traverse),
|
||||
catMaybes,
|
||||
const,
|
||||
encodeUtf8,
|
||||
filter,
|
||||
flip,
|
||||
for,
|
||||
fromMaybe,
|
||||
headMay,
|
||||
id,
|
||||
mappend,
|
||||
maximumOn,
|
||||
nonEmpty,
|
||||
note,
|
||||
pure,
|
||||
readMaybe,
|
||||
snd,
|
||||
sortOn,
|
||||
zipWith,
|
||||
zipWithM,
|
||||
($),
|
||||
(&&&),
|
||||
(.),
|
||||
(.*),
|
||||
(<$>),
|
||||
(<&>),
|
||||
(<>),
|
||||
(=<<),
|
||||
)
|
||||
import UnliftIO (Concurrently (..), mapConcurrently)
|
||||
import Yesod (
|
||||
MonadLogger,
|
||||
MonadResource,
|
||||
ToContent (..),
|
||||
ToTypedContent (..),
|
||||
YesodPersist (runDB),
|
||||
lookupGetParam,
|
||||
sendResponseStatus,
|
||||
)
|
||||
import Yesod.Core (logWarn)
|
||||
|
||||
|
||||
@@ -54,7 +113,7 @@ data PackageRes = PackageRes
|
||||
, packageResCategories :: ![Text]
|
||||
, packageResInstructions :: !Text
|
||||
, packageResLicense :: !Text
|
||||
, packageResVersions :: ![Version]
|
||||
, packageResVersions :: !(NonEmpty Version)
|
||||
, packageResDependencies :: !(HashMap PkgId DependencyRes)
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
@@ -69,16 +128,6 @@ instance ToJSON PackageRes where
|
||||
, "versions" .= packageResVersions
|
||||
, "dependency-metadata" .= packageResDependencies
|
||||
]
|
||||
instance FromJSON PackageRes where
|
||||
parseJSON = withObject "PackageRes" $ \o -> do
|
||||
packageResIcon <- o .: "icon"
|
||||
packageResLicense <- o .: "license"
|
||||
packageResInstructions <- o .: "instructions"
|
||||
packageResManifest <- o .: "manifest"
|
||||
packageResCategories <- o .: "categories"
|
||||
packageResVersions <- o .: "versions"
|
||||
packageResDependencies <- o .: "dependency-metadata"
|
||||
pure PackageRes{..}
|
||||
|
||||
|
||||
newtype PackageListRes = PackageListRes [PackageRes]
|
||||
@@ -97,23 +146,15 @@ data DependencyRes = DependencyRes
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON DependencyRes where
|
||||
toJSON DependencyRes{..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle]
|
||||
instance FromJSON DependencyRes where
|
||||
parseJSON = withObject "DependencyRes" $ \o -> do
|
||||
dependencyResIcon <- o .: "icon"
|
||||
dependencyResTitle <- o .: "title"
|
||||
pure DependencyRes{..}
|
||||
|
||||
|
||||
data PackageListDefaults = PackageListDefaults
|
||||
{ packageListOrder :: !OrderArrangement
|
||||
, packageListPageLimit :: !Int -- the number of items per page
|
||||
, packageListPageNumber :: !Int -- the page you are on
|
||||
, packageListCategory :: !(Maybe Text)
|
||||
, packageListQuery :: !Text
|
||||
data PackageMetadata = PackageMetadata
|
||||
{ packageMetadataPkgId :: !PkgId
|
||||
, packageMetadataPkgVersionRecords :: !(NonEmpty VersionRecord)
|
||||
, packageMetadataPkgVersion :: !Version
|
||||
, packageMetadataPkgCategories :: ![Category]
|
||||
}
|
||||
deriving (Eq, Show, Read)
|
||||
data OrderArrangement = ASC | DESC
|
||||
deriving (Eq, Show, Read)
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
getPackageIndexR :: Handler PackageListRes
|
||||
@@ -123,36 +164,20 @@ getPackageIndexR = do
|
||||
Nothing -> const True
|
||||
Just v -> flip satisfies v
|
||||
pkgIds <- getPkgIdsQuery
|
||||
filteredPackages <- case pkgIds of
|
||||
Nothing -> do
|
||||
-- query for all
|
||||
category <- getCategoryQuery
|
||||
page <- getPageQuery
|
||||
limit' <- getLimitQuery
|
||||
query <- T.strip . fromMaybe (packageListQuery defaults) <$> lookupGetParam "query"
|
||||
runDB $
|
||||
runConduit $
|
||||
serviceQuerySource category query
|
||||
-- group conduit pipeline by pkg id
|
||||
.| collateVersions
|
||||
-- filter out versions of apps that are incompatible with the OS predicate
|
||||
.| mapC (second (filter (osPredicate . versionRecordOsVersion)))
|
||||
-- prune empty version sets
|
||||
.| concatMapC (\(pkgId, vs) -> (pkgId,) <$> nonEmpty vs)
|
||||
-- grab the latest matching version if it exists
|
||||
.| concatMapC (\(a, b) -> (a,b,) <$> (selectLatestVersionFromSpec (const Any) b))
|
||||
-- construct
|
||||
.| mapMC (\(a, b, c) -> PackageMetadata a b (versionRecordNumber c) <$> getCategoriesFor a)
|
||||
-- pages start at 1 for some reason. TODO: make pages start at 0
|
||||
.| (dropC (limit' * (page - 1)) *> takeC limit')
|
||||
.| sinkList
|
||||
Just packages' -> do
|
||||
-- for each item in list get best available from version range
|
||||
let packageRanges = fromMaybe None . (flip lookup $ (packageReqId &&& packageReqVersion) <$> packages')
|
||||
runDB
|
||||
-- TODO could probably be better with sequenceConduits
|
||||
. runConduit
|
||||
$ getPkgDataSource (packageReqId <$> packages')
|
||||
category <- getCategoryQuery
|
||||
page <- fromMaybe 1 <$> getPageQuery
|
||||
limit' <- fromMaybe 20 <$> getLimitQuery
|
||||
query <- T.strip . fromMaybe "" <$> lookupGetParam "query"
|
||||
let (source, packageRanges) = case pkgIds of
|
||||
Nothing -> (serviceQuerySource category query, const Any)
|
||||
Just packages ->
|
||||
let s = getPkgDataSource (packageReqId <$> packages)
|
||||
r = fromMaybe None . (flip lookup $ (packageReqId &&& packageReqVersion) <$> packages)
|
||||
in (s, r)
|
||||
filteredPackages <-
|
||||
runDB $
|
||||
runConduit $
|
||||
source
|
||||
-- group conduit pipeline by pkg id
|
||||
.| collateVersions
|
||||
-- filter out versions of apps that are incompatible with the OS predicate
|
||||
@@ -163,141 +188,115 @@ getPackageIndexR = do
|
||||
.| concatMapC (\(a, b) -> (a,b,) <$> (selectLatestVersionFromSpec packageRanges b))
|
||||
-- construct
|
||||
.| mapMC (\(a, b, c) -> PackageMetadata a b (versionRecordNumber c) <$> getCategoriesFor a)
|
||||
-- pages start at 1 for some reason. TODO: make pages start at 0
|
||||
.| (dropC (limit' * (page - 1)) *> takeC limit')
|
||||
.| sinkList
|
||||
|
||||
-- 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
|
||||
, packageListPageLimit = 20
|
||||
, packageListPageNumber = 1
|
||||
, packageListCategory = Nothing
|
||||
, packageListQuery = ""
|
||||
}
|
||||
getPkgIdsQuery :: Handler (Maybe [PackageReq])
|
||||
getPkgIdsQuery =
|
||||
lookupGetParam "ids" >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just ids -> case eitherDecodeStrict (encodeUtf8 ids) of
|
||||
Left _ ->
|
||||
do
|
||||
let e = InvalidParamsE "get:ids" ids
|
||||
$logWarn (show e)
|
||||
sendResponseStatus status400 e
|
||||
Right a -> pure a
|
||||
getCategoryQuery :: Handler (Maybe Text)
|
||||
getCategoryQuery =
|
||||
lookupGetParam "category" >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just c -> case readMaybe . T.toUpper $ c of
|
||||
Nothing ->
|
||||
do
|
||||
let e = InvalidParamsE "get:category" c
|
||||
$logWarn (show e)
|
||||
sendResponseStatus status400 e
|
||||
Just t -> pure $ Just t
|
||||
getPageQuery :: Handler Int
|
||||
getPageQuery =
|
||||
lookupGetParam "page" >>= \case
|
||||
Nothing -> pure $ packageListPageNumber defaults
|
||||
Just p -> case readMaybe p of
|
||||
Nothing ->
|
||||
do
|
||||
let e = InvalidParamsE "get:page" p
|
||||
$logWarn (show e)
|
||||
sendResponseStatus status400 e
|
||||
Just t -> pure $ case t of
|
||||
0 -> 1 -- disallow page 0 so offset is not negative
|
||||
_ -> t
|
||||
getLimitQuery :: Handler Int
|
||||
getLimitQuery =
|
||||
lookupGetParam "per-page" >>= \case
|
||||
Nothing -> pure $ packageListPageLimit defaults
|
||||
Just pp -> case readMaybe pp of
|
||||
Nothing ->
|
||||
do
|
||||
let e = InvalidParamsE "get:per-page" pp
|
||||
$logWarn (show e)
|
||||
sendResponseStatus status400 e
|
||||
Just l -> pure l
|
||||
getOsVersionQuery :: Handler (Maybe VersionRange)
|
||||
getOsVersionQuery =
|
||||
lookupGetParam "eos-version-compat" >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just osv -> case Atto.parseOnly parseRange osv of
|
||||
Left _ ->
|
||||
do
|
||||
let e = InvalidParamsE "get:eos-version-compat" osv
|
||||
$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{packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion} =
|
||||
do
|
||||
let pkgId = PkgRecordKey pkg
|
||||
let pkgVersions' = versionRecordNumber <$> pkgVersions
|
||||
let pkgCategories' = pkgCategories
|
||||
pkgDepInfo <- getPkgDependencyData pkgId pkgVersion
|
||||
pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo
|
||||
let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions
|
||||
res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo
|
||||
pure (pkgId, pkgCategories', NE.toList 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 LBS.fromStrict
|
||||
icon <- loadIcon pkgId pkgVersion
|
||||
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 V0 pkgId
|
||||
, packageResLicense = basicRender $ LicenseR V0 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
|
||||
icon <- loadIcon depId depVersion
|
||||
pure (depId, DependencyRes{dependencyResTitle = depTitle, dependencyResIcon = encodeBase64 icon})
|
||||
)
|
||||
deps
|
||||
loadIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
|
||||
loadIcon pkg version = do
|
||||
(_, _, src) <- getIcon pkg version
|
||||
runConduit $ src .| CL.foldMap id
|
||||
PackageListRes <$> runConcurrently (zipWithM (Concurrently .* constructPackageListApiRes) filteredPackages pkgsWithDependencies)
|
||||
|
||||
|
||||
parseQueryParam :: Text -> (Text -> Either Text a) -> Handler (Maybe a)
|
||||
parseQueryParam param parser = do
|
||||
lookupGetParam param >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just x -> case parser x of
|
||||
Left e -> do
|
||||
let err = InvalidParamsE ("get:" <> param) x
|
||||
$logWarn e
|
||||
sendResponseStatus status400 err
|
||||
Right a -> pure (Just a)
|
||||
|
||||
|
||||
getPkgIdsQuery :: Handler (Maybe [PackageReq])
|
||||
getPkgIdsQuery = parseQueryParam "ids" (first toS . eitherDecodeStrict . encodeUtf8)
|
||||
|
||||
|
||||
getCategoryQuery :: Handler (Maybe Text)
|
||||
getCategoryQuery = parseQueryParam "category" ((flip $ note . mappend "Invalid 'category': ") =<< (readMaybe . T.toUpper))
|
||||
|
||||
|
||||
getPageQuery :: Handler (Maybe Int)
|
||||
getPageQuery = parseQueryParam "page" ((flip $ note . mappend "Invalid 'page': ") =<< readMaybe)
|
||||
|
||||
|
||||
getLimitQuery :: Handler (Maybe Int)
|
||||
getLimitQuery = parseQueryParam "per-page" ((flip $ note . mappend "Invalid 'per-page': ") =<< readMaybe)
|
||||
|
||||
|
||||
getOsVersionQuery :: Handler (Maybe VersionRange)
|
||||
getOsVersionQuery = parseQueryParam "eos-version-compat" (first toS . Atto.parseOnly parseRange)
|
||||
|
||||
|
||||
getPackageDependencies ::
|
||||
(MonadIO m, MonadLogger m, MonadResource m, Has PkgRepo r, MonadReader r m) =>
|
||||
(Version -> Bool) ->
|
||||
PackageMetadata ->
|
||||
ReaderT SqlBackend m (HashMap PkgId DependencyRes)
|
||||
getPackageDependencies osPredicate PackageMetadata{packageMetadataPkgId = pkg, packageMetadataPkgVersion = pkgVersion} =
|
||||
do
|
||||
pkgDepInfo <- getPkgDependencyData pkg pkgVersion
|
||||
pkgDepInfoWithVersions <- traverse getDependencyVersions pkgDepInfo
|
||||
let compatiblePkgDepInfo = fmap (filter (osPredicate . versionRecordOsVersion)) pkgDepInfoWithVersions
|
||||
let depMetadata = catMaybes $ zipWith selectDependencyBestVersion pkgDepInfo compatiblePkgDepInfo
|
||||
lift $
|
||||
fmap HM.fromList $
|
||||
for depMetadata $ \(depId, title, v) -> do
|
||||
icon <- encodeBase64 <$> loadIcon depId v
|
||||
pure $ (depId, DependencyRes title icon)
|
||||
|
||||
|
||||
constructPackageListApiRes ::
|
||||
(MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) =>
|
||||
PackageMetadata ->
|
||||
HashMap PkgId DependencyRes ->
|
||||
m PackageRes
|
||||
constructPackageListApiRes PackageMetadata{..} dependencies = do
|
||||
settings <- ask @_ @_ @AppSettings
|
||||
let pkgId = packageMetadataPkgId
|
||||
let pkgCategories = packageMetadataPkgCategories
|
||||
let pkgVersions = packageMetadataPkgVersionRecords
|
||||
let pkgVersion = packageMetadataPkgVersion
|
||||
manifest <-
|
||||
flip runReaderT settings $
|
||||
(snd <$> getManifest pkgId pkgVersion) >>= \bs ->
|
||||
runConduit $ bs .| CL.foldMap LBS.fromStrict
|
||||
icon <- loadIcon pkgId pkgVersion
|
||||
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 V0 pkgId
|
||||
, packageResLicense = basicRender $ LicenseR V0 pkgId
|
||||
, packageResVersions = versionRecordNumber <$> pkgVersions
|
||||
, packageResDependencies = dependencies
|
||||
}
|
||||
|
||||
|
||||
loadIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
|
||||
loadIcon pkg version = do
|
||||
(_, _, src) <- getIcon pkg version
|
||||
runConduit $ src .| CL.foldMap id
|
||||
|
||||
|
||||
selectLatestVersionFromSpec ::
|
||||
(PkgId -> VersionRange) ->
|
||||
NonEmpty VersionRecord ->
|
||||
Maybe VersionRecord
|
||||
selectLatestVersionFromSpec pkgRanges vs =
|
||||
let pkgId = NE.head $ versionRecordPkgId <$> vs
|
||||
spec = pkgRanges (unPkgRecordKey pkgId)
|
||||
in headMay . sortOn (Down . versionRecordNumber) $ NE.filter ((`satisfies` spec) . versionRecordNumber) vs
|
||||
|
||||
|
||||
-- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package)
|
||||
selectDependencyBestVersion :: PkgDependency -> [VersionRecord] -> Maybe (PkgId, Text, Version)
|
||||
selectDependencyBestVersion pkgDepRecord depVersions = do
|
||||
let depId = pkgDependencyDepId pkgDepRecord
|
||||
let versionRequirement = pkgDependencyDepVersionRange pkgDepRecord
|
||||
let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) depVersions
|
||||
case maximumOn versionRecordNumber satisfactory of
|
||||
Just bestVersion -> Just (unPkgRecordKey depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion)
|
||||
Nothing -> Nothing
|
||||
|
||||
@@ -5,7 +5,7 @@ import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.List (lookup)
|
||||
import Database.Marketplace (fetchLatestApp)
|
||||
import Database.Queries (fetchLatestApp)
|
||||
import Foundation (Handler)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.Types.AppIndex (PkgId)
|
||||
|
||||
@@ -5,7 +5,7 @@ module Handler.Package.V0.ReleaseNotes where
|
||||
import Data.Aeson (ToJSON (..))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Database.Marketplace (fetchAllAppVersions)
|
||||
import Database.Queries (fetchAllAppVersions)
|
||||
import Foundation (Handler, RegistryCtx (..))
|
||||
import Lib.Types.AppIndex (PkgId)
|
||||
import Lib.Types.Emver (Version)
|
||||
|
||||
@@ -6,7 +6,7 @@ module Handler.Package.V0.S9PK where
|
||||
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Data.Text qualified as T
|
||||
import Database.Queries (createMetric, fetchApp, fetchAppVersion)
|
||||
import Database.Queries (createMetric, fetchAppVersion)
|
||||
import Foundation (Handler)
|
||||
import GHC.Show (show)
|
||||
import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
|
||||
@@ -40,17 +40,10 @@ getAppR file = do
|
||||
|
||||
recordMetrics :: PkgId -> Version -> Handler ()
|
||||
recordMetrics pkg appVersion = do
|
||||
sa <- runDB $ fetchApp pkg
|
||||
case sa of
|
||||
existingVersion <- runDB $ fetchAppVersion pkg appVersion
|
||||
case existingVersion of
|
||||
Nothing ->
|
||||
do
|
||||
$logError [i|#{pkg} not found in database|]
|
||||
$logError [i|#{pkg}@#{appVersion} not found in database|]
|
||||
notFound
|
||||
Just _ -> do
|
||||
existingVersion <- runDB $ fetchAppVersion pkg appVersion
|
||||
case existingVersion of
|
||||
Nothing ->
|
||||
do
|
||||
$logError [i|#{pkg}@#{appVersion} not found in database|]
|
||||
notFound
|
||||
Just _ -> runDB $ createMetric pkg appVersion
|
||||
Just _ -> runDB $ createMetric pkg appVersion
|
||||
@@ -1,54 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Lib.Conduit where
|
||||
|
||||
import Control.Monad.Logger (logInfo)
|
||||
import Control.Monad.Logger.CallStack (MonadLogger)
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Database.Marketplace (PackageDependencyMetadata (..))
|
||||
import Database.Persist (Entity (..))
|
||||
import Lib.Ord (maximumOn)
|
||||
import Lib.Types.AppIndex (PkgId)
|
||||
import Lib.Types.Emver (Version, VersionRange (..), satisfies, (<||))
|
||||
import Model (Key (..), PkgDependency (..), PkgRecord (..), VersionRecord (..))
|
||||
import Startlude (Bool, Down (..), Maybe (..), NonEmpty, Text, filter, headMay, pure, sortOn, ($), (.), (<$>))
|
||||
|
||||
|
||||
selectLatestVersionFromSpec ::
|
||||
(PkgId -> VersionRange) ->
|
||||
NonEmpty VersionRecord ->
|
||||
Maybe VersionRecord
|
||||
selectLatestVersionFromSpec pkgRanges vs =
|
||||
let pkgId = NE.head $ versionRecordPkgId <$> vs
|
||||
spec = pkgRanges (unPkgRecordKey pkgId)
|
||||
in headMay . sortOn (Down . versionRecordNumber) $ NE.filter ((`satisfies` spec) . versionRecordNumber) vs
|
||||
|
||||
|
||||
filterDependencyOsCompatible :: (Version -> Bool) -> PackageDependencyMetadata -> PackageDependencyMetadata
|
||||
filterDependencyOsCompatible p PackageDependencyMetadata{packageDependencyMetadataPkgDependencyRecord = pkgDeps, packageDependencyMetadataDepPkgRecord = pkg, packageDependencyMetadataDepVersions = depVersions} =
|
||||
do
|
||||
let compatible = filter (p . versionRecordOsVersion . entityVal) depVersions
|
||||
PackageDependencyMetadata
|
||||
{ packageDependencyMetadataPkgDependencyRecord = pkgDeps
|
||||
, packageDependencyMetadataDepPkgRecord = pkg
|
||||
, packageDependencyMetadataDepVersions = compatible
|
||||
}
|
||||
|
||||
|
||||
-- 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 => PackageDependencyMetadata -> m (Maybe (Key PkgRecord, Text, Version))
|
||||
filterDependencyBestVersion PackageDependencyMetadata{packageDependencyMetadataPkgDependencyRecord = pkgDepRecord, packageDependencyMetadataDepVersions = depVersions} =
|
||||
do
|
||||
-- get best version from VersionRange of dependency
|
||||
let pkgId = pkgDependencyPkgId $ entityVal pkgDepRecord
|
||||
let depId = pkgDependencyDepId $ entityVal pkgDepRecord
|
||||
let versionRequirement = pkgDependencyDepVersionRange $ entityVal pkgDepRecord
|
||||
let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) (entityVal <$> depVersions)
|
||||
case maximumOn versionRecordNumber satisfactory of
|
||||
Just bestVersion -> pure $ Just (depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion)
|
||||
Nothing -> do
|
||||
$logInfo
|
||||
[i|No satisfactory version of #{depId} for dependent package #{pkgId}, needs #{versionRequirement}|]
|
||||
pure Nothing
|
||||
222
src/Lib/External/AppMgr.hs
vendored
222
src/Lib/External/AppMgr.hs
vendored
@@ -1,158 +1,148 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Lib.External.AppMgr where
|
||||
module Lib.External.AppMgr (
|
||||
sourceManifest,
|
||||
getPackageHash,
|
||||
sourceInstructions,
|
||||
sourceLicense,
|
||||
sourceIcon,
|
||||
) where
|
||||
|
||||
import Startlude ( ($)
|
||||
, (&&)
|
||||
, (<$>)
|
||||
, Applicative((*>), pure)
|
||||
, ByteString
|
||||
, Eq((==))
|
||||
, ExitCode
|
||||
, FilePath
|
||||
, Monad
|
||||
, MonadIO(..)
|
||||
, Monoid
|
||||
, String
|
||||
, atomically
|
||||
, id
|
||||
, liftA3
|
||||
, stderr
|
||||
, throwIO
|
||||
)
|
||||
import Startlude (
|
||||
Applicative (pure, (*>)),
|
||||
ByteString,
|
||||
Eq ((==)),
|
||||
FilePath,
|
||||
String,
|
||||
id,
|
||||
stderr,
|
||||
throwIO,
|
||||
($),
|
||||
(&&),
|
||||
)
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import System.Process.Typed ( ExitCodeException(eceExitCode)
|
||||
, Process
|
||||
, ProcessConfig
|
||||
, byteStringInput
|
||||
, byteStringOutput
|
||||
, getStderr
|
||||
, getStdout
|
||||
, proc
|
||||
, setEnvInherit
|
||||
, setStderr
|
||||
, setStdin
|
||||
, setStdout
|
||||
, startProcess
|
||||
, stopProcess
|
||||
, useHandleOpen
|
||||
, waitExitCodeSTM
|
||||
, withProcessWait
|
||||
)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.String.Interpolate.IsString (
|
||||
i,
|
||||
)
|
||||
import System.Process.Typed (
|
||||
ExitCodeException (eceExitCode),
|
||||
Process,
|
||||
ProcessConfig,
|
||||
byteStringInput,
|
||||
getStdout,
|
||||
proc,
|
||||
setEnvInherit,
|
||||
setStderr,
|
||||
setStdin,
|
||||
setStdout,
|
||||
startProcess,
|
||||
stopProcess,
|
||||
useHandleOpen,
|
||||
)
|
||||
|
||||
import Conduit ( (.|)
|
||||
, ConduitT
|
||||
, runConduit
|
||||
)
|
||||
import Control.Monad.Logger ( MonadLoggerIO
|
||||
, logErrorSH
|
||||
)
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Data.Conduit.Process.Typed ( createSource )
|
||||
import GHC.IO.Exception ( IOErrorType(NoSuchThing)
|
||||
, IOException(ioe_description, ioe_type)
|
||||
)
|
||||
import Lib.Error ( S9Error(AppMgrE) )
|
||||
import System.FilePath ( (</>) )
|
||||
import UnliftIO ( MonadUnliftIO
|
||||
, bracket
|
||||
, catch
|
||||
)
|
||||
import Conduit (
|
||||
ConduitT,
|
||||
runConduit,
|
||||
(.|),
|
||||
)
|
||||
import Control.Monad.Logger (
|
||||
MonadLoggerIO,
|
||||
logErrorSH,
|
||||
)
|
||||
import Data.Conduit.List qualified as CL
|
||||
import Data.Conduit.Process.Typed (createSource)
|
||||
import GHC.IO.Exception (
|
||||
IOErrorType (NoSuchThing),
|
||||
IOException (ioe_description, ioe_type),
|
||||
)
|
||||
import Lib.Error (S9Error (AppMgrE))
|
||||
import System.FilePath ((</>))
|
||||
import UnliftIO (
|
||||
MonadUnliftIO,
|
||||
bracket,
|
||||
catch,
|
||||
)
|
||||
|
||||
readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
|
||||
readProcessWithExitCode' a b c = liftIO $ do
|
||||
let pc =
|
||||
setStdin (byteStringInput $ LBS.fromStrict c)
|
||||
$ setStderr byteStringOutput
|
||||
$ setEnvInherit
|
||||
$ setStdout byteStringOutput
|
||||
$ System.Process.Typed.proc a b
|
||||
withProcessWait pc $ \process -> atomically $ liftA3 (,,)
|
||||
(waitExitCodeSTM process)
|
||||
(LBS.toStrict <$> getStdout process)
|
||||
(LBS.toStrict <$> getStderr process)
|
||||
|
||||
readProcessInheritStderr :: forall m a
|
||||
. MonadUnliftIO m
|
||||
=> String
|
||||
-> [String]
|
||||
-> ByteString
|
||||
-> (ConduitT () ByteString m () -> m a) -- this is because we can't clean up the process in the unCPS'ed version of this
|
||||
-> m a
|
||||
readProcessInheritStderr ::
|
||||
forall m a.
|
||||
MonadUnliftIO m =>
|
||||
String ->
|
||||
[String] ->
|
||||
ByteString ->
|
||||
(ConduitT () ByteString m () -> m a) -> -- this is because we can't clean up the process in the unCPS'ed version of this
|
||||
m a
|
||||
readProcessInheritStderr a b c sink = do
|
||||
let pc =
|
||||
setStdin (byteStringInput $ LBS.fromStrict c)
|
||||
$ setEnvInherit
|
||||
$ setStderr (useHandleOpen stderr)
|
||||
$ setStdout createSource
|
||||
$ System.Process.Typed.proc a b
|
||||
setStdin (byteStringInput $ LBS.fromStrict c) $
|
||||
setEnvInherit $
|
||||
setStderr (useHandleOpen stderr) $
|
||||
setStdout createSource $
|
||||
System.Process.Typed.proc a b
|
||||
withProcessTerm' pc $ \p -> sink (getStdout p)
|
||||
where
|
||||
-- We need this to deal with https://github.com/haskell/process/issues/215
|
||||
withProcessTerm' :: (MonadUnliftIO m)
|
||||
=> ProcessConfig stdin stdout stderr
|
||||
-> (Process stdin stdout stderr -> m a)
|
||||
-> m a
|
||||
withProcessTerm' ::
|
||||
(MonadUnliftIO m) =>
|
||||
ProcessConfig stdin stdout stderr ->
|
||||
(Process stdin stdout stderr -> m a) ->
|
||||
m a
|
||||
withProcessTerm' cfg = bracket (startProcess cfg) $ \p -> do
|
||||
stopProcess p
|
||||
`catch` (\e -> if ioe_type e == NoSuchThing && ioe_description e == "No child processes"
|
||||
then pure ()
|
||||
else throwIO e
|
||||
`catch` ( \e ->
|
||||
if ioe_type e == NoSuchThing && ioe_description e == "No child processes"
|
||||
then pure ()
|
||||
else throwIO e
|
||||
)
|
||||
|
||||
sourceManifest :: (MonadUnliftIO m, MonadLoggerIO m)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> (ConduitT () ByteString m () -> m r)
|
||||
-> m r
|
||||
|
||||
sourceManifest ::
|
||||
(MonadUnliftIO m, MonadLoggerIO m) =>
|
||||
FilePath ->
|
||||
FilePath ->
|
||||
(ConduitT () ByteString m () -> m r) ->
|
||||
m r
|
||||
sourceManifest appmgrPath pkgFile sink = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "manifest", pkgFile] ""
|
||||
appmgr sink `catch` \ece ->
|
||||
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece))
|
||||
|
||||
|
||||
sourceIcon :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
|
||||
sourceIcon appmgrPath pkgFile sink = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "icon", pkgFile] ""
|
||||
appmgr sink `catch` \ece ->
|
||||
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece))
|
||||
|
||||
|
||||
getPackageHash :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> m ByteString
|
||||
getPackageHash appmgrPath pkgFile = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "hash", pkgFile] ""
|
||||
appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) `catch` \ece ->
|
||||
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece))
|
||||
|
||||
sourceInstructions :: (MonadUnliftIO m, MonadLoggerIO m)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> (ConduitT () ByteString m () -> m r)
|
||||
-> m r
|
||||
|
||||
sourceInstructions ::
|
||||
(MonadUnliftIO m, MonadLoggerIO m) =>
|
||||
FilePath ->
|
||||
FilePath ->
|
||||
(ConduitT () ByteString m () -> m r) ->
|
||||
m r
|
||||
sourceInstructions appmgrPath pkgFile sink = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "instructions", pkgFile] ""
|
||||
appmgr sink `catch` \ece ->
|
||||
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece))
|
||||
|
||||
sourceLicense :: (MonadUnliftIO m, MonadLoggerIO m)
|
||||
=> FilePath
|
||||
-> FilePath
|
||||
-> (ConduitT () ByteString m () -> m r)
|
||||
-> m r
|
||||
|
||||
sourceLicense ::
|
||||
(MonadUnliftIO m, MonadLoggerIO m) =>
|
||||
FilePath ->
|
||||
FilePath ->
|
||||
(ConduitT () ByteString m () -> m r) ->
|
||||
m r
|
||||
sourceLicense appmgrPath pkgFile sink = do
|
||||
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "license", pkgFile] ""
|
||||
appmgr sink `catch` \ece ->
|
||||
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece))
|
||||
|
||||
sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a
|
||||
sinkMem c = runConduit $ c .| CL.foldMap id
|
||||
|
||||
@@ -1,11 +0,0 @@
|
||||
module Lib.Ord where
|
||||
|
||||
import Startlude (Alternative ((<|>)), Foldable (foldr), Maybe (..), Ord ((>)), (<$>))
|
||||
|
||||
|
||||
maximumOn :: forall a b t. (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
|
||||
maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
|
||||
|
||||
|
||||
maxOn :: Ord b => (a -> b) -> a -> a -> a
|
||||
maxOn f x y = if f x > f y then x else y
|
||||
@@ -35,3 +35,17 @@ id = identity
|
||||
readMaybe :: (Read a) => Text -> Maybe a
|
||||
readMaybe = P.readMaybe
|
||||
{-# INLINE readMaybe #-}
|
||||
|
||||
|
||||
maximumOn :: forall a b t. (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
|
||||
maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
|
||||
|
||||
|
||||
maxOn :: Ord b => (a -> b) -> a -> a -> a
|
||||
maxOn f x y = if f x > f y then x else y
|
||||
|
||||
|
||||
{-# INLINE (.*) #-}
|
||||
infixr 8 .*
|
||||
(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
|
||||
(.*) = (.) . (.)
|
||||
|
||||
Reference in New Issue
Block a user