{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Version
  ( assertCompatibleWithPathPin,
    matchVersion,
  )
where

import Data.Foldable (toList)
import Data.Char (isAlpha, isDigit)
import Data.Function (on)
import qualified Data.PartialOrd as PO
import qualified Data.Text as T
import Data.Versions (SemVer (..), VUnit (..), semver)
import OurPrelude
import Utils

notElemOf :: (Eq a, Foldable t) => t a -> a -> Bool
notElemOf :: t a -> a -> Bool
notElemOf t a
o = Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> t a -> Bool) -> t a -> a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem t a
o

-- | Similar to @breakOn@, but will not keep the pattern at the beginning of the suffix.
--
-- Examples:
--
-- >>> clearBreakOn "::" "a::b::c"
-- ("a","b::c")
clearBreakOn :: Text -> Text -> (Text, Text)
clearBreakOn :: Text -> Text -> (Text, Text)
clearBreakOn Text
boundary Text
string =
  let (Text
prefix, Text
suffix) = Text -> Text -> (Text, Text)
T.breakOn Text
boundary Text
string
   in if Text -> Bool
T.null Text
suffix
        then (Text
prefix, Text
suffix)
        else (Text
prefix, Int -> Text -> Text
T.drop (Text -> Int
T.length Text
boundary) Text
suffix)

-- | Check if attribute path is not pinned to a certain version.
-- If a derivation is expected to stay at certain version branch,
-- it will usually have the branch as a part of the attribute path.
--
-- Examples:
--
-- >>> versionCompatibleWithPathPin "libgit2_0_25" "0.25.3"
-- True
--
-- >>> versionCompatibleWithPathPin "owncloud90" "9.0.3"
-- True
--
-- >>> versionCompatibleWithPathPin "owncloud-client" "2.4.1"
-- True
--
-- >>> versionCompatibleWithPathPin "owncloud90" "9.1.3"
-- False
--
-- >>> versionCompatibleWithPathPin "nodejs-slim-10_x" "11.2.0"
-- False
--
-- >>> versionCompatibleWithPathPin "nodejs-slim-10_x" "10.12.0"
-- True
versionCompatibleWithPathPin :: Text -> Version -> Bool
versionCompatibleWithPathPin :: Text -> Text -> Bool
versionCompatibleWithPathPin Text
attrPath Text
newVer
  | Text
"_x" Text -> Text -> Bool
`T.isSuffixOf` Text -> Text
T.toLower Text
attrPath =
    Text -> Text -> Bool
versionCompatibleWithPathPin (Int -> Text -> Text
T.dropEnd Int
2 Text
attrPath) Text
newVer
  | Text
"_" Text -> Text -> Bool
`T.isInfixOf` Text
attrPath =
    let attrVersionPart :: Maybe Text
attrVersionPart =
          let (Text
_, Text
version) = Text -> Text -> (Text, Text)
clearBreakOn Text
"_" Text
attrPath
           in if (Char -> Bool) -> Text -> Bool
T.any ([Char] -> Char -> Bool
forall a (t :: * -> *). (Eq a, Foldable t) => t a -> a -> Bool
notElemOf (Char
'_' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char
'0' .. Char
'9'])) Text
version
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
version
        -- Check assuming version part has underscore separators
        attrVersionPeriods :: Maybe Text
attrVersionPeriods = Text -> Text -> Text -> Text
T.replace Text
"_" Text
"." (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
attrVersionPart
     in -- If we don't find version numbers in the attr path, exit success.
        Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Text -> Text -> Bool
`T.isPrefixOf` Text
newVer) Maybe Text
attrVersionPeriods
  | Bool
otherwise =
    let attrVersionPart :: Maybe Text
attrVersionPart =
          let version :: Text
version = (Char -> Bool) -> Text -> Text
T.dropWhile ([Char] -> Char -> Bool
forall a (t :: * -> *). (Eq a, Foldable t) => t a -> a -> Bool
notElemOf [Char
'0' .. Char
'9']) Text
attrPath
           in if (Char -> Bool) -> Text -> Bool
T.any ([Char] -> Char -> Bool
forall a (t :: * -> *). (Eq a, Foldable t) => t a -> a -> Bool
notElemOf [Char
'0' .. Char
'9']) Text
version
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
version
        -- Check assuming version part is the prefix of the version with dots
        -- removed. For example, 91 => "9.1"
        noPeriodNewVersion :: Text
noPeriodNewVersion = Text -> Text -> Text -> Text
T.replace Text
"." Text
"" Text
newVer
     in -- If we don't find version numbers in the attr path, exit success.
        Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Text -> Text -> Bool
`T.isPrefixOf` Text
noPeriodNewVersion) Maybe Text
attrVersionPart

versionIncompatibleWithPathPin :: Text -> Version -> Bool
versionIncompatibleWithPathPin :: Text -> Text -> Bool
versionIncompatibleWithPathPin Text
path Text
version =
  Bool -> Bool
not (Text -> Text -> Bool
versionCompatibleWithPathPin Text
path Text
version)

assertCompatibleWithPathPin :: Monad m => UpdateEnv -> Text -> ExceptT Text m ()
assertCompatibleWithPathPin :: UpdateEnv -> Text -> ExceptT Text m ()
assertCompatibleWithPathPin UpdateEnv
ue Text
attrPath =
  Text -> Bool -> ExceptT Text m ()
forall (m :: * -> *) e. Monad m => e -> Bool -> ExceptT e m ()
tryAssert
    ( Text
"Version in attr path "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrPath
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not compatible with "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UpdateEnv -> Text
newVersion UpdateEnv
ue
    )
    ( Bool -> Bool
not
        ( Text -> Text -> Bool
versionCompatibleWithPathPin Text
attrPath (UpdateEnv -> Text
oldVersion UpdateEnv
ue)
            Bool -> Bool -> Bool
&& Text -> Text -> Bool
versionIncompatibleWithPathPin Text
attrPath (UpdateEnv -> Text
newVersion UpdateEnv
ue)
        )
    )

data VersionPart
  = PreReleasePart VersionPart
  | EmptyPart
  | IntPart Word
  | TextPart Text
  deriving (Int -> VersionPart -> [Char] -> [Char]
[VersionPart] -> [Char] -> [Char]
VersionPart -> [Char]
(Int -> VersionPart -> [Char] -> [Char])
-> (VersionPart -> [Char])
-> ([VersionPart] -> [Char] -> [Char])
-> Show VersionPart
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [VersionPart] -> [Char] -> [Char]
$cshowList :: [VersionPart] -> [Char] -> [Char]
show :: VersionPart -> [Char]
$cshow :: VersionPart -> [Char]
showsPrec :: Int -> VersionPart -> [Char] -> [Char]
$cshowsPrec :: Int -> VersionPart -> [Char] -> [Char]
Show, VersionPart -> VersionPart -> Bool
(VersionPart -> VersionPart -> Bool)
-> (VersionPart -> VersionPart -> Bool) -> Eq VersionPart
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VersionPart -> VersionPart -> Bool
$c/= :: VersionPart -> VersionPart -> Bool
== :: VersionPart -> VersionPart -> Bool
$c== :: VersionPart -> VersionPart -> Bool
Eq)

data ParsedVersion
  = SemanticVersion SemVer
  | SimpleVersion [VersionPart]
  deriving (Int -> ParsedVersion -> [Char] -> [Char]
[ParsedVersion] -> [Char] -> [Char]
ParsedVersion -> [Char]
(Int -> ParsedVersion -> [Char] -> [Char])
-> (ParsedVersion -> [Char])
-> ([ParsedVersion] -> [Char] -> [Char])
-> Show ParsedVersion
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ParsedVersion] -> [Char] -> [Char]
$cshowList :: [ParsedVersion] -> [Char] -> [Char]
show :: ParsedVersion -> [Char]
$cshow :: ParsedVersion -> [Char]
showsPrec :: Int -> ParsedVersion -> [Char] -> [Char]
$cshowsPrec :: Int -> ParsedVersion -> [Char] -> [Char]
Show, ParsedVersion -> ParsedVersion -> Bool
(ParsedVersion -> ParsedVersion -> Bool)
-> (ParsedVersion -> ParsedVersion -> Bool) -> Eq ParsedVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParsedVersion -> ParsedVersion -> Bool
$c/= :: ParsedVersion -> ParsedVersion -> Bool
== :: ParsedVersion -> ParsedVersion -> Bool
$c== :: ParsedVersion -> ParsedVersion -> Bool
Eq)

preReleaseTexts :: [Text]
preReleaseTexts :: [Text]
preReleaseTexts = [Text
"alpha", Text
"beta", Text
"pre", Text
"rc"]

textPart :: Text -> VersionPart
textPart :: Text -> VersionPart
textPart Text
t
  | Text
tLower Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
preReleaseTexts = VersionPart -> VersionPart
PreReleasePart (VersionPart -> VersionPart) -> VersionPart -> VersionPart
forall a b. (a -> b) -> a -> b
$ Text -> VersionPart
TextPart Text
tLower
  | Bool
otherwise = Text -> VersionPart
TextPart Text
tLower
  where
    tLower :: Text
tLower = Text -> Text
T.toLower Text
t

class SimpleVersion a where
  simpleVersion :: a -> [VersionPart]

instance SimpleVersion Text where
  simpleVersion :: Text -> [VersionPart]
simpleVersion Text
t
    | Text
digitHead Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"" = Word -> VersionPart
IntPart Word
number VersionPart -> [VersionPart] -> [VersionPart]
forall a. a -> [a] -> [a]
: Text -> [VersionPart]
forall a. SimpleVersion a => a -> [VersionPart]
simpleVersion Text
digitTail
    | Text
alphaHead Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"" = Text -> VersionPart
textPart Text
alphaHead VersionPart -> [VersionPart] -> [VersionPart]
forall a. a -> [a] -> [a]
: Text -> [VersionPart]
forall a. SimpleVersion a => a -> [VersionPart]
simpleVersion Text
alphaTail
    | Bool
otherwise = []
    where
      t' :: Text
t' = (Char -> Bool) -> Text -> Text
T.dropWhile (\Char
c -> Bool -> Bool
not (Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c)) Text
t
      (Text
digitHead, Text
digitTail) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isDigit Text
t'
      number :: Word
number = [Char] -> Word
forall a. Read a => [Char] -> a
read ([Char] -> Word) -> [Char] -> Word
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
digitHead
      (Text
alphaHead, Text
alphaTail) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isAlpha Text
t'

instance SimpleVersion ParsedVersion where
  simpleVersion :: ParsedVersion -> [VersionPart]
simpleVersion (SimpleVersion [VersionPart]
v) = [VersionPart]
v
  simpleVersion (SemanticVersion SemVer
v) = SemVer -> [VersionPart]
forall a. SimpleVersion a => a -> [VersionPart]
simpleVersion SemVer
v

instance SimpleVersion SemVer where
  simpleVersion :: SemVer -> [VersionPart]
simpleVersion SemVer {Word
_svMajor :: SemVer -> Word
_svMajor :: Word
_svMajor, Word
_svMinor :: SemVer -> Word
_svMinor :: Word
_svMinor, Word
_svPatch :: SemVer -> Word
_svPatch :: Word
_svPatch, [VChunk]
_svPreRel :: SemVer -> [VChunk]
_svPreRel :: [VChunk]
_svPreRel} =
    [Word -> VersionPart
IntPart Word
_svMajor, Word -> VersionPart
IntPart Word
_svMinor, Word -> VersionPart
IntPart Word
_svPatch]
      [VersionPart] -> [VersionPart] -> [VersionPart]
forall a. [a] -> [a] -> [a]
++ (VUnit -> VersionPart) -> [VUnit] -> [VersionPart]
forall a b. (a -> b) -> [a] -> [b]
map VUnit -> VersionPart
toPart ([[VUnit]] -> [VUnit]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((VChunk -> [VUnit]) -> [VChunk] -> [[VUnit]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VChunk -> [VUnit]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [VChunk]
_svPreRel))
    where
      toPart :: VUnit -> VersionPart
      toPart :: VUnit -> VersionPart
toPart (Digits Word
i) = Word -> VersionPart
IntPart Word
i
      toPart (Str Text
t) =
        case Text -> VersionPart
textPart Text
t of
          PreReleasePart VersionPart
p -> VersionPart -> VersionPart
PreReleasePart VersionPart
p
          VersionPart
p -> VersionPart -> VersionPart
PreReleasePart VersionPart
p

instance SimpleVersion [VersionPart] where
  simpleVersion :: [VersionPart] -> [VersionPart]
simpleVersion = [VersionPart] -> [VersionPart]
forall a. a -> a
id

-- | Pre-release parts come before empty parts, everything else comes after
-- them. Int and text parts compare to themselves as expected and comparison
-- between them is not defined.
instance PO.PartialOrd VersionPart where
  PreReleasePart VersionPart
a <= :: VersionPart -> VersionPart -> Bool
<= PreReleasePart VersionPart
b = VersionPart
a VersionPart -> VersionPart -> Bool
forall a. PartialOrd a => a -> a -> Bool
PO.<= VersionPart
b
  PreReleasePart VersionPart
_ <= VersionPart
_ = Bool
True
  VersionPart
_ <= PreReleasePart VersionPart
_ = Bool
False
  VersionPart
EmptyPart <= VersionPart
_ = Bool
True
  VersionPart
_ <= VersionPart
EmptyPart = Bool
False
  IntPart Word
a <= IntPart Word
b = Word
a Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
b
  TextPart Text
a <= TextPart Text
b = Text
a Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
<= Text
b
  VersionPart
_ <= VersionPart
_ = Bool
False

-- | If either version contains no comparable parts, the versions are not
-- comparable. If both contain at least some parts, compare parts in order. When
-- a version runs out of parts, its remaining parts are considered empty parts,
-- which come after pre-release parts, but before other parts.
--
-- Examples:
--
-- >>> on PO.compare parseVersion "1.2.3" "1.2.4"
-- Just LT
--
-- >>> on PO.compare parseVersion "1.0" "-"
-- Nothing
--
-- >>> on PO.compare parseVersion "-" "-"
-- Nothing
--
-- >>> on PO.compare parseVersion "1.0" "1_0_0"
-- Just LT
--
-- >>> on PO.compare parseVersion "1.0-pre3" "1.0"
-- Just LT
--
-- >>> on PO.compare parseVersion "1.1" "1.a"
-- Nothing
instance PO.PartialOrd ParsedVersion where
  SemanticVersion SemVer
a <= :: ParsedVersion -> ParsedVersion -> Bool
<= SemanticVersion SemVer
b = SemVer
a SemVer -> SemVer -> Bool
forall a. Ord a => a -> a -> Bool
<= SemVer
b
  SimpleVersion [] <= ParsedVersion
_ = Bool
False
  ParsedVersion
_ <= SimpleVersion [] = Bool
False
  ParsedVersion
a <= ParsedVersion
b = ([VersionPart] -> [VersionPart] -> Bool)
-> (ParsedVersion -> [VersionPart])
-> ParsedVersion
-> ParsedVersion
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on [VersionPart] -> [VersionPart] -> Bool
lessOrEq ParsedVersion -> [VersionPart]
forall a. SimpleVersion a => a -> [VersionPart]
simpleVersion ParsedVersion
a ParsedVersion
b
    where
      lessOrEq :: [VersionPart] -> [VersionPart] -> Bool
lessOrEq [] [] = Bool
True
      lessOrEq [] [VersionPart]
ys = [VersionPart] -> [VersionPart] -> Bool
lessOrEq [VersionPart
EmptyPart] [VersionPart]
ys
      lessOrEq [VersionPart]
xs [] = [VersionPart] -> [VersionPart] -> Bool
lessOrEq [VersionPart]
xs [VersionPart
EmptyPart]
      lessOrEq (VersionPart
x : [VersionPart]
xs) (VersionPart
y : [VersionPart]
ys) =
        case VersionPart -> VersionPart -> Maybe Ordering
forall a. PartialOrd a => a -> a -> Maybe Ordering
PO.compare VersionPart
x VersionPart
y of
          Just Ordering
LT -> Bool
True
          Just Ordering
EQ -> [VersionPart] -> [VersionPart] -> Bool
lessOrEq [VersionPart]
xs [VersionPart]
ys
          Just Ordering
GT -> Bool
False
          Maybe Ordering
Nothing -> Bool
False

parseVersion :: Version -> ParsedVersion
parseVersion :: Text -> ParsedVersion
parseVersion Text
v =
  case Text -> Either ParsingError SemVer
semver Text
v of
    Left ParsingError
_ -> [VersionPart] -> ParsedVersion
SimpleVersion ([VersionPart] -> ParsedVersion) -> [VersionPart] -> ParsedVersion
forall a b. (a -> b) -> a -> b
$ Text -> [VersionPart]
forall a. SimpleVersion a => a -> [VersionPart]
simpleVersion Text
v
    Right SemVer
v' -> SemVer -> ParsedVersion
SemanticVersion SemVer
v'

matchUpperBound :: Boundary Version -> Version -> Bool
matchUpperBound :: Boundary Text -> Text -> Bool
matchUpperBound Boundary Text
Unbounded Text
_ = Bool
True
matchUpperBound (Including Text
b) Text
v = Text -> ParsedVersion
parseVersion Text
v ParsedVersion -> ParsedVersion -> Bool
forall a. PartialOrd a => a -> a -> Bool
PO.<= Text -> ParsedVersion
parseVersion Text
b
matchUpperBound (Excluding Text
b) Text
v = Text -> ParsedVersion
parseVersion Text
v ParsedVersion -> ParsedVersion -> Bool
forall a. PartialOrd a => a -> a -> Bool
PO.< Text -> ParsedVersion
parseVersion Text
b

matchLowerBound :: Boundary Version -> Version -> Bool
matchLowerBound :: Boundary Text -> Text -> Bool
matchLowerBound Boundary Text
Unbounded Text
_ = Bool
True
matchLowerBound (Including Text
b) Text
v = Text -> ParsedVersion
parseVersion Text
b ParsedVersion -> ParsedVersion -> Bool
forall a. PartialOrd a => a -> a -> Bool
PO.<= Text -> ParsedVersion
parseVersion Text
v
matchLowerBound (Excluding Text
b) Text
v = Text -> ParsedVersion
parseVersion Text
b ParsedVersion -> ParsedVersion -> Bool
forall a. PartialOrd a => a -> a -> Bool
PO.< Text -> ParsedVersion
parseVersion Text
v

-- | Reports True only if matcher certainly matches. When the order or equality
-- of versions is ambiguous, return False.
--
-- Examples:
--
-- >>> matchVersion (SingleMatcher "1.2.3") "1_2-3"
-- True
--
-- >>> matchVersion (RangeMatcher Unbounded (Including "1.0-pre3")) "1.0"
-- False
--
-- >>> matchVersion (RangeMatcher Unbounded (Excluding "1.0-rev3")) "1.0"
-- True
matchVersion :: VersionMatcher -> Version -> Bool
matchVersion :: VersionMatcher -> Text -> Bool
matchVersion (SingleMatcher Text
v) Text
v' = Text -> ParsedVersion
parseVersion Text
v ParsedVersion -> ParsedVersion -> Bool
forall a. PartialOrd a => a -> a -> Bool
PO.== Text -> ParsedVersion
parseVersion Text
v'
matchVersion (RangeMatcher Boundary Text
lowerBound Boundary Text
upperBound) Text
v =
  Boundary Text -> Text -> Bool
matchLowerBound Boundary Text
lowerBound Text
v Bool -> Bool -> Bool
&& Boundary Text -> Text -> Bool
matchUpperBound Boundary Text
upperBound Text
v