{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.TrustChain
(
TrustChain (..)
, validTrustChain
, mkTrustProxy
, mkTrustless
, Claim (..)
, claims
, assignments
, Inconsistency (..)
, PublicKey
, PrivateKey
, Signed(..)
, Merge
) where
import Data.Text (Text)
import Data.Set (Set)
import Data.Typeable (Typeable)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Functor.Identity (Identity (..))
import Data.Binary (Binary (..))
import qualified Data.Binary as Binary
import GHC.Generics (Generic)
import Data.Semigroup (All(All, getAll))
import Cropty
import Data.Merge
encode :: Binary a => a -> ByteString
encode :: a -> ByteString
encode a
a = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode a
a
data TrustChain f a =
Trustless a
| TrustProxy (Signed (f (TrustChain f a)))
deriving ((forall x. TrustChain f a -> Rep (TrustChain f a) x)
-> (forall x. Rep (TrustChain f a) x -> TrustChain f a)
-> Generic (TrustChain f a)
forall x. Rep (TrustChain f a) x -> TrustChain f a
forall x. TrustChain f a -> Rep (TrustChain f a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) a x. Rep (TrustChain f a) x -> TrustChain f a
forall (f :: * -> *) a x. TrustChain f a -> Rep (TrustChain f a) x
$cto :: forall (f :: * -> *) a x. Rep (TrustChain f a) x -> TrustChain f a
$cfrom :: forall (f :: * -> *) a x. TrustChain f a -> Rep (TrustChain f a) x
Generic, Typeable)
deriving instance (Show a, forall a. Show a => Show (f a)) => Show (TrustChain f a)
deriving instance (Read a, forall a. Read a => Read (f a)) => Read (TrustChain f a)
deriving instance (Eq a, forall a. Eq a => Eq (f a)) => Eq (TrustChain f a)
deriving instance (Binary a, forall a. Binary a => Binary (f a)) => Binary (TrustChain f a)
validTrustChain :: (Binary a, forall x. Binary x => Binary (f x), Foldable f) => TrustChain f a -> Bool
validTrustChain :: TrustChain f a -> Bool
validTrustChain (Trustless a
_) = Bool
True
validTrustChain (TrustProxy Signed (f (TrustChain f a))
s) = Signed (f (TrustChain f a)) -> Bool
forall a. Signed a -> Bool
verifySigned Signed (f (TrustChain f a))
s Bool -> Bool -> Bool
&& All -> Bool
getAll ((TrustChain f a -> All) -> f (TrustChain f a) -> All
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Bool -> All
All (Bool -> All) -> (TrustChain f a -> Bool) -> TrustChain f a -> All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrustChain f a -> Bool
forall a (f :: * -> *).
(Binary a, forall x. Binary x => Binary (f x), Foldable f) =>
TrustChain f a -> Bool
validTrustChain) (Signed (f (TrustChain f a)) -> f (TrustChain f a)
forall a. Signed a -> a
signed Signed (f (TrustChain f a))
s))
mkTrustProxy ::
( Traversable f
, Binary a
, forall a. Binary a => Binary (f a)
, forall a. Monoid (f a)
, Applicative f
)
=> PrivateKey
-> f (TrustChain f a)
-> IO (TrustChain f a)
mkTrustProxy :: PrivateKey -> f (TrustChain f a) -> IO (TrustChain f a)
mkTrustProxy PrivateKey
privateKey f (TrustChain f a)
layer = Signed (f (TrustChain f a)) -> TrustChain f a
forall (f :: * -> *) a.
Signed (f (TrustChain f a)) -> TrustChain f a
TrustProxy (Signed (f (TrustChain f a)) -> TrustChain f a)
-> IO (Signed (f (TrustChain f a))) -> IO (TrustChain f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrivateKey
-> f (TrustChain f a) -> IO (Signed (f (TrustChain f a)))
forall a. Binary a => PrivateKey -> a -> IO (Signed a)
mkSigned PrivateKey
privateKey f (TrustChain f a)
layer
mkTrustless :: a -> TrustChain f a
mkTrustless :: a -> TrustChain f a
mkTrustless = a -> TrustChain f a
forall (f :: * -> *) a. a -> TrustChain f a
Trustless
data Claim a = Claim [PublicKey] a
deriving (Claim a -> Claim a -> Bool
(Claim a -> Claim a -> Bool)
-> (Claim a -> Claim a -> Bool) -> Eq (Claim a)
forall a. Eq a => Claim a -> Claim a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Claim a -> Claim a -> Bool
$c/= :: forall a. Eq a => Claim a -> Claim a -> Bool
== :: Claim a -> Claim a -> Bool
$c== :: forall a. Eq a => Claim a -> Claim a -> Bool
Eq, Eq (Claim a)
Eq (Claim a)
-> (Claim a -> Claim a -> Ordering)
-> (Claim a -> Claim a -> Bool)
-> (Claim a -> Claim a -> Bool)
-> (Claim a -> Claim a -> Bool)
-> (Claim a -> Claim a -> Bool)
-> (Claim a -> Claim a -> Claim a)
-> (Claim a -> Claim a -> Claim a)
-> Ord (Claim a)
Claim a -> Claim a -> Bool
Claim a -> Claim a -> Ordering
Claim a -> Claim a -> Claim a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Claim a)
forall a. Ord a => Claim a -> Claim a -> Bool
forall a. Ord a => Claim a -> Claim a -> Ordering
forall a. Ord a => Claim a -> Claim a -> Claim a
min :: Claim a -> Claim a -> Claim a
$cmin :: forall a. Ord a => Claim a -> Claim a -> Claim a
max :: Claim a -> Claim a -> Claim a
$cmax :: forall a. Ord a => Claim a -> Claim a -> Claim a
>= :: Claim a -> Claim a -> Bool
$c>= :: forall a. Ord a => Claim a -> Claim a -> Bool
> :: Claim a -> Claim a -> Bool
$c> :: forall a. Ord a => Claim a -> Claim a -> Bool
<= :: Claim a -> Claim a -> Bool
$c<= :: forall a. Ord a => Claim a -> Claim a -> Bool
< :: Claim a -> Claim a -> Bool
$c< :: forall a. Ord a => Claim a -> Claim a -> Bool
compare :: Claim a -> Claim a -> Ordering
$ccompare :: forall a. Ord a => Claim a -> Claim a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Claim a)
Ord, Typeable, (forall x. Claim a -> Rep (Claim a) x)
-> (forall x. Rep (Claim a) x -> Claim a) -> Generic (Claim a)
forall x. Rep (Claim a) x -> Claim a
forall x. Claim a -> Rep (Claim a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Claim a) x -> Claim a
forall a x. Claim a -> Rep (Claim a) x
$cto :: forall a x. Rep (Claim a) x -> Claim a
$cfrom :: forall a x. Claim a -> Rep (Claim a) x
Generic, Get (Claim a)
[Claim a] -> Put
Claim a -> Put
(Claim a -> Put)
-> Get (Claim a) -> ([Claim a] -> Put) -> Binary (Claim a)
forall a. Binary a => Get (Claim a)
forall a. Binary a => [Claim a] -> Put
forall a. Binary a => Claim a -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Claim a] -> Put
$cputList :: forall a. Binary a => [Claim a] -> Put
get :: Get (Claim a)
$cget :: forall a. Binary a => Get (Claim a)
put :: Claim a -> Put
$cput :: forall a. Binary a => Claim a -> Put
Binary)
data Inconsistency e a =
IncompatibleClaim e (Claim a) [Claim a]
deriving (Inconsistency e a -> Inconsistency e a -> Bool
(Inconsistency e a -> Inconsistency e a -> Bool)
-> (Inconsistency e a -> Inconsistency e a -> Bool)
-> Eq (Inconsistency e a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall e a.
(Eq e, Eq a) =>
Inconsistency e a -> Inconsistency e a -> Bool
/= :: Inconsistency e a -> Inconsistency e a -> Bool
$c/= :: forall e a.
(Eq e, Eq a) =>
Inconsistency e a -> Inconsistency e a -> Bool
== :: Inconsistency e a -> Inconsistency e a -> Bool
$c== :: forall e a.
(Eq e, Eq a) =>
Inconsistency e a -> Inconsistency e a -> Bool
Eq, Eq (Inconsistency e a)
Eq (Inconsistency e a)
-> (Inconsistency e a -> Inconsistency e a -> Ordering)
-> (Inconsistency e a -> Inconsistency e a -> Bool)
-> (Inconsistency e a -> Inconsistency e a -> Bool)
-> (Inconsistency e a -> Inconsistency e a -> Bool)
-> (Inconsistency e a -> Inconsistency e a -> Bool)
-> (Inconsistency e a -> Inconsistency e a -> Inconsistency e a)
-> (Inconsistency e a -> Inconsistency e a -> Inconsistency e a)
-> Ord (Inconsistency e a)
Inconsistency e a -> Inconsistency e a -> Bool
Inconsistency e a -> Inconsistency e a -> Ordering
Inconsistency e a -> Inconsistency e a -> Inconsistency e a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall e a. (Ord e, Ord a) => Eq (Inconsistency e a)
forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Bool
forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Ordering
forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Inconsistency e a
min :: Inconsistency e a -> Inconsistency e a -> Inconsistency e a
$cmin :: forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Inconsistency e a
max :: Inconsistency e a -> Inconsistency e a -> Inconsistency e a
$cmax :: forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Inconsistency e a
>= :: Inconsistency e a -> Inconsistency e a -> Bool
$c>= :: forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Bool
> :: Inconsistency e a -> Inconsistency e a -> Bool
$c> :: forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Bool
<= :: Inconsistency e a -> Inconsistency e a -> Bool
$c<= :: forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Bool
< :: Inconsistency e a -> Inconsistency e a -> Bool
$c< :: forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Bool
compare :: Inconsistency e a -> Inconsistency e a -> Ordering
$ccompare :: forall e a.
(Ord e, Ord a) =>
Inconsistency e a -> Inconsistency e a -> Ordering
$cp1Ord :: forall e a. (Ord e, Ord a) => Eq (Inconsistency e a)
Ord, Typeable, (forall x. Inconsistency e a -> Rep (Inconsistency e a) x)
-> (forall x. Rep (Inconsistency e a) x -> Inconsistency e a)
-> Generic (Inconsistency e a)
forall x. Rep (Inconsistency e a) x -> Inconsistency e a
forall x. Inconsistency e a -> Rep (Inconsistency e a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall e a x. Rep (Inconsistency e a) x -> Inconsistency e a
forall e a x. Inconsistency e a -> Rep (Inconsistency e a) x
$cto :: forall e a x. Rep (Inconsistency e a) x -> Inconsistency e a
$cfrom :: forall e a x. Inconsistency e a -> Rep (Inconsistency e a) x
Generic, Get (Inconsistency e a)
[Inconsistency e a] -> Put
Inconsistency e a -> Put
(Inconsistency e a -> Put)
-> Get (Inconsistency e a)
-> ([Inconsistency e a] -> Put)
-> Binary (Inconsistency e a)
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
forall e a. (Binary e, Binary a) => Get (Inconsistency e a)
forall e a. (Binary e, Binary a) => [Inconsistency e a] -> Put
forall e a. (Binary e, Binary a) => Inconsistency e a -> Put
putList :: [Inconsistency e a] -> Put
$cputList :: forall e a. (Binary e, Binary a) => [Inconsistency e a] -> Put
get :: Get (Inconsistency e a)
$cget :: forall e a. (Binary e, Binary a) => Get (Inconsistency e a)
put :: Inconsistency e a -> Put
$cput :: forall e a. (Binary e, Binary a) => Inconsistency e a -> Put
Binary)
claims :: (Eq a, Ord a, Foldable f) => TrustChain f a -> [Claim a]
claims :: TrustChain f a -> [Claim a]
claims = \case
Trustless a
a -> [[PublicKey] -> a -> Claim a
forall a. [PublicKey] -> a -> Claim a
Claim [] a
a]
TrustProxy Signed (f (TrustChain f a))
s -> (\(Claim [PublicKey]
ps a
a) -> [PublicKey] -> a -> Claim a
forall a. [PublicKey] -> a -> Claim a
Claim (Signed (f (TrustChain f a)) -> PublicKey
forall a. Signed a -> PublicKey
signedBy Signed (f (TrustChain f a))
s PublicKey -> [PublicKey] -> [PublicKey]
forall a. a -> [a] -> [a]
: [PublicKey]
ps) a
a) (Claim a -> Claim a) -> [Claim a] -> [Claim a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TrustChain f a -> [Claim a]) -> f (TrustChain f a) -> [Claim a]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TrustChain f a -> [Claim a]
forall a (f :: * -> *).
(Eq a, Ord a, Foldable f) =>
TrustChain f a -> [Claim a]
claims (Signed (f (TrustChain f a)) -> f (TrustChain f a)
forall a. Signed a -> a
signed Signed (f (TrustChain f a))
s)
assignments :: (Ord k, Eq a, Ord a) => (a -> k) -> Merge e a a -> [Claim a] -> Either (Inconsistency e a) (Map k a)
assignments :: (a -> k)
-> Merge e a a -> [Claim a] -> Either (Inconsistency e a) (Map k a)
assignments a -> k
getKey Merge e a a
f [Claim a]
cs = Map k (a, [Claim a])
-> [Claim a] -> Either (Inconsistency e a) (Map k a)
go Map k (a, [Claim a])
forall k a. Map k a
Map.empty [Claim a]
cs where
go :: Map k (a, [Claim a])
-> [Claim a] -> Either (Inconsistency e a) (Map k a)
go Map k (a, [Claim a])
as [] = Map k a -> Either (Inconsistency e a) (Map k a)
forall a b. b -> Either a b
Right (((a, [Claim a]) -> a) -> Map k (a, [Claim a]) -> Map k a
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (a, [Claim a]) -> a
forall a b. (a, b) -> a
fst Map k (a, [Claim a])
as)
go Map k (a, [Claim a])
as (Claim [PublicKey]
ps a
a : [Claim a]
xxs) =
case k -> Map k (a, [Claim a]) -> Maybe (a, [Claim a])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (a -> k
getKey a
a) Map k (a, [Claim a])
as of
Just (a
a', [Claim a]
pss) -> case Merge e a a -> a -> a -> Validation e a
forall e x a. Merge e x a -> x -> x -> Validation e a
runMerge Merge e a a
f a
a a
a' of
Success a
a'' -> Map k (a, [Claim a])
-> [Claim a] -> Either (Inconsistency e a) (Map k a)
go (((a, [Claim a]) -> (a, [Claim a]))
-> k -> Map k (a, [Claim a]) -> Map k (a, [Claim a])
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\(a, [Claim a])
_ -> (a
a'', [PublicKey] -> a -> Claim a
forall a. [PublicKey] -> a -> Claim a
Claim [PublicKey]
ps a
a Claim a -> [Claim a] -> [Claim a]
forall a. a -> [a] -> [a]
: [Claim a]
pss)) (a -> k
getKey a
a) Map k (a, [Claim a])
as) [Claim a]
xxs
Error e
e -> Inconsistency e a -> Either (Inconsistency e a) (Map k a)
forall a b. a -> Either a b
Left (e -> Claim a -> [Claim a] -> Inconsistency e a
forall e a. e -> Claim a -> [Claim a] -> Inconsistency e a
IncompatibleClaim e
e ([PublicKey] -> a -> Claim a
forall a. [PublicKey] -> a -> Claim a
Claim [PublicKey]
ps a
a) [Claim a]
pss)
Maybe (a, [Claim a])
Nothing -> Map k (a, [Claim a])
-> [Claim a] -> Either (Inconsistency e a) (Map k a)
go (k -> (a, [Claim a]) -> Map k (a, [Claim a]) -> Map k (a, [Claim a])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (a -> k
getKey a
a) (a
a, [[PublicKey] -> a -> Claim a
forall a. [PublicKey] -> a -> Claim a
Claim [PublicKey]
ps a
a]) Map k (a, [Claim a])
as) [Claim a]
xxs