{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeOperators              #-}

module Ouroboros.Network.Protocol.Handshake.Version
  ( Versions (..)
  , Version (..)
  , Accept (..)
  , Acceptable (..)
  , VersionMismatch (..)
    -- * Simple or no versioning
  , simpleSingletonVersions
  , foldMapVersions
  , combineVersions
  ) where

import           Data.Foldable (toList)
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Text (Text)
import           GHC.Stack (HasCallStack)


-- | The version map supported by the local agent keyed on the version
-- identifier.
--
-- Each 'Version' contains a function which takes negotiated version data and
-- returns negotiated application (the 'r' type variable).
--
-- If one needs to combine multiple versions the simplest way is to use one of
-- the combinators: 'foldMapVersions', 'combineVersions' or the 'Semigroup'
-- instance directly:
--
-- >
-- > fold $ (simpleSingletonVersions ...)
-- >       :| [ (simpleSingletonVersions ...)
-- >          , (simpleSingletonVersions ...)
-- >          , ...
-- >          ]
-- >
--
newtype Versions vNum vData r = Versions
  { Versions vNum vData r -> Map vNum (Version vData r)
getVersions :: Map vNum (Version vData r)
  }
  deriving b -> Versions vNum vData r -> Versions vNum vData r
NonEmpty (Versions vNum vData r) -> Versions vNum vData r
Versions vNum vData r
-> Versions vNum vData r -> Versions vNum vData r
(Versions vNum vData r
 -> Versions vNum vData r -> Versions vNum vData r)
-> (NonEmpty (Versions vNum vData r) -> Versions vNum vData r)
-> (forall b.
    Integral b =>
    b -> Versions vNum vData r -> Versions vNum vData r)
-> Semigroup (Versions vNum vData r)
forall b.
Integral b =>
b -> Versions vNum vData r -> Versions vNum vData r
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall vNum vData r.
Ord vNum =>
NonEmpty (Versions vNum vData r) -> Versions vNum vData r
forall vNum vData r.
Ord vNum =>
Versions vNum vData r
-> Versions vNum vData r -> Versions vNum vData r
forall vNum vData r b.
(Ord vNum, Integral b) =>
b -> Versions vNum vData r -> Versions vNum vData r
stimes :: b -> Versions vNum vData r -> Versions vNum vData r
$cstimes :: forall vNum vData r b.
(Ord vNum, Integral b) =>
b -> Versions vNum vData r -> Versions vNum vData r
sconcat :: NonEmpty (Versions vNum vData r) -> Versions vNum vData r
$csconcat :: forall vNum vData r.
Ord vNum =>
NonEmpty (Versions vNum vData r) -> Versions vNum vData r
<> :: Versions vNum vData r
-> Versions vNum vData r -> Versions vNum vData r
$c<> :: forall vNum vData r.
Ord vNum =>
Versions vNum vData r
-> Versions vNum vData r -> Versions vNum vData r
Semigroup

instance Functor (Versions vNum extra) where
    fmap :: (a -> b) -> Versions vNum extra a -> Versions vNum extra b
fmap a -> b
f (Versions Map vNum (Version extra a)
vs) = Map vNum (Version extra b) -> Versions vNum extra b
forall vNum vData r.
Map vNum (Version vData r) -> Versions vNum vData r
Versions (Map vNum (Version extra b) -> Versions vNum extra b)
-> Map vNum (Version extra b) -> Versions vNum extra b
forall a b. (a -> b) -> a -> b
$ (Version extra a -> Version extra b)
-> Map vNum (Version extra a) -> Map vNum (Version extra b)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((a -> b) -> Version extra a -> Version extra b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)  Map vNum (Version extra a)
vs


-- | Useful for folding multiple 'Versions'.
--
-- A 'foldMap' restricted to the 'Versions' 'Semigroup'.
--
-- PRECONDITION: @f x@ is non-empty.
--
foldMapVersions :: (Ord vNum, Foldable f, HasCallStack)
                => (x -> Versions vNum extra r)
                -> f x
                -> Versions vNum extra r
foldMapVersions :: (x -> Versions vNum extra r) -> f x -> Versions vNum extra r
foldMapVersions x -> Versions vNum extra r
f f x
fx = case f x -> [x]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f x
fx of
    [] -> [Char] -> Versions vNum extra r
forall a. HasCallStack => [Char] -> a
error [Char]
"foldMapVersions: precondition violated"
    [x]
xs -> (Versions vNum extra r
 -> Versions vNum extra r -> Versions vNum extra r)
-> [Versions vNum extra r] -> Versions vNum extra r
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Versions vNum extra r
-> Versions vNum extra r -> Versions vNum extra r
forall a. Semigroup a => a -> a -> a
(<>) ((x -> Versions vNum extra r) -> [x] -> [Versions vNum extra r]
forall a b. (a -> b) -> [a] -> [b]
map x -> Versions vNum extra r
f [x]
xs)

combineVersions :: (Ord vNum, Foldable f, HasCallStack)
                => f (Versions vNum extra r)
                -> Versions vNum extra r
combineVersions :: f (Versions vNum extra r) -> Versions vNum extra r
combineVersions = (Versions vNum extra r -> Versions vNum extra r)
-> f (Versions vNum extra r) -> Versions vNum extra r
forall vNum (f :: * -> *) x extra r.
(Ord vNum, Foldable f, HasCallStack) =>
(x -> Versions vNum extra r) -> f x -> Versions vNum extra r
foldMapVersions Versions vNum extra r -> Versions vNum extra r
forall a. a -> a
id

-- |
-- A @'Maybe'@ like type which better explains its purpose.
--
data Accept vData
  = Accept vData
  | Refuse !Text
  deriving (Accept vData -> Accept vData -> Bool
(Accept vData -> Accept vData -> Bool)
-> (Accept vData -> Accept vData -> Bool) -> Eq (Accept vData)
forall vData. Eq vData => Accept vData -> Accept vData -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Accept vData -> Accept vData -> Bool
$c/= :: forall vData. Eq vData => Accept vData -> Accept vData -> Bool
== :: Accept vData -> Accept vData -> Bool
$c== :: forall vData. Eq vData => Accept vData -> Accept vData -> Bool
Eq, Int -> Accept vData -> ShowS
[Accept vData] -> ShowS
Accept vData -> [Char]
(Int -> Accept vData -> ShowS)
-> (Accept vData -> [Char])
-> ([Accept vData] -> ShowS)
-> Show (Accept vData)
forall vData. Show vData => Int -> Accept vData -> ShowS
forall vData. Show vData => [Accept vData] -> ShowS
forall vData. Show vData => Accept vData -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Accept vData] -> ShowS
$cshowList :: forall vData. Show vData => [Accept vData] -> ShowS
show :: Accept vData -> [Char]
$cshow :: forall vData. Show vData => Accept vData -> [Char]
showsPrec :: Int -> Accept vData -> ShowS
$cshowsPrec :: forall vData. Show vData => Int -> Accept vData -> ShowS
Show)

class Acceptable v where
  acceptableVersion :: v -> v -> Accept v


data Version vData r = Version
  { Version vData r -> vData -> r
versionApplication :: vData -> r
  , Version vData r -> vData
versionData        :: vData
  }
  deriving a -> Version vData b -> Version vData a
(a -> b) -> Version vData a -> Version vData b
(forall a b. (a -> b) -> Version vData a -> Version vData b)
-> (forall a b. a -> Version vData b -> Version vData a)
-> Functor (Version vData)
forall a b. a -> Version vData b -> Version vData a
forall a b. (a -> b) -> Version vData a -> Version vData b
forall vData a b. a -> Version vData b -> Version vData a
forall vData a b. (a -> b) -> Version vData a -> Version vData b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Version vData b -> Version vData a
$c<$ :: forall vData a b. a -> Version vData b -> Version vData a
fmap :: (a -> b) -> Version vData a -> Version vData b
$cfmap :: forall vData a b. (a -> b) -> Version vData a -> Version vData b
Functor

data VersionMismatch vNum where
  NoCommonVersion     :: VersionMismatch vNum
  InconsistentVersion :: vNum -> VersionMismatch vNum

--
-- Simple version negotiation
--

-- | Singleton smart constructor for 'Versions'.
--
simpleSingletonVersions
  :: vNum
  -> vData
  -> r
  -> Versions vNum vData r
simpleSingletonVersions :: vNum -> vData -> r -> Versions vNum vData r
simpleSingletonVersions vNum
vNum vData
vData r
r =
  Map vNum (Version vData r) -> Versions vNum vData r
forall vNum vData r.
Map vNum (Version vData r) -> Versions vNum vData r
Versions
    (Map vNum (Version vData r) -> Versions vNum vData r)
-> Map vNum (Version vData r) -> Versions vNum vData r
forall a b. (a -> b) -> a -> b
$ vNum -> Version vData r -> Map vNum (Version vData r)
forall k a. k -> a -> Map k a
Map.singleton vNum
vNum
      ((vData -> r) -> vData -> Version vData r
forall vData r. (vData -> r) -> vData -> Version vData r
Version (\vData
_ -> r
r) vData
vData)