trust-chain (empty) → 0.1.0.0
raw patch · 4 files changed
+241/−0 lines, 4 filesdep +basedep +binarydep +bytestring
Dependencies added: base, binary, bytestring, containers, cropty, merge, network, text, trust-chain
Files
- CHANGELOG.md +5/−0
- src/Data/TrustChain.hs +121/−0
- test/Test.hs +80/−0
- trust-chain.cabal +35/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for chat++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ src/Data/TrustChain.hs view
@@ -0,0 +1,121 @@+{-# 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 = LBS.toStrict $ Binary.encode 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 (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 (Trustless _) = True+validTrustChain (TrustProxy s) = verifySigned s && getAll (foldMap (All . validTrustChain) (signed 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 layer = TrustProxy <$> mkSigned privateKey layer++-- | Make a basic, trustless trust chain.+mkTrustless :: a -> TrustChain f a+mkTrustless = Trustless++-- |+-- A path through the trust chain.+data Claim a = Claim [PublicKey] a+ deriving (Eq, Ord, Typeable, Generic, Binary)++-- |+-- An inconsistency with the various accounts in the trust chain+data Inconsistency e a =+ IncompatibleClaim e (Claim a) [Claim a]+ deriving (Eq, Ord, Typeable, Generic, Binary)++-- |+-- Extract all of the claims from the trust chain.+claims :: (Eq a, Ord a, Foldable f) => TrustChain f a -> [Claim a]+claims = \case+ Trustless a -> [Claim [] a]+ TrustProxy s -> (\(Claim ps a) -> Claim (signedBy s : ps) a) <$> foldMap claims (signed 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 getKey f cs = go Map.empty cs where+ go as [] = Right (Map.map fst as)+ go as (Claim ps a : xxs) =+ case Map.lookup (getKey a) as of+ Just (a', pss) -> case runMerge f a a' of+ Success a'' -> go (Map.adjust (\_ -> (a'', Claim ps a : pss)) (getKey a) as) xxs+ Error e -> Left (IncompatibleClaim e (Claim ps a) pss)+ Nothing -> go (Map.insert (getKey a) (a, [Claim ps a]) as) xxs
+ test/Test.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Data.Binary (encode, decode, Binary(..))+import GHC.Generics (Generic)+import Data.TrustChain+import Data.Merge+import Cropty+import System.Exit (exitFailure)+import Control.Monad (forM_)+import Data.Map (Map)+import Data.Text (Text)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set++requires :: String -> [Bool] -> IO ()+requires msg = mapM_ (uncurry go) . zip [1..] where+ go x y = if y then pure () else putStrLn (msg <> ": " <> show x) >> exitFailure++main :: IO ()+main = do+ privateKey0 <- generatePrivateKey KeySize256+ privateKey1 <- generatePrivateKey KeySize256+ let trustChain0 :: TrustChain [] String = Trustless "Hello"+ trustChain1 <- mkTrustProxy privateKey0 [mkTrustless "Hi", trustChain0]+ trustChain2 <- mkTrustProxy privateKey1 [mkTrustless "Hey", trustChain1]+ let roundTrip f g x = x == f (g x)+ requires "validTrustChain"+ [ validTrustChain trustChain0+ , validTrustChain trustChain1+ , validTrustChain trustChain2+ ]+ requires "claims"+ [ claims trustChain0 == [Claim [] "Hello"]+ , claims trustChain1 == [Claim [privateToPublic privateKey0] "Hi", Claim [privateToPublic privateKey0] "Hello"]+ , claims trustChain2 == [Claim [privateToPublic privateKey1] "Hey", Claim [privateToPublic privateKey1, privateToPublic privateKey0] "Hi", Claim [privateToPublic privateKey1, privateToPublic privateKey0] "Hello"] + ]+ requires "assignments"+ [ assignments id (required id .? ["bad id"]) (claims trustChain0) == Right (Map.fromList [("Hello", "Hello")])+ ]+ requires "encode/decode" $ map (roundTrip decode encode) [trustChain0, trustChain1, trustChain2]+ person++type Time = Integer++data Person = Person+ { pubKey :: PublicKey+ , legalName :: Maybe Text+ , emails :: Set Text+ , posts :: Set (Time, Text)+ }+ deriving (Eq, Ord, Binary, Generic)++mergePerson :: Merge [String] Person Person+mergePerson =+ Person+ <$> required pubKey+ <*> optional legalName+ <*> combine emails+ <*> combine posts++person :: IO ()+person = do+ privateKey0 <- generatePrivateKey KeySize256+ privateKey1 <- generatePrivateKey KeySize256+ let myself = Person (privateToPublic privateKey0) (Just "Samuel Schlesinger") (Set.fromList ["sgschlesinger@gmail.com", "samuel@simspace.com"]) (Set.fromList [])+ let myfriend = Person (privateToPublic privateKey1) (Just "My Friend") (Set.fromList ["friend@friendly.com"]) Set.empty+ let partialfriend = Person (privateToPublic privateKey1) Nothing Set.empty Set.empty+ tc0 <- mkTrustProxy privateKey0 [Trustless myself, Trustless partialfriend]+ tc1 <- mkTrustProxy privateKey1 [Trustless myfriend]+ tc0' <- mkTrustProxy privateKey0 [tc0, tc1]+ tc1' <- mkTrustProxy privateKey1 [tc0, tc1]+ requires "person"+ [ assignments pubKey mergePerson (claims tc1') == assignments pubKey mergePerson (claims tc0')+ , assignments pubKey mergePerson (claims tc0') == Right (Map.fromList [(privateToPublic privateKey0, myself), (privateToPublic privateKey1, myfriend)])+ ]
+ trust-chain.cabal view
@@ -0,0 +1,35 @@+cabal-version: 2.4+name: trust-chain+version: 0.1.0.0+category: Cryptography, Crypto+synopsis: An implementation of a trust chain+license: MIT+description: An implementation of a trust chain.+author: Samuel Schlesinger+maintainer: sgschlesinger@gmail.com+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/samuelschlesinger/trust-chain++library+ exposed-modules: Data.TrustChain+ build-depends:+ , base >=4.6 && <5+ , network >=3.1 && <4+ , binary >=0.8 && <1+ , bytestring >=0.11 && <1+ , text >=1.2 && <2+ , containers >=0.6 && <1+ , cropty >=0.3+ , merge >=0.3+ hs-source-dirs: src+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: Test.hs+ hs-source-dirs: test+ build-depends: base >= 4.12 && <5, trust-chain, cropty, merge, binary, containers, text+ default-language: Haskell2010