mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 12:18:29 +01:00
118 lines
4.3 KiB
Haskell
118 lines
4.3 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
|
|
module Data.Hackage.Views where
|
|
|
|
import ClassyPrelude.Yesod
|
|
import Distribution.Package
|
|
import Distribution.PackageDescription
|
|
import Distribution.Version (anyVersion, intersectVersionRanges, earlierVersion, Version (..), simplifyVersionRange, VersionRange (..))
|
|
import Distribution.Text (simpleParse)
|
|
import Data.NonNull (fromNullable) -- FIXME expose from ClassyPrelude
|
|
import Data.Hackage (UploadHistory)
|
|
import Data.Time (addUTCTime)
|
|
import qualified Types
|
|
|
|
viewUnchanged :: Monad m
|
|
=> packageName -> version -> time
|
|
-> GenericPackageDescription
|
|
-> m GenericPackageDescription
|
|
viewUnchanged _ _ _ = return
|
|
|
|
helper :: Monad m
|
|
=> (Dependency -> m Dependency)
|
|
-> GenericPackageDescription
|
|
-> m GenericPackageDescription
|
|
helper f0 gpd = do
|
|
a <- mapM (go f0) $ condLibrary gpd
|
|
b <- mapM (go2 f0) $ condExecutables gpd
|
|
c <- mapM (go2 f0) $ condTestSuites gpd
|
|
d <- mapM (go2 f0) $ condBenchmarks gpd
|
|
return gpd
|
|
{ condLibrary = a
|
|
, condExecutables = b
|
|
, condTestSuites = c
|
|
, condBenchmarks = d
|
|
}
|
|
where
|
|
go2 f (x, y) = do
|
|
y' <- go f y
|
|
return (x, y')
|
|
|
|
go :: Monad m
|
|
=> (Dependency -> m Dependency)
|
|
-> CondTree ConfVar [Dependency] a
|
|
-> m (CondTree ConfVar [Dependency] a)
|
|
go f (CondNode a constraints comps) = do
|
|
constraints' <- mapM f constraints
|
|
comps' <- mapM (goComp f) comps
|
|
return $ CondNode a constraints' comps'
|
|
|
|
goComp :: Monad m
|
|
=> (Dependency -> m Dependency)
|
|
-> (condition, CondTree ConfVar [Dependency] a, Maybe (CondTree ConfVar [Dependency] a))
|
|
-> m (condition, CondTree ConfVar [Dependency] a, Maybe (CondTree ConfVar [Dependency] a))
|
|
goComp f (condition, tree, mtree) = do
|
|
tree' <- go f tree
|
|
mtree' <- mapM (go f) mtree
|
|
return (condition, tree', mtree')
|
|
|
|
viewNoBounds :: Monad m
|
|
=> packageName -> version -> time
|
|
-> GenericPackageDescription
|
|
-> m GenericPackageDescription
|
|
viewNoBounds _ _ _ =
|
|
helper go
|
|
where
|
|
go (Dependency name _range) = return $ Dependency name anyVersion
|
|
|
|
getAvailable :: Types.PackageName
|
|
-> UTCTime
|
|
-> HashMap Types.PackageName (HashMap Types.Version UTCTime)
|
|
-> [Types.Version]
|
|
getAvailable name maxUploaded =
|
|
map fst . filter ((<= maxUploaded) . snd) . mapToList . fromMaybe mempty . lookup name
|
|
|
|
-- | We want to allow a certain "fuzz factor" between upload dates, so that if,
|
|
-- for example, foo and bar are released within a few seconds of each other,
|
|
-- and bar depends on foo, bar can use that new version of foo, even though
|
|
-- technically it "wasn't available" yet.
|
|
--
|
|
-- The actual value we should use is up for debate. I'm starting with 24 hours.
|
|
addFuzz :: UTCTime -> UTCTime
|
|
addFuzz = addUTCTime (60 * 60 * 24)
|
|
|
|
viewPVP :: Monad m
|
|
=> UploadHistory
|
|
-> packageName -> version -> UTCTime
|
|
-> GenericPackageDescription
|
|
-> m GenericPackageDescription
|
|
viewPVP uploadHistory _ _ uploaded =
|
|
helper go
|
|
where
|
|
toStr (Distribution.Package.PackageName name) = name
|
|
|
|
go orig@(Dependency _ range) | hasUpperBound range = return orig
|
|
go orig@(Dependency nameO@(toStr -> name) range) = do
|
|
let available = getAvailable (fromString name) (addFuzz uploaded) uploadHistory
|
|
case fromNullable $ mapMaybe (simpleParse . unpack . toPathPiece) available of
|
|
Nothing -> return orig
|
|
Just vs ->
|
|
case pvpBump $ maximum vs of
|
|
Nothing -> return orig
|
|
Just v -> return
|
|
$ Dependency nameO
|
|
$ simplifyVersionRange
|
|
$ intersectVersionRanges range
|
|
$ earlierVersion v
|
|
|
|
pvpBump (Version (x:y:_) _) = Just $ Version [x, y + 1] []
|
|
pvpBump _ = Nothing
|
|
|
|
hasUpperBound AnyVersion = False
|
|
hasUpperBound ThisVersion{} = True
|
|
hasUpperBound LaterVersion{} = False
|
|
hasUpperBound EarlierVersion{} = True
|
|
hasUpperBound WildcardVersion{} = True
|
|
hasUpperBound (UnionVersionRanges x y) = hasUpperBound x && hasUpperBound y
|
|
hasUpperBound (IntersectVersionRanges x y) = hasUpperBound x || hasUpperBound y
|
|
hasUpperBound (VersionRangeParens x) = hasUpperBound x
|