{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.TrustChain
  ( 
    -- * Trust Chains
    TrustChain (..)
  , validTrustChain
  , mkTrustProxy
  , mkTrustless
    -- * Claims
  , Claim (..)
  , claims
    -- * Index and Merge
  , assignments 
    -- * Inconsistencies
  , Inconsistency (..)
    -- * Re-Exports from Cropty
  , PublicKey
  , PrivateKey
  , Signed(..)
    -- * Re-Exports from Data.Merge
  , 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

-- | A tree of trust of the given shape, where each internal node of the
-- tree is signed by potentially different keys. @TrustChain Identity a@
-- is a linear signature chain, whereas @TrustChain NonEmpty a@ is a tree
-- shaped trust chain. We can keep track of metadata at each internal
-- node of any structure using @TrustChain (Compose ((,) metadata) f) a@.
--
-- For those who are familiar with the free monad, you can think of this
-- as a free monad where the internal nodes are signed by differing parties.
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)

-- | Check that the trust chain has been legitimately signed. Once you receive
-- 'True' from this function, you can be certain that all of the 'Signed'
-- types within are truly correct.
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))

-- | Extend the trust chain with new subchains and new items.
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

-- | Make a basic, trustless trust chain.
mkTrustless :: a -> TrustChain f a
mkTrustless :: a -> TrustChain f a
mkTrustless = a -> TrustChain f a
forall (f :: * -> *) a. a -> TrustChain f a
Trustless

-- |
-- A path through the trust chain.
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)

-- |
-- An inconsistency with the various accounts in the trust chain
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)

-- |
-- Extract all of the claims from the trust chain.
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)

-- | 
-- Extract all of the assignments from the trust chain, unifying information contained
-- within them. This is where we might find potential inconsistencies.
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