mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 10:21:51 +00:00
changes serialization scheme for v1 api
This commit is contained in:
Keagan McClelland
@@ -54,6 +54,9 @@ dependencies:
|
||||
- protolude
|
||||
- rainbow
|
||||
- shakespeare
|
||||
- singletons # sorry
|
||||
- singletons-base # sorry
|
||||
- singletons-th # sorry
|
||||
- template-haskell
|
||||
- terminal-progress-bar
|
||||
- text
|
||||
|
||||
@@ -1,8 +1,11 @@
|
||||
module Handler.Package where
|
||||
|
||||
import Data.Singletons (TyCon)
|
||||
import Data.Singletons.Sigma (Sigma (..))
|
||||
import Foundation (Handler)
|
||||
import Handler.Package.Api (PackageListRes)
|
||||
import Handler.Package.V0.Icon qualified
|
||||
import Handler.Package.V0.Index (PackageListRes, getPackageIndexR)
|
||||
import Handler.Package.V0.Index qualified
|
||||
import Handler.Package.V0.Info (InfoRes, getInfoR)
|
||||
import Handler.Package.V0.Instructions qualified
|
||||
import Handler.Package.V0.Latest (VersionLatestRes, getVersionLatestR)
|
||||
@@ -11,8 +14,10 @@ import Handler.Package.V0.Manifest qualified
|
||||
import Handler.Package.V0.ReleaseNotes (ReleaseNotes, getReleaseNotesR)
|
||||
import Handler.Package.V0.S9PK qualified
|
||||
import Handler.Package.V0.Version (AppVersionRes, getPkgVersionR)
|
||||
import Handler.Types.Api (ApiVersion (..))
|
||||
import Handler.Package.V1.Index (getPackageIndexR)
|
||||
import Handler.Types.Api (ApiVersion (..), SApiVersion (..))
|
||||
import Lib.Types.Core (PkgId, S9PK)
|
||||
import Startlude (fmap)
|
||||
import Yesod.Core.Types (
|
||||
JSONResponse,
|
||||
TypedContent,
|
||||
@@ -23,8 +28,9 @@ getInfoR :: ApiVersion -> Handler (JSONResponse InfoRes)
|
||||
getInfoR _ = Handler.Package.V0.Info.getInfoR
|
||||
|
||||
|
||||
getPackageIndexR :: ApiVersion -> Handler PackageListRes
|
||||
getPackageIndexR _ = Handler.Package.V0.Index.getPackageIndexR
|
||||
getPackageIndexR :: ApiVersion -> Handler (Sigma ApiVersion (TyCon PackageListRes))
|
||||
getPackageIndexR V0 = fmap (SV0 :&:) Handler.Package.V0.Index.getPackageIndexR
|
||||
getPackageIndexR V1 = fmap (SV1 :&:) Handler.Package.V1.Index.getPackageIndexR
|
||||
|
||||
|
||||
getVersionLatestR :: ApiVersion -> Handler VersionLatestRes
|
||||
|
||||
94
src/Handler/Package/Api.hs
Normal file
94
src/Handler/Package/Api.hs
Normal file
@@ -0,0 +1,94 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Handler.Package.Api where
|
||||
|
||||
import Data.ByteString.Base64 (encodeBase64)
|
||||
import Data.HashMap.Strict
|
||||
import Data.Singletons (TyCon)
|
||||
import Data.Singletons.Sigma (Sigma (..))
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Handler.Types.Api (ApiVersion (..), SApiVersion (..))
|
||||
import Lib.Types.Core
|
||||
import Lib.Types.Emver
|
||||
import Startlude
|
||||
import Yesod
|
||||
|
||||
|
||||
dataUrl :: (ContentType, ByteString) -> Text
|
||||
dataUrl (ct, payload) = [i|data:#{ct};base64,#{encodeBase64 payload}|]
|
||||
|
||||
|
||||
type PackageListRes :: ApiVersion -> Type
|
||||
newtype PackageListRes a = PackageListRes [PackageRes a]
|
||||
deriving (Generic)
|
||||
instance ToJSON (PackageRes a) => ToJSON (PackageListRes a) where
|
||||
toJSON (PackageListRes a) = toJSON a
|
||||
instance ToJSON (PackageRes a) => ToContent (PackageListRes a) where
|
||||
toContent = toContent . toJSON
|
||||
instance ToJSON (PackageRes a) => ToTypedContent (PackageListRes a) where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
|
||||
data PackageRes a = PackageRes
|
||||
{ packageResIcon :: !(ContentType, ByteString)
|
||||
, packageResManifest :: !Value -- PackageManifest
|
||||
, packageResCategories :: ![Text]
|
||||
, packageResInstructions :: !Text
|
||||
, packageResLicense :: !Text
|
||||
, packageResVersions :: !(NonEmpty Version)
|
||||
, packageResDependencies :: !(HashMap PkgId (DependencyRes a))
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
|
||||
instance ToJSON (PackageRes 'V0) where
|
||||
toJSON PackageRes{..} =
|
||||
object
|
||||
[ "icon" .= encodeBase64 (snd packageResIcon)
|
||||
, "license" .= packageResLicense
|
||||
, "instructions" .= packageResInstructions
|
||||
, "manifest" .= packageResManifest
|
||||
, "categories" .= packageResCategories
|
||||
, "versions" .= packageResVersions
|
||||
, "dependency-metadata" .= packageResDependencies
|
||||
]
|
||||
instance ToJSON (PackageRes 'V1) where
|
||||
toJSON PackageRes{..} =
|
||||
object
|
||||
[ "icon" .= dataUrl packageResIcon
|
||||
, "license" .= packageResLicense
|
||||
, "instructions" .= packageResInstructions
|
||||
, "manifest" .= packageResManifest
|
||||
, "categories" .= packageResCategories
|
||||
, "versions" .= packageResVersions
|
||||
, "dependency-metadata" .= packageResDependencies
|
||||
]
|
||||
|
||||
|
||||
instance ToJSON (Sigma ApiVersion (TyCon PackageListRes)) where
|
||||
toJSON (s :&: t) = case s of
|
||||
SV0 -> toJSON t
|
||||
SV1 -> toJSON t
|
||||
instance ToContent (Sigma ApiVersion (TyCon PackageListRes)) where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent (Sigma ApiVersion (TyCon PackageListRes)) where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
|
||||
type DependencyRes :: ApiVersion -> Type
|
||||
data DependencyRes a = DependencyRes
|
||||
{ dependencyResTitle :: !Text
|
||||
, dependencyResIcon :: !(ContentType, ByteString)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
instance ToJSON (DependencyRes 'V0) where
|
||||
toJSON DependencyRes{..} = object ["icon" .= encodeBase64 (snd dependencyResIcon), "title" .= dependencyResTitle]
|
||||
instance ToJSON (DependencyRes 'V1) where
|
||||
toJSON DependencyRes{..} = object ["icon" .= dataUrl dependencyResIcon, "title" .= dependencyResTitle]
|
||||
@@ -1,302 +1,16 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# 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, lift)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..), Value, decode, eitherDecodeStrict, object, withObject, (.:), (.=))
|
||||
import Data.Attoparsec.Text qualified as Atto
|
||||
import Data.ByteString.Base64 (encodeBase64)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Conduit.List qualified as CL
|
||||
import Data.HashMap.Internal.Strict (HashMap)
|
||||
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.Persist.Sql (SqlBackend)
|
||||
import Database.Queries (
|
||||
collateVersions,
|
||||
getCategoriesFor,
|
||||
getDependencyVersions,
|
||||
getPkgDataSource,
|
||||
getPkgDependencyData,
|
||||
serviceQuerySource,
|
||||
)
|
||||
import Foundation (Handler, Route (InstructionsR, LicenseR))
|
||||
import Foundation (Handler)
|
||||
import Handler.Package.Api (PackageListRes)
|
||||
import Handler.Package.V1.Index qualified
|
||||
import Handler.Types.Api (ApiVersion (..))
|
||||
import Handler.Util (basicRender)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (PkgRepo, getIcon, getManifest)
|
||||
import Lib.Types.Core (PkgId)
|
||||
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 (..),
|
||||
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)
|
||||
import Startlude ((<$>))
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
|
||||
|
||||
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{..}
|
||||
|
||||
|
||||
data PackageRes = PackageRes
|
||||
{ packageResIcon :: !Text
|
||||
, packageResManifest :: !Value -- PackageManifest
|
||||
, packageResCategories :: ![Text]
|
||||
, packageResInstructions :: !Text
|
||||
, packageResLicense :: !Text
|
||||
, packageResVersions :: !(NonEmpty Version)
|
||||
, packageResDependencies :: !(HashMap PkgId DependencyRes)
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
instance ToJSON PackageRes where
|
||||
toJSON PackageRes{..} =
|
||||
object
|
||||
[ "icon" .= packageResIcon
|
||||
, "license" .= packageResLicense
|
||||
, "instructions" .= packageResInstructions
|
||||
, "manifest" .= packageResManifest
|
||||
, "categories" .= packageResCategories
|
||||
, "versions" .= packageResVersions
|
||||
, "dependency-metadata" .= packageResDependencies
|
||||
]
|
||||
|
||||
|
||||
newtype PackageListRes = PackageListRes [PackageRes]
|
||||
deriving (Generic)
|
||||
instance ToJSON PackageListRes
|
||||
instance ToContent PackageListRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent PackageListRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
|
||||
data DependencyRes = DependencyRes
|
||||
{ dependencyResTitle :: !Text
|
||||
, dependencyResIcon :: !Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON DependencyRes where
|
||||
toJSON DependencyRes{..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle]
|
||||
|
||||
|
||||
data PackageMetadata = PackageMetadata
|
||||
{ packageMetadataPkgId :: !PkgId
|
||||
, packageMetadataPkgVersionRecords :: !(NonEmpty VersionRecord)
|
||||
, packageMetadataPkgVersion :: !Version
|
||||
, packageMetadataPkgCategories :: ![Category]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
getPackageIndexR :: Handler PackageListRes
|
||||
getPackageIndexR = do
|
||||
osPredicate <-
|
||||
getOsVersionQuery <&> \case
|
||||
Nothing -> const True
|
||||
Just v -> flip satisfies v
|
||||
pkgIds <- getPkgIdsQuery
|
||||
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
|
||||
.| 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 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 <$> 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
|
||||
-- this use of unsafecoerce is OK because the 'V0 witness does not appear in any way in the representation
|
||||
getPackageIndexR :: Handler (PackageListRes 'V0)
|
||||
getPackageIndexR = unsafeCoerce <$> Handler.Package.V1.Index.getPackageIndexR
|
||||
261
src/Handler/Package/V1/Index.hs
Normal file
261
src/Handler/Package/V1/Index.hs
Normal file
@@ -0,0 +1,261 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Handler.Package.V1.Index where
|
||||
|
||||
import Conduit (concatMapC, dropC, mapC, mapMC, runConduit, sinkList, takeC, (.|))
|
||||
import Control.Monad.Reader.Has (Functor (fmap), Has, Monad ((>>=)), MonadReader, ReaderT (runReaderT), ask, lift)
|
||||
import Data.Aeson (FromJSON (..), decode, eitherDecodeStrict, withObject, (.:))
|
||||
import Data.Attoparsec.Text qualified as Atto
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Conduit.List qualified as CL
|
||||
import Data.HashMap.Internal.Strict (HashMap)
|
||||
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.Persist.Sql (SqlBackend)
|
||||
import Database.Queries (
|
||||
collateVersions,
|
||||
getCategoriesFor,
|
||||
getDependencyVersions,
|
||||
getPkgDataSource,
|
||||
getPkgDependencyData,
|
||||
serviceQuerySource,
|
||||
)
|
||||
import Foundation (Handler, Route (InstructionsR, LicenseR))
|
||||
import Handler.Package.Api (DependencyRes (..), PackageListRes (..), PackageRes (..))
|
||||
import Handler.Types.Api (ApiVersion (..))
|
||||
import Handler.Util (basicRender)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (PkgRepo, getIcon, getManifest)
|
||||
import Lib.Types.Core (PkgId)
|
||||
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 (..),
|
||||
Bool (..),
|
||||
ByteString,
|
||||
ConvertText (toS),
|
||||
Down (..),
|
||||
Either (..),
|
||||
Eq (..),
|
||||
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 (
|
||||
ContentType,
|
||||
MonadLogger,
|
||||
MonadResource,
|
||||
YesodPersist (runDB),
|
||||
lookupGetParam,
|
||||
sendResponseStatus,
|
||||
)
|
||||
import Yesod.Core (logWarn)
|
||||
|
||||
|
||||
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{..}
|
||||
|
||||
|
||||
data PackageMetadata = PackageMetadata
|
||||
{ packageMetadataPkgId :: !PkgId
|
||||
, packageMetadataPkgVersionRecords :: !(NonEmpty VersionRecord)
|
||||
, packageMetadataPkgVersion :: !Version
|
||||
, packageMetadataPkgCategories :: ![Category]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
getPackageIndexR :: Handler (PackageListRes 'V1)
|
||||
getPackageIndexR = do
|
||||
osPredicate <-
|
||||
getOsVersionQuery <&> \case
|
||||
Nothing -> const True
|
||||
Just v -> flip satisfies v
|
||||
pkgIds <- getPkgIdsQuery
|
||||
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
|
||||
.| 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 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 <$> 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 'V1))
|
||||
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 <- loadIcon depId v
|
||||
pure $ (depId, DependencyRes title icon)
|
||||
|
||||
|
||||
constructPackageListApiRes ::
|
||||
(MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) =>
|
||||
PackageMetadata ->
|
||||
HashMap PkgId (DependencyRes a) ->
|
||||
m (PackageRes a)
|
||||
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 = icon
|
||||
, 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 (ContentType, ByteString)
|
||||
loadIcon pkg version = do
|
||||
(ct, _, src) <- getIcon pkg version
|
||||
buffered <- runConduit $ src .| CL.foldMap id
|
||||
pure (ct, buffered)
|
||||
|
||||
|
||||
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
|
||||
@@ -1,7 +1,16 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Handler.Types.Api where
|
||||
|
||||
import Data.Ord.Singletons
|
||||
import Data.Singletons.TH
|
||||
import GHC.Read (Read (..))
|
||||
import GHC.Show (show)
|
||||
import Prelude.Singletons
|
||||
import Startlude (
|
||||
Eq,
|
||||
Maybe (..),
|
||||
@@ -11,10 +20,14 @@ import Startlude (
|
||||
import Yesod (PathPiece (..))
|
||||
|
||||
|
||||
data ApiVersion
|
||||
= V0
|
||||
| V1
|
||||
deriving (Eq, Ord)
|
||||
$( singletons
|
||||
[d|
|
||||
data ApiVersion
|
||||
= V0
|
||||
| V1
|
||||
deriving (Eq, Ord)
|
||||
|]
|
||||
)
|
||||
|
||||
|
||||
instance Show ApiVersion where
|
||||
|
||||
Reference in New Issue
Block a user