simplexmq/src/Simplex/Messaging/Version.hs

{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}

module Simplex.Messaging.Version
  ( Version,
    VersionRange (minVersion, maxVersion),
    VersionScope,
    pattern VersionRange,
    VersionI (..),
    VersionRangeI (..),
    Compatible,
    pattern Compatible,
    mkVersionRange,
    safeVersionRange,
    versionToRange,
    isCompatible,
    isCompatibleRange,
    proveCompatible,
    compatibleVersion,
    compatibleVRange,
    compatibleVRange',
  )
where

import Control.Applicative (optional)
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import Data.Aeson.Types ((.:), (.=))
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Version.Internal (Version (..))

pattern VersionRange :: Version v -> Version v -> VersionRange v
pattern VersionRange v1 v2 <- VRange v1 v2

{-# COMPLETE VersionRange #-}

data VersionRange v = VRange
  { minVersion :: Version v,
    maxVersion :: Version v
  }
  deriving (Eq, Show)

instance J.FromJSON (VersionRange v) where
  parseJSON (J.Object v) = do
    minVersion <- v .: "minVersion"
    maxVersion <- v .: "maxVersion"
    pure VRange {minVersion, maxVersion}
  parseJSON invalid =
    JT.prependFailure "bad VersionRange, " (JT.typeMismatch "Object" invalid)

instance J.ToJSON (VersionRange v) where
  toEncoding VRange {minVersion, maxVersion} = JE.pairs $ ("minVersion" .= minVersion) <> ("maxVersion" .= maxVersion)
  toJSON VRange {minVersion, maxVersion} = J.object ["minVersion" .= minVersion, "maxVersion" .= maxVersion]

class VersionScope v

-- | construct valid version range, to be used in constants
mkVersionRange :: Version v -> Version v -> VersionRange v
mkVersionRange v1 v2
  | v1 <= v2 = VRange v1 v2
  | otherwise = error "invalid version range"

safeVersionRange :: Version v -> Version v -> Maybe (VersionRange v)
safeVersionRange v1 v2
  | v1 <= v2 = Just $ VRange v1 v2
  | otherwise = Nothing

versionToRange :: Version v -> VersionRange v
versionToRange v = VRange v v

instance VersionScope v => Encoding (VersionRange v) where
  smpEncode (VRange v1 v2) = smpEncode (v1, v2)
  smpP =
    maybe (fail "invalid version range") pure
      =<< safeVersionRange <$> smpP <*> smpP

instance VersionScope v => StrEncoding (VersionRange v) where
  strEncode (VRange v1 v2)
    | v1 == v2 = strEncode v1
    | otherwise = strEncode v1 <> "-" <> strEncode v2
  strP = do
    v1 <- strP
    v2 <- maybe (pure v1) (const strP) =<< optional (A.char '-')
    maybe (fail "invalid version range") pure $ safeVersionRange v1 v2

class VersionScope v => VersionI v a | a -> v where
  type VersionRangeT v a
  version :: a -> Version v
  toVersionRangeT :: a -> VersionRange v -> VersionRangeT v a

class VersionScope v => VersionRangeI v a | a -> v where
  type VersionT v a
  versionRange :: a -> VersionRange v
  toVersionRange :: a -> VersionRange v -> a
  toVersionT :: a -> Version v -> VersionT v a

instance VersionScope v => VersionI v (Version v) where
  type VersionRangeT v (Version v) = VersionRange v
  version = id
  toVersionRangeT _ vr = vr

instance VersionScope v => VersionRangeI v (VersionRange v) where
  type VersionT v (VersionRange v) = Version v
  versionRange = id
  toVersionRange _ vr = vr
  toVersionT _ v = v

newtype Compatible a = Compatible_ a

pattern Compatible :: a -> Compatible a
pattern Compatible a <- Compatible_ a

{-# COMPLETE Compatible #-}

isCompatible :: VersionI v a => a -> VersionRange v -> Bool
isCompatible x (VRange v1 v2) = let v = version x in v1 <= v && v <= v2

isCompatibleRange :: VersionRangeI v a => a -> VersionRange v -> Bool
isCompatibleRange x (VRange min2 max2) = min1 <= max2 && min2 <= max1
  where
    VRange min1 max1 = versionRange x

proveCompatible :: VersionI v a => a -> VersionRange v -> Maybe (Compatible a)
proveCompatible x vr = x `mkCompatibleIf` (x `isCompatible` vr)

compatibleVersion :: VersionRangeI v a => a -> VersionRange v -> Maybe (Compatible (VersionT v a))
compatibleVersion x vr =
  toVersionT x (min max1 max2) `mkCompatibleIf` isCompatibleRange x vr
  where
    max1 = maxVersion $ versionRange x
    max2 = maxVersion vr

-- | intersection of version ranges
compatibleVRange :: VersionRangeI v a => a -> VersionRange v -> Maybe (Compatible a)
compatibleVRange x vr =
  compatibleVRange_ x (max min1 min2) (min max1 max2)
  where
    VRange min1 max1 = versionRange x
    VRange min2 max2 = vr

-- | version range capped by compatible version
compatibleVRange' :: VersionRangeI v a => a -> Version v -> Maybe (Compatible a)
compatibleVRange' x v
  | v <= max1 = compatibleVRange_ x min1 v
  | otherwise = Nothing
  where
    VRange min1 max1 = versionRange x

compatibleVRange_ :: VersionRangeI v a => a -> Version v -> Version v -> Maybe (Compatible a)
compatibleVRange_ x v1 v2 = Compatible_ . toVersionRange x <$> safeVersionRange v1 v2

mkCompatibleIf :: a -> Bool -> Maybe (Compatible a)
x `mkCompatibleIf` cond = if cond then Just $ Compatible_ x else Nothing