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

organization refactor separating database actions, data transformations, and api type constructs into separate components

Browse Source
This commit is contained in:
Lucy Cifferello
2021-12-02 08:06:47 -07:00
committed by Keagan McClelland
parent fe5218925d
commit 649f876692
13 changed files with 304 additions and 283 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
src/Application.hs
View File

@@ -132,13 +132,14 @@ makeFoundation appSettings = do
mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation")
logFunc = messageLoggerSource tempFoundation appLogger
stop <- runLoggingT (runReaderT watchPkgRepoRoot appSettings) logFunc
createDirectoryIfMissing True (errorLogRoot appSettings)
-- Create the database connection pool
pool <- flip runLoggingT logFunc
$ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings)
stop <- runLoggingT (runReaderT (watchPkgRepoRoot pool) appSettings) logFunc
-- Preform database migration using application logging settings
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc

127
src/Database/Marketplace.hs
View File

@@ -14,6 +14,7 @@ import Database.Esqueleto.Experimental
( (%)
, (&&.)
, (++.)
, (:&)(..)
, (==.)
, (^.)
, desc
@@ -25,37 +26,28 @@ import Database.Esqueleto.Experimental
, orderBy
, select
, selectSource
, table
, val
, valList
, where_
, (||.)
, Value(unValue)
)
import Database.Esqueleto.Experimental
( (:&)(..)
, table
)
import Lib.Types.AppIndex ( VersionInfo(..)
, PkgId
import qualified Database.Persist as P
import Database.Persist.Postgresql
hiding ( (==.)
, getJust
, selectSource
, (||.)
)
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Category
import Lib.Types.Emver ( Version
, VersionRange
)
import Lib.Types.Emver ( Version )
import Model
import Startlude hiding ( (%)
, from
, 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
@@ -101,46 +93,69 @@ getPkgData pkgs = selectSource $ do
where_ (pkgData ^. PkgRecordId `in_` valList (PkgRecordKey <$> pkgs))
pure pkgData
getPkgDependencyData :: MonadIO m
=> Key PkgRecord
-> Version
-> ReaderT SqlBackend m ([(Entity PkgDependency, Entity PkgRecord)])
getPkgDependencyData pkgId pkgVersion = select $ do
pd <- 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)
)
pure pd
zipCategories :: MonadUnliftIO m
=> ConduitT
(Entity PkgRecord, [Entity VersionRecord])
(Entity PkgRecord, [Entity VersionRecord], [Entity Category])
(ReaderT SqlBackend m)
()
zipCategories = awaitForever $ \(pkg, vers) -> do
let pkgDbId = entityKey pkg
raw <- lift $ select $ do
(sc :& cat) <-
from
$ table @PkgCategory
`innerJoin` table @Category
`on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
where_ (sc ^. PkgCategoryPkgId ==. val pkgDbId)
pure cat
yield (pkg, vers, raw)
zipVersions :: MonadUnliftIO m
=> ConduitT (Entity PkgRecord) (Entity PkgRecord, [Entity VersionRecord]) (ReaderT SqlBackend m) ()
zipVersions = awaitForever $ \i -> do
let appDbId = entityKey i
zipVersions = awaitForever $ \pkg -> do
let appDbId = entityKey pkg
res <- lift $ select $ do
v <- from $ table @VersionRecord
where_ $ v ^. VersionRecordPkgId ==. val appDbId
-- first value in list will be latest version
orderBy [desc (v ^. VersionRecordNumber)]
pure v
yield (i, res)
yield (pkg, res)
filterOsCompatible :: Monad m
=> (Version -> Bool)
-> ConduitT
(Entity PkgRecord, [Entity VersionRecord], VersionRange)
(Entity PkgRecord, [Entity VersionRecord], VersionRange)
m
()
filterOsCompatible p = awaitForever $ \(app, versions, requestedVersion) -> do
let compatible = filter (p . versionRecordOsVersion . entityVal) versions
when (not $ null compatible) $ yield (app, compatible, requestedVersion)
zipDependencyVersions :: (Monad m, MonadIO m)
=> (Entity PkgDependency, Entity PkgRecord)
-> ReaderT SqlBackend m (Entity PkgDependency, Entity PkgRecord, [Entity VersionRecord])
zipDependencyVersions (pkgDepRecord, depRecord) = do
let pkgDbId = entityKey $ depRecord
depVers <- select $ do
v <- from $ table @VersionRecord
where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
pure v
pure $ (pkgDepRecord, depRecord, depVers)
fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m ([VersionInfo], ReleaseNotes)
fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
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
pure $ entityVal <$> entityAppVersions
fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
fetchLatestApp appId = fmap headMay . sortResults . select $ do
@@ -152,19 +167,3 @@ fetchLatestApp appId = fmap headMay . sortResults . select $ do
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

4
src/Foundation.hs
View File

@@ -7,6 +7,7 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Foundation where
import Startlude hiding ( Handler )
@@ -75,9 +76,6 @@ instance Has AppSettings RegistryCtx where
extract = appSettings
update f ctx = ctx { appSettings = f (appSettings ctx) }
setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO ()
setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid

222
src/Handler/Marketplace.hs
View File

@@ -25,21 +25,11 @@ import Conduit ( (.|)
, sinkList
, sourceFile
, takeC
, MonadUnliftIO
)
import Control.Monad.Except.CoHas ( liftEither )
import Control.Parallel.Strategies ( parMap
, rpar
)
import Crypto.Hash ( SHA256 )
import Crypto.Hash.Conduit ( hashFile )
import Data.Aeson ( (.:)
, FromJSON(parseJSON)
, KeyValue((.=))
, ToJSON(toJSON)
, Value(String)
, decode
import Data.Aeson ( decode
, eitherDecode
, eitherDecodeStrict
)
@@ -54,7 +44,6 @@ import Data.List ( head
, lookup
, sortOn
)
import Data.Semigroup ( Max(Max, getMax) )
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
@@ -68,15 +57,13 @@ import Database.Esqueleto.Experimental
, select
, table
)
import Database.Marketplace ( filterOsCompatible
, getPkgData
import Database.Marketplace ( getPkgData
, searchServices
, zipVersions
, fetchAllAppVersions
, fetchLatestApp
, fetchAppCategories
, getPkgDependencyData, zipDependencyVersions, zipCategories
)
import qualified Database.Persist as P
import Database.Persist ( PersistUniqueRead(getBy)
, insertUnique
)
@@ -84,17 +71,16 @@ import Foundation ( Handler
, RegistryCtx(appSettings, appConnPool)
)
import Lib.Error ( S9Error(..)
, toStatus
)
import Lib.PkgRepository ( getManifest )
import Lib.Types.AppIndex ( PkgId(PkgId)
, PackageDependency(packageDependencyVersion)
, PackageManifest(packageManifestDependencies)
)
import Lib.Types.AppIndex ( )
import Lib.Types.Category ( CategoryTitle(..) )
import Lib.Types.Emver ( (<||)
, Version
import Lib.Types.Emver ( Version
, VersionRange(Any)
, parseRange
, parseVersion
@@ -103,7 +89,7 @@ import Lib.Types.Emver ( (<||)
import Model ( Category(..)
, EntityField(..)
, EosHash(EosHash, eosHashHash)
, Key(PkgRecordKey, unPkgRecordKey)
, Key(unPkgRecordKey)
, OsVersion(..)
, PkgRecord(..)
, Unique(UniqueVersion)
@@ -120,7 +106,7 @@ import UnliftIO.Async ( concurrently
, mapConcurrently
)
import UnliftIO.Directory ( listDirectory )
import Util.Shared ( getVersionSpecFromQuery )
import Util.Shared ( getVersionSpecFromQuery, filterLatestVersionFromSpec, filterPkgOsCompatible, filterDependencyOsCompatible, filterDependencyBestVersion )
import Yesod.Core ( MonadResource
, TypedContent
, YesodRequest(..)
@@ -136,13 +122,7 @@ import Yesod.Core ( MonadResource
)
import Yesod.Persist ( YesodDB )
import Yesod.Persist.Core ( YesodPersist(runDB) )
import Data.Tuple.Extra hiding ( second
, first
, (&&&)
)
import Control.Monad.Logger
import Database.Persist.Sql ( runSqlPool )
import Database.Persist.Postgresql ( ConnectionPool )
import Control.Monad.Reader.Has ( Has
, ask
)
@@ -182,8 +162,12 @@ getReleaseNotesR = do
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "<MISSING>")
Just package -> do
appConnPool <- appConnPool <$> getYesod
(_, notes) <- runDB $ fetchAllAppVersions appConnPool (PkgId package)
pure notes
versionRecords <- runDB $ fetchAllAppVersions appConnPool (PkgId package)
pure $ constructReleaseNotesApiRes versionRecords
where
constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes
constructReleaseNotesApiRes vers = do
ReleaseNotes $ HM.fromList $ sortOn (Down) $ (versionRecordNumber &&& versionRecordReleaseNotes) <$> vers
getEosR :: Handler TypedContent
getEosR = do
@@ -213,6 +197,7 @@ getEosR = do
void $ insertUnique (EosHash v t) -- lazily populate
pure t
-- TODO refactor with conduit
getVersionLatestR :: Handler VersionLatestRes
getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest
@@ -240,13 +225,6 @@ getPackageListR = do
Nothing -> const True
Just v -> flip satisfies v
pkgIds <- getPkgIdsQuery
-- deep info
-- generate data from db
-- filter os
-- filter from request
-- shallow info - generate get deps
-- transformations
-- assemble api response
filteredPackages <- case pkgIds of
Nothing -> do
-- query for all
@@ -258,8 +236,11 @@ getPackageListR = do
$ runConduit
$ searchServices category query
.| zipVersions
.| mapC (\(a, vs) -> (,,) a vs Any)
.| filterOsCompatible osPredicate
.| zipCategories
-- if no packages are specified, the VersionRange is implicitly `*`
.| mapC (\(a, vs, cats) -> (a, vs, cats,Any))
.| filterLatestVersionFromSpec
.| filterPkgOsCompatible osPredicate
-- pages start at 1 for some reason. TODO: make pages start at 0
.| (dropC (limit' * (page - 1)) *> takeC limit')
.| sinkList
@@ -267,26 +248,21 @@ getPackageListR = do
-- for each item in list get best available from version range
let vMap = (packageReqId &&& packageReqVersion) <$> packages'
runDB
-- TODO could probably be better with sequenceConduits
. runConduit
$ getPkgData (packageReqId <$> packages')
.| zipVersions
.| mapC
(\(a, vs) ->
let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) vMap
in (a, filter ((<|| spec) . versionRecordNumber . entityVal) vs, spec)
)
.| filterOsCompatible osPredicate
.| zipCategories
.| mapC (\(a, vs, cats) -> do
let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) vMap
(a, vs, cats, spec)
)
.| filterLatestVersionFromSpec
.| filterPkgOsCompatible osPredicate
.| sinkList
(keys, packageMetadata) <- runDB $ createPackageMetadata filteredPackages
appConnPool <- appConnPool <$> getYesod
serviceDetailResult <- mapConcurrently (getServiceDetails osPredicate appConnPool packageMetadata) keys
let (errors, res) = partitionEithers serviceDetailResult
case errors of
x : xs -> do
-- log all errors but just throw first error until Validation implemented - TODO https://hackage.haskell.org/package/validation
for_ xs (\e -> $logWarn [i|Get package list errors: #{e}|])
sendResponseStatus (toStatus x) x
[] -> pure $ PackageListRes res
-- 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
@@ -342,104 +318,36 @@ getPackageListR = do
$logWarn (show e)
sendResponseStatus status400 e
Right v -> pure $ Just v
mergeDupes :: ([Version], VersionRange) -> ([Version], VersionRange) -> ([Version], VersionRange)
mergeDupes (vs, vr) (vs', _) = (,) ((++) vs vs') vr
createPackageMetadata :: (MonadReader r m, MonadIO m)
=> [(Entity PkgRecord, [Entity VersionRecord], VersionRange)]
-> ReaderT
SqlBackend
m
([PkgId], HM.HashMap PkgId (([Version], VersionRange), [CategoryTitle]))
createPackageMetadata pkgs = do
let keys = unPkgRecordKey . entityKey . fst3 <$> pkgs
cats <- fetchAppCategories keys
let vers =
pkgs
<&> first3 (unPkgRecordKey . entityKey)
<&> second3 (sortOn Down . fmap (versionRecordNumber . entityVal))
<&> (\(a, vs, vr) -> (,) a $ (,) vs vr)
& HM.fromListWith mergeDupes
pure $ (keys, HM.intersectionWith (,) vers (categoryName <<$>> cats))
getServiceDetails :: (MonadResource m, MonadReader r m, MonadLogger m, Has AppSettings r, MonadUnliftIO m)
=> (Version -> Bool)
-> ConnectionPool
-> (HM.HashMap PkgId (([Version], VersionRange), [CategoryTitle]))
-> PkgId
-> m (Either S9Error PackageRes)
getServiceDetails osPredicate appConnPool metadata pkg = runExceptT $ do
settings <- ask
packageMetadata <- case HM.lookup pkg metadata of
Nothing -> liftEither . Left $ NotFoundE [i|#{pkg} not found.|]
Just m -> pure m
let domain = registryHostname settings
let versionInfo = fst $ (HM.!) metadata pkg
version <- case snd versionInfo of
Any -> do
-- grab first value, which will be the latest version
case fst versionInfo of
[] -> liftEither . Left $ NotFoundE $ [i|No latest version found for #{pkg}|]
x : _ -> pure x
spec -> case headMay . sortOn Down $ filter (`satisfies` spec) $ fst versionInfo of
Nothing -> liftEither . Left $ NotFoundE [i|No version for #{pkg} satisfying #{spec}|]
Just v -> pure v
manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs ->
runConduit $ bs .| CL.foldMap BS.fromStrict
case eitherDecode manifest of
Left _ -> liftEither . Left $ AssetParseE [i|#{pkg}:manifest|] (decodeUtf8 $ BS.toStrict manifest)
Right m -> do
let depVerList = (fst &&& (packageDependencyVersion . snd)) <$> (HM.toList $ packageManifestDependencies m)
(_, depMetadata) <- lift $ runSqlPool (createPackageMetadata =<< getDependencies depVerList) appConnPool
let (errors, deps) = partitionEithers $ parMap
rpar
(mapDependencyMetadata domain $ (HM.union depMetadata metadata))
(HM.toList $ packageManifestDependencies m)
case errors of
_ : xs -> liftEither . Left $ DepMetadataE xs
[] -> pure $ PackageRes { packageResIcon = [i|https://#{domain}/package/icon/#{pkg}|]
-- pass through raw JSON Value, we have checked its correct parsing above
, packageResManifest = unsafeFromJust . decode $ manifest
, packageResCategories = snd packageMetadata
, packageResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|]
, packageResLicense = [i|https://#{domain}/package/license/#{pkg}|]
, packageResVersions = fst . fst $ packageMetadata
, packageResDependencies = HM.fromList deps
}
where
getDependencies :: (MonadResource m, MonadUnliftIO m)
=> [(PkgId, VersionRange)]
-> ReaderT SqlBackend m [(Entity PkgRecord, [Entity VersionRecord], VersionRange)]
getDependencies deps =
runConduit
$ getPkgData (fst <$> deps)
.| zipVersions
.| mapC
(\(a, vs) ->
let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) deps
in (a, filter ((<|| spec) . versionRecordNumber . entityVal) vs, spec)
)
.| filterOsCompatible osPredicate
.| sinkList
mapDependencyMetadata :: Text
-> HM.HashMap PkgId (([Version], VersionRange), [CategoryTitle])
-> (PkgId, PackageDependency)
-> Either Text (PkgId, DependencyRes)
mapDependencyMetadata domain metadata (appId, depInfo) = do
depMetadata <- case HM.lookup appId metadata of
Nothing -> Left [i|dependency metadata for #{appId} not found.|]
Just m -> pure m
-- get best version from VersionRange of dependency
let satisfactory = filter (<|| packageDependencyVersion depInfo) (fst . fst $ depMetadata)
let best = getMax <$> foldMap (Just . Max) satisfactory
version <- case best of
Nothing -> Left [i|No satisfactory version for dependent package #{appId}|]
Just v -> pure v
pure
( appId
, DependencyRes { dependencyResTitle = appId
, dependencyResIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|]
getPackageDependencies :: (MonadIO m, MonadLogger m) => (Version -> Bool) -> (Entity PkgRecord, [Entity VersionRecord], [Entity Category], Version) -> ReaderT SqlBackend m (Key PkgRecord, [Category], [Version], Version, [(Key PkgRecord, Text, Version)])
getPackageDependencies osPredicate (pkg, pkgVersions, pkgCategories, pkgVersion) = do
let pkgId = entityKey pkg
let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions
let pkgCategories' = entityVal <$> pkgCategories
pkgDepInfo <- getPkgDependencyData pkgId pkgVersion
pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo
let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions
res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo
pure $ (pkgId, pkgCategories', pkgVersions', pkgVersion, res)
constructPackageListApiRes :: (Monad m, MonadResource m, MonadReader r m, Has AppSettings r) => (Key PkgRecord, [Category], [Version], Version, [(Key PkgRecord, Text, Version)]) -> m PackageRes
constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do
settings <- ask
let pkgId = unPkgRecordKey pkgKey
let domain = registryHostname settings
manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs ->
runConduit $ bs .| CL.foldMap BS.fromStrict
pure $ PackageRes { packageResIcon = [i|https://#{domain}/package/icon/#{pkgId}|]
-- pass through raw JSON Value, we have checked its correct parsing above
, packageResManifest = unsafeFromJust . decode $ manifest
, packageResCategories = categoryName <$> pkgCategories
, packageResInstructions = [i|https://#{domain}/package/instructions/#{pkgId}|]
, packageResLicense = [i|https://#{domain}/package/license/#{pkgId}|]
, packageResVersions = pkgVersions
, packageResDependencies = HM.fromList $ constructDependenciesApiRes domain dependencies
}
)
constructDependenciesApiRes :: Text
-> [(Key PkgRecord, Text, Version)]
-> [(PkgId, DependencyRes)]
constructDependenciesApiRes domain deps = fmap (\(depKey, depTitle, depVersion) -> do
let depId = unPkgRecordKey depKey
(depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = [i|https://#{domain}/package/icon/#{depId}?spec==#{depVersion}|]})) deps

27
src/Handler/Types/Marketplace.hs
View File

@@ -1,15 +1,16 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Handler.Types.Marketplace where
import Lib.Types.Category ( CategoryTitle )
import Data.Aeson
import qualified Data.HashMap.Internal.Strict as HM
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Category ( CategoryTitle )
import Lib.Types.Emver ( Version
, VersionRange
)
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
@@ -22,12 +23,12 @@ instance ToContent CategoryRes where
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]
{ packageResIcon :: URL
, packageResManifest :: Data.Aeson.Value -- PackageManifest
, packageResCategories :: [CategoryTitle]
, packageResInstructions :: URL
, packageResLicense :: URL
, packageResVersions :: [Version]
, packageResDependencies :: HM.HashMap PkgId DependencyRes
}
deriving (Show, Generic)
@@ -60,7 +61,7 @@ instance FromJSON PackageRes where
packageResDependencies <- o .: "dependency-metadata"
pure PackageRes { .. }
data DependencyRes = DependencyRes
{ dependencyResTitle :: PkgId
{ dependencyResTitle :: Text -- TODO switch to `Text` to display actual title in Marketplace. Confirm with FE that this will not break loading. Perhaps return title and id?
, dependencyResIcon :: URL
}
deriving (Eq, Show)

6
src/Lib/Error.hs
View File

@@ -8,7 +8,6 @@ import Startlude
import Data.String.Interpolate.IsString
import Network.HTTP.Types
import Yesod.Core
import qualified Data.Text as T
type S9ErrT m = ExceptT S9Error m
@@ -18,7 +17,6 @@ data S9Error =
| NotFoundE Text
| InvalidParamsE Text Text
| AssetParseE Text Text
| DepMetadataE [Text]
deriving (Show, Eq)
instance Exception S9Error
@@ -31,9 +29,6 @@ toError = \case
NotFoundE e -> Error NOT_FOUND [i|#{e}|]
InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|]
AssetParseE asset found -> Error PARSE_ERROR [i|Could not parse #{asset}: #{found}|]
DepMetadataE errs -> do
let errorText = T.concat errs
Error NOT_FOUND [i|#{errorText}|]
data ErrorCode =
DATABASE_ERROR
@@ -69,4 +64,3 @@ toStatus = \case
NotFoundE _ -> status404
InvalidParamsE _ _ -> status400
AssetParseE _ _ -> status500
DepMetadataE _ -> status404

54
src/Lib/PkgRepository.hs
View File

@@ -31,19 +31,33 @@ import qualified Data.Attoparsec.Text as Atto
import Data.ByteString ( readFile
, writeFile
)
import qualified Data.HashMap.Strict as HM
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
import Data.Time ( getCurrentTime )
import Database.Esqueleto.Experimental
( ConnectionPool
, insertUnique
, runSqlPool
)
import Lib.Error ( S9Error(NotFoundE) )
import qualified Lib.External.AppMgr as AppMgr
import Lib.Types.AppIndex ( PkgId(..)
, PackageManifest(packageManifestIcon)
import Lib.Types.AppIndex ( PackageManifest
( packageManifestIcon
, packageManifestId
, packageManifestVersion
)
, PkgId(..)
, packageDependencyVersion
, packageManifestDependencies
)
import Lib.Types.Emver ( Version
, VersionRange
, parseVersion
, satisfies
)
import Model
import Startlude ( ($)
, (&&)
, (.)
@@ -62,14 +76,18 @@ import Startlude ( ($)
, MonadReader
, Show
, SomeException(..)
, Traversable(traverse)
, filter
, find
, first
, for_
, fst
, headMay
, not
, partitionEithers
, pure
, show
, snd
, sortOn
, throwIO
, void
@@ -111,7 +129,6 @@ import Yesod.Core.Content ( typeGif
, typeSvg
)
import Yesod.Core.Types ( ContentType )
data ManifestParseException = ManifestParseException FilePath
deriving Show
instance Exception ManifestParseException
@@ -143,10 +160,28 @@ 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
loadPkgDependencies :: MonadUnliftIO m => ConnectionPool -> PackageManifest -> m ()
loadPkgDependencies appConnPool manifest = do
let pkgId = packageManifestId manifest
let pkgVersion = packageManifestVersion manifest
let deps = packageManifestDependencies manifest
time <- liftIO getCurrentTime
let deps' = first PkgRecordKey <$> HM.toList deps
_ <- traverse
(\d ->
(runSqlPool
( insertUnique
$ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d)
)
appConnPool
)
)
deps'
pure ()
-- 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
extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m ()
extractPkg pool fp = handle @_ @SomeException cleanup $ do
$logInfo [i|Extracting package: #{fp}|]
PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask
let pkgRoot = takeDirectory fp
@@ -169,6 +204,7 @@ extractPkg fp = handle @_ @SomeException cleanup $ do
Just x -> case takeExtension (T.unpack x) of
"" -> "png"
other -> other
loadPkgDependencies pool manifest
liftIO $ renameFile (pkgRoot </> "icon.tmp") (pkgRoot </> iconDest)
hash <- wait pkgHashTask
liftIO $ writeFile (pkgRoot </> "hash.bin") hash
@@ -184,8 +220,8 @@ extractPkg fp = handle @_ @SomeException cleanup $ do
mapConcurrently_ (removeFile . (pkgRoot </>)) toRemove
throwIO e
watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => m (IO Bool)
watchPkgRepoRoot = do
watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool)
watchPkgRepoRoot pool = do
$logInfo "Starting FSNotify Watch Manager"
root <- asks pkgRepoFileRoot
runInIO <- askRunInIO
@@ -195,7 +231,7 @@ watchPkgRepoRoot = do
let pkg = eventPath evt
-- TODO: validate that package path is an actual s9pk and is in a correctly conforming path.
void . forkIO $ runInIO $ do
(extractPkg pkg)
(extractPkg pool pkg)
takeMVar box
stop
pure $ tryPutMVar box ()

2
src/Lib/Types/AppIndex.hs
View File

@@ -17,7 +17,6 @@ import Data.Aeson ( (.:)
, ToJSON(..)
, ToJSONKey(..)
, withObject
, eitherDecode
)
import qualified Data.ByteString.Lazy as BS
import Data.Functor.Contravariant ( contramap )
@@ -77,7 +76,6 @@ data VersionInfo = VersionInfo
}
deriving (Eq, Show)
-- TODO rename to PackageDependencyInfo
data PackageDependency = PackageDependency
{ packageDependencyOptional :: Maybe Text
, packageDependencyVersion :: VersionRange

4
src/Model.hs
View File

@@ -17,7 +17,6 @@ import Lib.Types.Category
import Lib.Types.Emver
import Orphans.Emver ( )
import Startlude
import Yesod.Persist ( PersistFilter(Eq) )
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
PkgRecord
@@ -92,13 +91,14 @@ ErrorLogRecord
message Text
incidents Word32
UniqueLogRecord epoch commitHash sourceFile line target level message
PkgDependency
createdAt UTCTime
pkgId PkgRecordId
pkgVersion Version
depId PkgRecordId
depVersionRange VersionRange
UniquePkgVersion pkgId pkgVersion
UniquePkgDepVersion pkgId pkgVersion depId
deriving Eq
deriving Show
|]

77
src/Util/Shared.hs
View File

@@ -1,20 +1,45 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
module Util.Shared where
import Startlude hiding ( Handler )
import Startlude hiding ( Handler
, yield
)
import qualified Data.Text as T
import Network.HTTP.Types
import Yesod.Core
import Conduit ( ConduitT
, awaitForever
, yield
)
import Control.Monad.Reader.Has ( Has )
import Data.Semigroup ( Max(Max)
, getMax
)
import Data.String.Interpolate.IsString
( i )
import Database.Esqueleto.Experimental
( Entity
, Key
, entityKey
, entityVal
)
import Foundation
import Lib.PkgRepository ( PkgRepo
, getHash
)
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver
import Model ( Category
, PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange)
, PkgRecord(pkgRecordTitle)
, VersionRecord(versionRecordNumber, versionRecordOsVersion)
, pkgDependencyPkgId
)
getVersionSpecFromQuery :: Handler VersionRange
getVersionSpecFromQuery = do
@@ -32,3 +57,53 @@ orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
orThrow action other = action >>= \case
Nothing -> other
Just x -> pure x
filterPkgOsCompatible :: Monad m
=> (Version -> Bool)
-> ConduitT
(Entity PkgRecord, [Entity VersionRecord], [Entity Category], Version)
(Entity PkgRecord, [Entity VersionRecord], [Entity Category], Version)
m
()
filterPkgOsCompatible p = awaitForever $ \(app, versions, cats, requestedVersion) -> do
let compatible = filter (p . versionRecordOsVersion . entityVal) versions
when (not $ null compatible) $ yield (app, compatible, cats, requestedVersion)
filterDependencyOsCompatible :: (Version -> Bool)
-> (Entity PkgDependency, Entity PkgRecord, [Entity VersionRecord])
-> (Entity PkgDependency, Entity PkgRecord, [Entity VersionRecord])
filterDependencyOsCompatible p (pkgDeps, pkg, versions) = do
let compatible = filter (p . versionRecordOsVersion . entityVal) versions
(pkgDeps, pkg, compatible)
filterLatestVersionFromSpec :: (Monad m, MonadLogger m)
=> ConduitT
(Entity PkgRecord, [Entity VersionRecord], [Entity Category], VersionRange)
(Entity PkgRecord, [Entity VersionRecord], [Entity Category], Version)
m
()
filterLatestVersionFromSpec = awaitForever $ \(a, vs, cats, spec) -> do
let pkgId = entityKey a
case headMay . sortOn Down $ filter (`satisfies` spec) $ fmap (versionRecordNumber . entityVal) vs of
Nothing -> $logInfo [i|No version for #{pkgId} satisfying #{spec}|]
Just v -> yield $ (,,,) a vs cats v
-- 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
=> (Entity PkgDependency, Entity PkgRecord, [Entity VersionRecord])
-> m (Maybe (Key PkgRecord, Text, Version))
filterDependencyBestVersion (pkgDepRecord, depPkgRecord, depVersions) = do
-- get best version from VersionRange of dependency
let pkgId = pkgDependencyPkgId $ entityVal pkgDepRecord
let depId = pkgDependencyDepId $ entityVal pkgDepRecord
let depTitle = pkgRecordTitle $ entityVal depPkgRecord
let satisfactory = filter (<|| (pkgDependencyDepVersionRange $ entityVal pkgDepRecord))
(versionRecordNumber . entityVal <$> depVersions)
case getMax <$> foldMap (Just . Max) satisfactory of
-- QUESTION is this an acceptable transformation here? These are the only values that we care about after this filter.
Just bestVersion -> pure $ Just (depId, depTitle, bestVersion)
Nothing -> do
$logInfo [i|No satisfactory version of #{depId} for dependent package #{pkgId}|]
-- TODO it would be better if we could return the requirements for display
pure Nothing

1
stack.yaml
View File

@@ -44,6 +44,7 @@ extra-deps:
- esqueleto-3.5.1.0
- monad-logger-extras-0.1.1.1
- wai-request-spec-0.10.2.4
- data-tree-print-0.1.0.2
# Override default flag values for local packages and extra-deps
# flags: {}

22
test/Handler/AppSpec.hs
View File

@@ -3,21 +3,19 @@
module Handler.AppSpec
( spec
)
where
) where
import Startlude
import Database.Persist.Sql
import Data.Maybe
import Database.Persist.Sql
import Startlude
import TestImport
import Model
import Handler.Marketplace
import Seed
import Lib.Types.AppIndex
import Data.Aeson
import Data.Either.Extra
import Handler.Marketplace ( PackageRes )
import Handler.Types.Marketplace ( PackageRes(packageResDependencies, packageResManifest) )
import Lib.Types.AppIndex
import Model
import Seed
import TestImport
spec :: Spec
spec = do
@@ -92,13 +90,13 @@ spec = do
setMethod "GET"
setUrl ("/package/bitcoind.s9pk?spec==0.20.0" :: Text)
statusIs 404
xdescribe "GET /package/:pkgId with unknown package" $ withApp $ it "fails to get an unregistered app" $ do
describe "GET /package/:pkgId with unknown package" $ withApp $ it "fails to get an unregistered app" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/tempapp.s9pk?spec=0.0.1" :: Text)
statusIs 404
xdescribe "GET /package/:pkgId with package at unknown version"
describe "GET /package/:pkgId with package at unknown version"
$ withApp
$ it "fails to get an unregistered app"
$ do

38
test/Seed.hs
View File

@@ -1,25 +1,27 @@
module Seed where
import Startlude ( ($)
, Applicative(pure)
, Maybe(Nothing, Just)
, getCurrentTime
, MonadIO(liftIO)
)
import Database.Persist.Sql ( PersistStoreWrite(insert_, insertKey, insert) )
import Model ( Key(PkgRecordKey)
, PkgRecord(PkgRecord)
, Category(Category)
import Database.Persist.Sql ( PersistStoreWrite(insert, insertKey, insert_) )
import Model ( Category(Category)
, Key(PkgRecordKey)
, PkgCategory(PkgCategory)
, PkgDependency(PkgDependency)
, PkgRecord(PkgRecord)
, VersionRecord(VersionRecord)
)
import Startlude ( ($)
, Applicative(pure)
, Maybe(Just, Nothing)
, MonadIO(liftIO)
, getCurrentTime
)
import TestImport ( runDBtest
, RegistryCtx
import Lib.Types.Category ( CategoryTitle(BITCOIN, FEATURED, LIGHTNING) )
import Prelude ( read )
import TestImport ( RegistryCtx
, SIO
, YesodExampleData
, runDBtest
)
import Lib.Types.Category ( CategoryTitle(LIGHTNING, FEATURED, BITCOIN) )
seedBitcoinLndStack :: SIO (YesodExampleData RegistryCtx) ()
seedBitcoinLndStack = do
@@ -73,4 +75,14 @@ seedBitcoinLndStack = do
_ <- runDBtest $ insert_ $ PkgCategory time (PkgRecordKey "lnd") btcCat
_ <- runDBtest $ insert_ $ PkgCategory time (PkgRecordKey "bitcoind") btcCat
_ <- runDBtest $ insert_ $ PkgCategory time (PkgRecordKey "btc-rpc-proxy") btcCat
_ <- runDBtest $ insert_ $ PkgDependency time
(PkgRecordKey "lnd")
"0.13.3.1"
(PkgRecordKey "bitcoind")
(read ">=0.21.1.2 <0.22.0")
_ <- runDBtest $ insert_ $ PkgDependency time
(PkgRecordKey "lnd")
"0.13.3.1"
(PkgRecordKey "btc-rpc-proxy")
(read ">=0.3.2.1 <0.4.0")
pure ()