implements query parameter for prioritizing lower versions

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

src/Handler/Icons.hs

@@ -34,8 +34,9 @@ instance FromJSON IconType
 
 getIconsR :: PkgId -> Handler TypedContent
 getIconsR pkg = do
-    spec    <- getVersionSpecFromQuery
+    spec      <- getVersionSpecFromQuery
-    version <- getBestVersion pkg spec
+    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
+    spec      <- getVersionSpecFromQuery
-    version <- getBestVersion pkg spec
+    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
+    spec      <- getVersionSpecFromQuery
-    version <- getBestVersion pkg spec
+    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)

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
+    spec      <- getVersionSpecFromQuery
-    AppVersionRes <$> getBestVersion pkg spec `orThrow` sendResponseStatus
+    preferMin <- versionPriorityFromQueryIsMin
+    AppVersionRes <$> getBestVersion pkg spec preferMin `orThrow` sendResponseStatus
         status404
         (NotFoundE [i|Version for #{pkg} satisfying #{spec}|])

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

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