Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

reprganize database calls and marketplaces types

Browse Source
This commit is contained in:
Lucy Cifferello
2021-11-24 18:20:32 -07:00
parent b8a84f540a
commit 1610c8c9fd
5 changed files with 199 additions and 185 deletions
Download Patch File Download Diff File Expand all files Collapse all files

62
src/Database/Marketplace.hs
View File

@@ -15,8 +15,6 @@ import Database.Esqueleto.Experimental
, (&&.)
, (++.)
, (==.)
, Entity(entityKey, entityVal)
, SqlBackend
, (^.)
, desc
, from
@@ -31,12 +29,15 @@ import Database.Esqueleto.Experimental
, valList
, where_
, (||.)
, Value(unValue)
)
import Database.Esqueleto.Experimental
( (:&)(..)
, table
)
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.AppIndex ( VersionInfo(..)
, PkgId
)
import Lib.Types.Category
import Lib.Types.Emver ( Version
, VersionRange
@@ -47,6 +48,14 @@ import Startlude hiding ( (%)
, on
, yield
)
import qualified Data.HashMap.Internal.Strict as HM
import Handler.Types.Marketplace ( ReleaseNotes(ReleaseNotes) )
import qualified Database.Persist as P
import Database.Persist.Postgresql
hiding ( (||.)
, selectSource
, (==.)
)
searchServices :: (MonadResource m, MonadIO m)
=> Maybe CategoryTitle
@@ -112,3 +121,50 @@ filterOsCompatible :: Monad m
filterOsCompatible p = awaitForever $ \(app, versions, requestedVersion) -> do
let compatible = filter (p . versionRecordOsVersion . entityVal) versions
when (not $ null compatible) $ yield (app, compatible, requestedVersion)
fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m ([VersionInfo], ReleaseNotes)
fetchAllAppVersions appConnPool appId = do
entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
let vers = entityVal <$> entityAppVersions
let vv = mapSVersionToVersionInfo vers
let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv
pure $ (sortOn (Down . versionInfoVersion) vv, mappedVersions)
where
mapSVersionToVersionInfo :: [VersionRecord] -> [VersionInfo]
mapSVersionToVersionInfo sv = do
(\v -> VersionInfo { versionInfoVersion = versionRecordNumber v
, versionInfoReleaseNotes = versionRecordReleaseNotes v
, versionInfoDependencies = HM.empty
, versionInfoOsVersion = versionRecordOsVersion v
, versionInfoInstallAlert = Nothing
}
)
<$> sv
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)
fetchAppCategories :: MonadIO m => [PkgId] -> ReaderT SqlBackend m (HM.HashMap PkgId [Category])
fetchAppCategories appIds = do
raw <- select $ do
(sc :& app :& cat) <-
from
$ table @PkgCategory
`innerJoin` table @PkgRecord
`on` (\(sc :& app) -> sc ^. PkgCategoryPkgId ==. app ^. PkgRecordId)
`innerJoin` table @Category
`on` (\(sc :& _ :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
where_ (sc ^. PkgCategoryPkgId `in_` valList (PkgRecordKey <$> appIds))
pure (app ^. PkgRecordId, cat)
let ls = fmap (first (unPkgRecordKey . unValue) . second (pure . entityVal)) raw
pure $ HM.fromListWith (++) ls

180
src/Handler/Marketplace.hs
View File

@@ -42,8 +42,6 @@ import Data.Aeson ( (.:)
, decode
, eitherDecode
, eitherDecodeStrict
, object
, withObject
)
import qualified Data.Attoparsec.Text as Atto
import Data.ByteArray.Encoding ( Base(Base16)
@@ -61,28 +59,22 @@ import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
import Database.Esqueleto.Experimental
( (:&)((:&))
, (==.)
, Entity(entityKey, entityVal)
( Entity(entityKey, entityVal)
, SqlBackend
, Value(unValue)
, (^.)
, desc
, from
, in_
, innerJoin
, on
, orderBy
, select
, table
, val
, valList
, where_
)
import Database.Marketplace ( filterOsCompatible
, getPkgData
, searchServices
, zipVersions
, fetchAllAppVersions
, fetchLatestApp
, fetchAppCategories
)
import qualified Database.Persist as P
import Database.Persist ( PersistUniqueRead(getBy)
@@ -98,7 +90,6 @@ import Lib.PkgRepository ( getManifest )
import Lib.Types.AppIndex ( PkgId(PkgId)
, PackageDependency(packageDependencyVersion)
, PackageManifest(packageManifestDependencies)
, VersionInfo(..)
)
import Lib.Types.AppIndex ( )
import Lib.Types.Category ( CategoryTitle(..) )
@@ -114,7 +105,6 @@ import Model ( Category(..)
, EosHash(EosHash, eosHashHash)
, Key(PkgRecordKey, unPkgRecordKey)
, OsVersion(..)
, PkgCategory
, PkgRecord(..)
, Unique(UniqueVersion)
, VersionRecord(..)
@@ -132,8 +122,6 @@ import UnliftIO.Async ( concurrently
import UnliftIO.Directory ( listDirectory )
import Util.Shared ( getVersionSpecFromQuery )
import Yesod.Core ( MonadResource
, ToContent(..)
, ToTypedContent(..)
, TypedContent
, YesodRequest(..)
, addHeader
@@ -158,115 +146,7 @@ import Database.Persist.Postgresql ( ConnectionPool )
import Control.Monad.Reader.Has ( Has
, ask
)
type URL = Text
newtype CategoryRes = CategoryRes {
categories :: [CategoryTitle]
} deriving (Show, Generic)
instance ToJSON CategoryRes
instance ToContent CategoryRes where
toContent = toContent . toJSON
instance ToTypedContent CategoryRes where
toTypedContent = toTypedContent . toJSON
data PackageRes = PackageRes
{ packageResIcon :: URL
, packageResManifest :: Data.Aeson.Value -- PackageManifest
, packageResCategories :: [CategoryTitle]
, packageResInstructions :: URL
, packageResLicense :: URL
, packageResVersions :: [Version]
, packageResDependencies :: HM.HashMap PkgId DependencyRes
}
deriving (Show, Generic)
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
deriving (Eq, Show)
instance ToJSON ReleaseNotes where
toJSON ReleaseNotes {..} = object [ t .= v | (k, v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ]
instance ToContent ReleaseNotes where
toContent = toContent . toJSON
instance ToTypedContent ReleaseNotes where
toTypedContent = toTypedContent . toJSON
instance ToJSON PackageRes where
toJSON PackageRes {..} = object
[ "icon" .= packageResIcon
, "license" .= packageResLicense
, "instructions" .= packageResInstructions
, "manifest" .= packageResManifest
, "categories" .= packageResCategories
, "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 { .. }
data DependencyRes = DependencyRes
{ dependencyResTitle :: PkgId
, dependencyResIcon :: URL
}
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 { .. }
newtype PackageListRes = PackageListRes [PackageRes]
deriving (Generic)
instance ToJSON PackageListRes
instance ToContent PackageListRes where
toContent = toContent . toJSON
instance ToTypedContent PackageListRes where
toTypedContent = toTypedContent . toJSON
newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version))
deriving (Show, Generic)
instance ToJSON VersionLatestRes
instance ToContent VersionLatestRes where
toContent = toContent . toJSON
instance ToTypedContent VersionLatestRes where
toTypedContent = toTypedContent . toJSON
data OrderArrangement = ASC | DESC
deriving (Eq, Show, Read)
data PackageListDefaults = PackageListDefaults
{ packageListOrder :: OrderArrangement
, packageListPageLimit :: Int -- the number of items per page
, packageListPageNumber :: Int -- the page you are on
, packageListCategory :: Maybe CategoryTitle
, packageListQuery :: Text
}
deriving (Eq, Show, Read)
data EosRes = EosRes
{ eosResVersion :: Version
, eosResHeadline :: Text
, eosResReleaseNotes :: ReleaseNotes
}
deriving (Eq, Show, Generic)
instance ToJSON EosRes where
toJSON EosRes {..} =
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
instance ToContent EosRes where
toContent = toContent . toJSON
instance ToTypedContent EosRes where
toTypedContent = toTypedContent . toJSON
data PackageReq = PackageReq
{ packageReqId :: PkgId
, packageReqVersion :: VersionRange
}
deriving Show
instance FromJSON PackageReq where
parseJSON = withObject "package version" $ \o -> do
packageReqId <- o .: "id"
packageReqVersion <- o .: "version"
pure PackageReq { .. }
import Handler.Types.Marketplace
getCategoriesR :: Handler CategoryRes
getCategoriesR = do
@@ -301,7 +181,8 @@ getReleaseNotesR = do
case lookup "id" getParameters of
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "<MISSING>")
Just package -> do
(_, notes) <- fetchAllAppVersions (PkgId package)
appConnPool <- appConnPool <$> getYesod
(_, notes) <- runDB $ fetchAllAppVersions appConnPool (PkgId package)
pure notes
getEosR :: Handler TypedContent
@@ -562,50 +443,3 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do
, dependencyResIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|]
}
)
fetchAllAppVersions :: PkgId -> Handler ([VersionInfo], ReleaseNotes)
fetchAllAppVersions appId = do
entityAppVersions <- runDB $ P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []
let vers = entityVal <$> entityAppVersions
let vv = mapSVersionToVersionInfo vers
let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv
pure (sortOn (Down . versionInfoVersion) vv, mappedVersions)
where
mapSVersionToVersionInfo :: [VersionRecord] -> [VersionInfo]
mapSVersionToVersionInfo sv = do
(\v -> VersionInfo { versionInfoVersion = versionRecordNumber v
, versionInfoReleaseNotes = versionRecordReleaseNotes v
, versionInfoDependencies = HM.empty
, versionInfoOsVersion = versionRecordOsVersion v
, versionInfoInstallAlert = Nothing
}
)
<$> sv
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)
fetchAppCategories :: MonadIO m => [PkgId] -> ReaderT SqlBackend m (HM.HashMap PkgId [Category])
fetchAppCategories appIds = do
raw <- select $ do
(sc :& app :& cat) <-
from
$ table @PkgCategory
`innerJoin` table @PkgRecord
`on` (\(sc :& app) -> sc ^. PkgCategoryPkgId ==. app ^. PkgRecordId)
`innerJoin` table @Category
`on` (\(sc :& _ :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
where_ (sc ^. PkgCategoryPkgId `in_` valList (PkgRecordKey <$> appIds))
pure (app ^. PkgRecordId, cat)
let ls = fmap (first (unPkgRecordKey . unValue) . second (pure . entityVal)) raw
pure $ HM.fromListWith (++) ls

122
src/Handler/Types/Marketplace.hs Normal file
View File

@@ -0,0 +1,122 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Handler.Types.Marketplace where
import Lib.Types.Category ( CategoryTitle )
import Data.Aeson
import Startlude
import Yesod
import qualified Data.HashMap.Internal.Strict as HM
import Lib.Types.Emver ( VersionRange
, Version
)
import Lib.Types.AppIndex ( PkgId )
type URL = Text
newtype CategoryRes = CategoryRes {
categories :: [CategoryTitle]
} deriving (Show, Generic)
instance ToJSON CategoryRes
instance ToContent CategoryRes where
toContent = toContent . toJSON
instance ToTypedContent CategoryRes where
toTypedContent = toTypedContent . toJSON
data PackageRes = PackageRes
{ packageResIcon :: URL
, packageResManifest :: Data.Aeson.Value -- PackageManifest
, packageResCategories :: [CategoryTitle]
, packageResInstructions :: URL
, packageResLicense :: URL
, packageResVersions :: [Version]
, packageResDependencies :: HM.HashMap PkgId DependencyRes
}
deriving (Show, Generic)
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
deriving (Eq, Show)
instance ToJSON ReleaseNotes where
toJSON ReleaseNotes {..} = object [ t .= v | (k, v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ]
instance ToContent ReleaseNotes where
toContent = toContent . toJSON
instance ToTypedContent ReleaseNotes where
toTypedContent = toTypedContent . toJSON
instance ToJSON PackageRes where
toJSON PackageRes {..} = object
[ "icon" .= packageResIcon
, "license" .= packageResLicense
, "instructions" .= packageResInstructions
, "manifest" .= packageResManifest
, "categories" .= packageResCategories
, "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 { .. }
data DependencyRes = DependencyRes
{ dependencyResTitle :: PkgId
, dependencyResIcon :: URL
}
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 { .. }
newtype PackageListRes = PackageListRes [PackageRes]
deriving (Generic)
instance ToJSON PackageListRes
instance ToContent PackageListRes where
toContent = toContent . toJSON
instance ToTypedContent PackageListRes where
toTypedContent = toTypedContent . toJSON
newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version))
deriving (Show, Generic)
instance ToJSON VersionLatestRes
instance ToContent VersionLatestRes where
toContent = toContent . toJSON
instance ToTypedContent VersionLatestRes where
toTypedContent = toTypedContent . toJSON
data OrderArrangement = ASC | DESC
deriving (Eq, Show, Read)
data PackageListDefaults = PackageListDefaults
{ packageListOrder :: OrderArrangement
, packageListPageLimit :: Int -- the number of items per page
, packageListPageNumber :: Int -- the page you are on
, packageListCategory :: Maybe CategoryTitle
, packageListQuery :: Text
}
deriving (Eq, Show, Read)
data EosRes = EosRes
{ eosResVersion :: Version
, eosResHeadline :: Text
, eosResReleaseNotes :: ReleaseNotes
}
deriving (Eq, Show, Generic)
instance ToJSON EosRes where
toJSON EosRes {..} =
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
instance ToContent EosRes where
toContent = toContent . toJSON
instance ToTypedContent EosRes where
toTypedContent = toTypedContent . toJSON
data PackageReq = PackageReq
{ packageReqId :: PkgId
, packageReqVersion :: VersionRange
}
deriving Show
instance FromJSON PackageReq where
parseJSON = withObject "package version" $ \o -> do
packageReqId <- o .: "id"
packageReqVersion <- o .: "version"
pure PackageReq { .. }

4
src/Lib/PkgRepository.hs
View File

@@ -143,6 +143,7 @@ getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m)
-> m (Maybe Version)
getBestVersion pkg spec = headMay . sortOn Down <$> getViableVersions pkg spec
-- TODO add loadDependencies
-- extract all package assets into their own respective files
extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m ()
extractPkg fp = handle @_ @SomeException cleanup $ do
@@ -193,7 +194,8 @@ watchPkgRepoRoot = do
stop <- watchTree watchManager root onlyAdded $ \evt -> do
let pkg = eventPath evt
-- TODO: validate that package path is an actual s9pk and is in a correctly conforming path.
void . forkIO $ runInIO (extractPkg pkg)
void . forkIO $ runInIO $ do
(extractPkg pkg)
takeMVar box
stop
pure $ tryPutMVar box ()

16
test/Handler/AppSpec.hs
View File

@@ -17,7 +17,7 @@ import Seed
import Lib.Types.AppIndex
import Data.Aeson
import Data.Either.Extra
import Handler.Marketplace ( PackageListRes )
import Handler.Marketplace ( PackageRes )
spec :: Spec
spec = do
@@ -27,7 +27,7 @@ spec = do
setMethod "GET"
setUrl ("/package/index" :: Text)
statusIs 200
(res :: PackageListRes) <- requireJSONResponse
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have two packages" (length res) 3
describe "GET /package/index?ids" $ withApp $ it "returns list of packages at specified version" $ do
_ <- seedBitcoinLndStack
@@ -35,7 +35,7 @@ spec = do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\"=0.21.1.2\"}]" :: Text)
statusIs 200
(res :: PackageListRes) <- requireJSONResponse
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
let (manifest :: PackageManifest) = fromRight' $ eitherDecode $ encode $ packageResManifest pkg
@@ -49,17 +49,17 @@ spec = do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"lnd\",\"version\":\"=0.13.3.1\"}]" :: Text)
statusIs 200
(res :: PackageListRes) <- requireJSONResponse
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
assertEq "package dependency metadata should not be empty" (null $ packageResDependencyInfo pkg) False
assertEq "package dependency metadata should not be empty" (null $ packageResDependencies pkg) False
describe "GET /package/index?ids" $ withApp $ it "returns list of packages at exactly specified version" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\"=0.21.1.1\"}]" :: Text)
statusIs 200
(res :: PackageListRes) <- requireJSONResponse
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
let (manifest :: PackageManifest) = fromRight' $ eitherDecode $ encode $ packageResManifest pkg
@@ -70,7 +70,7 @@ spec = do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\">=0.21.1.1\"}]" :: Text)
statusIs 200
(res :: PackageListRes) <- requireJSONResponse
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
let (manifest :: PackageManifest) = fromRight' $ eitherDecode $ encode $ packageResManifest pkg
@@ -81,7 +81,7 @@ spec = do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\">=0.21.1.2\"}]" :: Text)
statusIs 200
(res :: PackageListRes) <- requireJSONResponse
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
let (manifest :: PackageManifest) = fromRight' $ eitherDecode $ encode $ packageResManifest pkg