diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 7c9bbe7..2028110 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -50,6 +50,7 @@ import Lib.Types.Emver ( Version ) import Util.Shared ( addPackageHeader , getVersionSpecFromQuery , orThrow + , versionPriorityFromQueryIsMin ) data FileExtension = FileExtension FilePath (Maybe String) @@ -60,7 +61,8 @@ instance Show FileExtension where getAppManifestR :: PkgId -> Handler TypedContent getAppManifestR pkg = do versionSpec <- getVersionSpecFromQuery - version <- getBestVersion pkg versionSpec + preferMin <- versionPriorityFromQueryIsMin + version <- getBestVersion pkg versionSpec preferMin `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) addPackageHeader pkg version (len, src) <- getManifest pkg version @@ -71,7 +73,8 @@ getAppR :: S9PK -> Handler TypedContent getAppR file = do let pkg = PkgId . T.pack $ takeBaseName (show file) versionSpec <- getVersionSpecFromQuery - version <- getBestVersion pkg versionSpec + preferMin <- versionPriorityFromQueryIsMin + version <- getBestVersion pkg versionSpec preferMin `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) addPackageHeader pkg version void $ recordMetrics pkg version diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 25cee0d..b951aec 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -34,8 +34,9 @@ instance FromJSON IconType getIconsR :: PkgId -> Handler TypedContent getIconsR pkg = do - spec <- getVersionSpecFromQuery - version <- getBestVersion pkg spec + spec <- getVersionSpecFromQuery + preferMin <- versionPriorityFromQueryIsMin + version <- getBestVersion pkg spec preferMin `orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|]) (ct, len, src) <- getIcon pkg version addHeader "Content-Length" (show len) @@ -43,8 +44,9 @@ getIconsR pkg = do getLicenseR :: PkgId -> Handler TypedContent getLicenseR pkg = do - spec <- getVersionSpecFromQuery - version <- getBestVersion pkg spec + spec <- getVersionSpecFromQuery + preferMin <- versionPriorityFromQueryIsMin + version <- getBestVersion pkg spec preferMin `orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|]) (len, src) <- getLicense pkg version addHeader "Content-Length" (show len) @@ -52,8 +54,9 @@ getLicenseR pkg = do getInstructionsR :: PkgId -> Handler TypedContent getInstructionsR pkg = do - spec <- getVersionSpecFromQuery - version <- getBestVersion pkg spec + spec <- getVersionSpecFromQuery + preferMin <- versionPriorityFromQueryIsMin + version <- getBestVersion pkg spec preferMin `orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|]) (len, src) <- getInstructions pkg version addHeader "Content-Length" (show len) diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index b383ef3..ecccf3b 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -21,11 +21,13 @@ import Lib.Types.AppIndex ( PkgId ) import Network.HTTP.Types.Status ( status404 ) import Util.Shared ( getVersionSpecFromQuery , orThrow + , versionPriorityFromQueryIsMin ) getPkgVersionR :: PkgId -> Handler AppVersionRes getPkgVersionR pkg = do - spec <- getVersionSpecFromQuery - AppVersionRes <$> getBestVersion pkg spec `orThrow` sendResponseStatus + spec <- getVersionSpecFromQuery + preferMin <- versionPriorityFromQueryIsMin + AppVersionRes <$> getBestVersion pkg spec preferMin `orThrow` sendResponseStatus status404 (NotFoundE [i|Version for #{pkg} satisfying #{spec}|]) diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 0463542..4897703 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -1,11 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} + module Lib.PkgRepository where import Conduit ( (.|) @@ -70,6 +71,7 @@ import Startlude ( ($) , Maybe(..) , MonadIO(liftIO) , MonadReader + , Ord(compare) , Show , SomeException(..) , filter @@ -79,11 +81,12 @@ import Startlude ( ($) , fst , headMay , not + , on , partitionEithers , pure , show , snd - , sortOn + , sortBy , throwIO , void ) @@ -105,9 +108,9 @@ import UnliftIO ( MonadUnliftIO , mapConcurrently_ , newEmptyMVar , takeMVar + , tryPutMVar , wait ) -import UnliftIO ( tryPutMVar ) import UnliftIO.Concurrent ( forkIO ) import UnliftIO.Directory ( doesDirectoryExist , doesPathExist @@ -124,6 +127,7 @@ import Yesod.Core.Content ( typeGif , typeSvg ) import Yesod.Core.Types ( ContentType ) + data ManifestParseException = ManifestParseException FilePath deriving Show instance Exception ManifestParseException @@ -152,8 +156,10 @@ getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange + -> Bool -> m (Maybe Version) -getBestVersion pkg spec = headMay . sortOn Down <$> getViableVersions pkg spec +getBestVersion pkg spec preferMin = headMay . sortBy comparator <$> getViableVersions pkg spec + where comparator = if preferMin then compare else compare `on` Down loadPkgDependencies :: MonadUnliftIO m => ConnectionPool -> PackageManifest -> m () loadPkgDependencies appConnPool manifest = do @@ -234,7 +240,6 @@ watchPkgRepoRoot pool = do onlyAdded (Added path _ isDir) = not isDir && takeExtension path == ".s9pk" onlyAdded (Modified path _ isDir) = not isDir && takeExtension path == ".s9pk" onlyAdded _ = False - -- Added path _ isDir -> not isDir && takeExtension path == ".s9pk" getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 88f30d9..be3b586 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Util.Shared where @@ -54,6 +54,15 @@ getVersionSpecFromQuery = do Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) Just t -> pure t +versionPriorityFromQueryIsMin :: Handler Bool +versionPriorityFromQueryIsMin = do + priorityString <- lookupGetParam "version-priority" + case priorityString of + Nothing -> pure False + (Just "max") -> pure False + (Just "min") -> pure True + (Just t ) -> sendResponseStatus status400 ("Invalid Version Priority Specification: " <> t) + addPackageHeader :: (MonadUnliftIO m, MonadHandler m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m () addPackageHeader pkg version = do packageHash <- getHash pkg version @@ -64,7 +73,6 @@ orThrow action other = action >>= \case Nothing -> other Just x -> pure x - filterPkgOsCompatible :: Monad m => (Version -> Bool) -> ConduitT PackageMetadata PackageMetadata m () filterPkgOsCompatible p = awaitForever @@ -109,7 +117,7 @@ filterLatestVersionFromSpec versionMap = awaitForever $ \(a, vs, cats) -> do filterDependencyBestVersion :: MonadLogger m => PackageDependencyMetadata -> m (Maybe (Key PkgRecord, Text, Version)) filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord, packageDependencyMetadataDepPkgRecord = depRecord, packageDependencyMetadataDepVersions = depVersions } = do - -- get best version from VersionRange of dependency + -- get best version from VersionRange of dependency let pkgId = pkgDependencyPkgId $ entityVal pkgDepRecord let depId = pkgDependencyDepId $ entityVal pkgDepRecord let depTitle = pkgRecordTitle $ entityVal depRecord @@ -119,6 +127,6 @@ filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadat -- QUESTION is this an acceptable transformation here? These are the only values that we care about after this filter. Just bestVersion -> pure $ Just (depId, depTitle, bestVersion) Nothing -> do - $logInfo [i|No satisfactory version of #{depId} for dependent package #{pkgId}|] -- TODO it would be better if we could return the requirements for display + $logInfo [i|No satisfactory version of #{depId} for dependent package #{pkgId}|] pure Nothing