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