From c7453747d42e201a1338913d19ab42d258b7cb78 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Fri, 10 Jun 2022 15:32:30 -0600 Subject: [PATCH] changes serialization scheme for v1 api --- package.yaml | 3 + src/Handler/Package.hs | 14 +- src/Handler/Package/Api.hs | 94 ++++++++++ src/Handler/Package/V0/Index.hs | 304 +------------------------------- src/Handler/Package/V1/Index.hs | 261 +++++++++++++++++++++++++++ src/Handler/Types/Api.hs | 21 ++- 6 files changed, 394 insertions(+), 303 deletions(-) create mode 100644 src/Handler/Package/Api.hs create mode 100644 src/Handler/Package/V1/Index.hs diff --git a/package.yaml b/package.yaml index 193d575..ea09054 100644 --- a/package.yaml +++ b/package.yaml @@ -54,6 +54,9 @@ dependencies: - protolude - rainbow - shakespeare + - singletons # sorry + - singletons-base # sorry + - singletons-th # sorry - template-haskell - terminal-progress-bar - text diff --git a/src/Handler/Package.hs b/src/Handler/Package.hs index 294d48c..023739a 100644 --- a/src/Handler/Package.hs +++ b/src/Handler/Package.hs @@ -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 diff --git a/src/Handler/Package/Api.hs b/src/Handler/Package/Api.hs new file mode 100644 index 0000000..70cd7e5 --- /dev/null +++ b/src/Handler/Package/Api.hs @@ -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] diff --git a/src/Handler/Package/V0/Index.hs b/src/Handler/Package/V0/Index.hs index 5df0991..c9e49d6 100644 --- a/src/Handler/Package/V0/Index.hs +++ b/src/Handler/Package/V0/Index.hs @@ -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 \ No newline at end of file diff --git a/src/Handler/Package/V1/Index.hs b/src/Handler/Package/V1/Index.hs new file mode 100644 index 0000000..bc24a1b --- /dev/null +++ b/src/Handler/Package/V1/Index.hs @@ -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 diff --git a/src/Handler/Types/Api.hs b/src/Handler/Types/Api.hs index e04d67e..877ef9d 100644 --- a/src/Handler/Types/Api.hs +++ b/src/Handler/Types/Api.hs @@ -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