From 8929cdb7911aed2f969d5812e9af603de26d2857 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 23 May 2022 16:16:14 -0600 Subject: [PATCH] add index and deindex endpoints --- src/Application.hs | 6 ++-- src/Database/Marketplace.hs | 36 ++++++++++----------- src/Database/Queries.hs | 52 ++++++++++++++++++++++++++++--- src/Handler/Admin.hs | 52 +++++++++++++++++++++++++++---- src/Lib/PkgRepository.hs | 10 ++++-- src/Lib/Types/AppIndex.hs | 2 ++ src/Model.hs | 12 ++++--- src/Util/Shared.hs | 62 +++++++++++++++++++++++++++---------- 8 files changed, 176 insertions(+), 56 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index d7c570e..b2130bd 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -303,7 +303,7 @@ startApp foundation = do -- certbot renew loop void . forkIO $ forever $ flip runReaderT foundation $ do shouldRenew <- doesSslNeedRenew - runLog $ $logInfo $ [i|Checking if SSL Certs should be renewed: #{shouldRenew}|] + runLog $ $logInfo [i|Checking if SSL Certs should be renewed: #{shouldRenew}|] when shouldRenew $ do runLog $ $logInfo "Renewing SSL Certs." renewSslCerts @@ -322,9 +322,9 @@ startWeb foundation = do where startWeb' app = (`onException` (appStopFsNotifyPkg foundation *> appStopFsNotifyEos foundation)) $ do let AppSettings {..} = appSettings foundation - runLog $ $logInfo $ [i|Launching Tor Web Server on port #{torPort}|] + runLog $ $logInfo [i|Launching Tor Web Server on port #{torPort}|] torAction <- async $ runSettings (warpSettings torPort foundation) app - runLog $ $logInfo $ [i|Launching Web Server on port #{appPort}|] + runLog $ $logInfo [i|Launching Web Server on port #{appPort}|] action <- async $ if sslAuto then runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app else runSettings (warpSettings appPort foundation) app diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index f28b076..f8872d1 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Fuse on/on" #-} module Database.Marketplace where @@ -54,24 +55,24 @@ type CategoryTitle = Text searchServices :: (MonadResource m, MonadIO m) => Maybe CategoryTitle -> Text - -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) () + -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () searchServices Nothing query = selectSource $ do - service <- from $ table @PkgRecord + service <- from $ table @VersionRecord where_ - ( (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%)) - ||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%)) - ||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%)) + ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) ) - orderBy [desc (service ^. PkgRecordUpdatedAt)] + orderBy [desc (service ^. VersionRecordUpdatedAt)] pure service searchServices (Just category) query = selectSource $ do services <- from (do (service :& _ :& cat) <- from - $ table @PkgRecord + $ table @VersionRecord `innerJoin` table @PkgCategory - `on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. PkgRecordId) + `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 @@ -80,13 +81,13 @@ searchServices (Just category) query = selectSource $ do $ cat ^. CategoryName ==. val category - &&. ( (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%)) - ||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%)) - ||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%)) + &&. ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) ) pure service ) - orderBy [desc (services ^. PkgRecordUpdatedAt)] + orderBy [desc (services ^. VersionRecordUpdatedAt)] pure services getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) () @@ -98,20 +99,19 @@ getPkgData pkgs = selectSource $ do getPkgDependencyData :: MonadIO m => Key PkgRecord -> Version - -> ReaderT SqlBackend m ([(Entity PkgDependency, Entity PkgRecord)]) + -> ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)] getPkgDependencyData pkgId pkgVersion = select $ do - pd <- from + from (do (pkgDepRecord :& depPkgRecord) <- from $ table @PkgDependency `innerJoin` table @PkgRecord `on` (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId) - where_ (pkgDepRecord ^. PkgDependencyPkgId ==. (val pkgId)) + where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val pkgId) where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion) pure (pkgDepRecord, depPkgRecord) ) - pure pd zipCategories :: MonadUnliftIO m => ConduitT @@ -147,7 +147,7 @@ zipDependencyVersions :: (Monad m, MonadIO m) => (Entity PkgDependency, Entity PkgRecord) -> ReaderT SqlBackend m PackageDependencyMetadata zipDependencyVersions (pkgDepRecord, depRecord) = do - let pkgDbId = entityKey $ depRecord + let pkgDbId = entityKey depRecord depVers <- select $ do v <- from $ table @VersionRecord where_ $ v ^. VersionRecordPkgId ==. val pkgDbId diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index 4c674e5..0777ee4 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -1,15 +1,38 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Database.Queries where -import Database.Persist.Sql -import Lib.Types.AppIndex -import Lib.Types.Emver -import Model +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 hiding ( get ) +import Startlude ( ($) + , (.) + , ConvertText(toS) + , Maybe(..) + , MonadIO(..) + , ReaderT + , SomeException + , getCurrentTime + , maybe + ) +import System.FilePath ( takeExtension ) +import UnliftIO ( MonadUnliftIO + , try + ) fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe PkgRecord) fetchApp = get . PkgRecordKey @@ -21,3 +44,22 @@ 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 + 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 + _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 d135764..e24cf79 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -9,16 +9,33 @@ import Conduit ( (.|) ) import Control.Monad.Reader.Has ( ask ) import Control.Monad.Trans.Maybe ( MaybeT(..) ) -import Data.Aeson ( decodeFileStrict ) +import Data.Aeson ( (.:) + , FromJSON(parseJSON) + , decodeFileStrict + , withObject + ) +import Data.String.Interpolate.IsString + ( i ) +import Database.Queries ( upsertPackageVersion ) import Foundation import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot) , extractPkg + , getManifestLocation + ) +import Lib.Types.AppIndex ( PackageManifest(..) + , PkgId + ) +import Lib.Types.Emver ( Version(..) ) +import Model ( Key(PkgRecordKey, VersionRecordKey) ) +import Network.HTTP.Types ( status404 + , status500 ) -import Lib.Types.AppIndex ( PackageManifest(..) ) -import Network.HTTP.Types ( status500 ) import Startlude ( ($) , (.) , (<$>) + , Applicative(pure) + , Eq + , Show , SomeException(..) , asum , hush @@ -38,9 +55,12 @@ import UnliftIO.Directory ( renameDirectory ) import Util.Shared ( orThrow , sendResponseText ) -import Yesod ( getsYesod +import Yesod ( delete + , getsYesod , logError , rawRequestBody + , requireCheckJsonBody + , runDB ) postPkgUploadR :: Handler () @@ -58,8 +78,28 @@ postPkgUploadR = do renameDirectory path (pkgRepoFileRoot show packageManifestId show packageManifestVersion) where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m) + +data IndexPkgReq = IndexPkgReq + { indexPkgReqId :: !PkgId + , indexPkgReqVersion :: !Version + } + deriving (Eq, Show) +instance FromJSON IndexPkgReq where + parseJSON = withObject "Index Package Request" $ \o -> do + indexPkgReqId <- o .: "id" + indexPkgReqVersion <- o .: "version" + pure IndexPkgReq { .. } + postPkgIndexR :: Handler () -postPkgIndexR = _ +postPkgIndexR = do + IndexPkgReq {..} <- requireCheckJsonBody + manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion + man <- liftIO (decodeFileStrict manifest) `orThrow` sendResponseText + status404 + [i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|] + runDB $ upsertPackageVersion man postPkgDeindexR :: Handler () -postPkgDeindexR = _ +postPkgDeindexR = do + IndexPkgReq {..} <- requireCheckJsonBody + runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion) diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index e60f32c..d913cf7 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -286,14 +286,18 @@ watchEosRepoRoot pool = do Right version -> void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText] +getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath +getManifestLocation pkg version = do + root <- asks pkgRepoFileRoot + pure $ root show pkg show version "manifest.json" + getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m (Integer, ConduitT () ByteString m ()) getManifest pkg version = do - root <- asks pkgRepoFileRoot - let manifestPath = root show pkg show version "manifest.json" - n <- getFileSize manifestPath + manifestPath <- getManifestLocation pkg version + n <- getFileSize manifestPath pure (n, sourceFile manifestPath) getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r) diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index 9e575e8..26c5431 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -100,6 +100,7 @@ data PackageManifest = PackageManifest , packageManifestIcon :: !(Maybe Text) , packageManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text)) , packageManifestDependencies :: !(HM.HashMap PkgId PackageDependency) + , packageManifestEosVersion :: !Version } deriving Show instance FromJSON PackageManifest where @@ -120,6 +121,7 @@ instance FromJSON PackageManifest where pure (alertType, alertDesc) let packageManifestAlerts = HM.fromList a packageManifestDependencies <- o .: "dependencies" + packageManifestEosVersion <- o .: "eos-version" pure PackageManifest { .. } -- >>> eitherDecode testManifest :: Either String PackageManifest diff --git a/src/Model.hs b/src/Model.hs index fa1bcc2..291d1bb 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -24,10 +24,10 @@ PkgRecord Id PkgId sql=pkg_id createdAt UTCTime updatedAt UTCTime Maybe - title Text - descShort Text - descLong Text - iconType Text + -- title Text + -- descShort Text + -- descLong Text + -- iconType Text deriving Eq deriving Show @@ -36,6 +36,10 @@ VersionRecord sql=version updatedAt UTCTime Maybe pkgId PkgRecordId number Version + title Text + descShort Text + descLong Text + iconType Text releaseNotes Text osVersion Version arch Text Maybe diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 52e1f3b..c6b924d 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -1,14 +1,13 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} module Util.Shared where -import Startlude hiding ( Any - , Handler - , yield - ) import qualified Data.Text as T import Network.HTTP.Types @@ -18,10 +17,10 @@ import Conduit ( ConduitT , awaitForever , yield ) -import Control.Monad.Reader.Has ( Has ) -import Data.Semigroup ( Max(Max) - , getMax +import Control.Monad.Reader.Has ( Has + , MonadReader ) +import Data.Semigroup ( (<>) ) import Data.String.Interpolate.IsString ( i ) import Database.Esqueleto.Experimental @@ -43,10 +42,33 @@ import Lib.Types.Emver import Model ( Category , Key(unPkgRecordKey) , PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange) - , PkgRecord(pkgRecordTitle) - , VersionRecord(versionRecordNumber, versionRecordOsVersion) + , PkgRecord + , VersionRecord(..) , pkgDependencyPkgId ) +import Startlude ( ($) + , (.) + , (<$>) + , Alternative((<|>)) + , Applicative(pure) + , Bool(..) + , Down(Down) + , Foldable(foldr, null) + , Functor(fmap) + , Maybe(..) + , Monad((>>=)) + , Ord((>)) + , Text + , decodeUtf8 + , filter + , fromMaybe + , headMay + , isSpace + , not + , readMaybe + , sortOn + , unless + ) getVersionSpecFromQuery :: Handler VersionRange getVersionSpecFromQuery = do @@ -116,17 +138,17 @@ filterLatestVersionFromSpec versionMap = awaitForever $ \(a, vs, cats) -> do -- 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, packageDependencyMetadataDepPkgRecord = depRecord, packageDependencyMetadataDepVersions = depVersions } +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 depTitle = pkgRecordTitle $ entityVal depRecord - let satisfactory = filter (<|| (pkgDependencyDepVersionRange $ entityVal pkgDepRecord)) - (versionRecordNumber . entityVal <$> depVersions) - case getMax <$> foldMap (Just . Max) satisfactory of + let pkgId = pkgDependencyPkgId $ entityVal pkgDepRecord + let depId = pkgDependencyDepId $ entityVal pkgDepRecord + let satisfactory = filter + ((<|| (pkgDependencyDepVersionRange $ entityVal pkgDepRecord)) . versionRecordNumber) + (entityVal <$> depVersions) + case maximumOn versionRecordNumber satisfactory of -- QUESTION is this an acceptable transformation here? These are the only values that we care about after this filter. - Just bestVersion -> pure $ Just (depId, depTitle, bestVersion) + Just bestVersion -> pure $ Just (depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion) Nothing -> do -- TODO it would be better if we could return the requirements for display $logInfo [i|No satisfactory version of #{depId} for dependent package #{pkgId}|] @@ -134,3 +156,9 @@ filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadat sendResponseText :: MonadHandler m => Status -> Text -> m a sendResponseText = sendResponseStatus @_ @Text + +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