{-# LANGUAGE ScopedTypeVariables #-}

module Tahoe.CHK.Validate where

import Control.Lens (view)
import Crypto.Hash (HashAlgorithm)
import Data.Bifunctor (Bifunctor (first))
import qualified Data.ByteString.Lazy as LB
import Tahoe.CHK.Capability (Verifier, fingerprint)
import Tahoe.CHK.Crypto (blockHash', ciphertextSegmentHash', uriExtensionHash)
import Tahoe.CHK.Merkle (checkMerkleProof, heightForLeafCount, leafHashes, rootHash)
import Tahoe.CHK.SHA256d (Digest', SHA256d)
import Tahoe.CHK.Share (Crypttext, Share (..), blockHashTree, blocks, crypttextHashTree, neededHashes, uriExtension)
import Tahoe.CHK.URIExtension (crypttextRootHash, shareRootHash, totalShares)

{- | Determine the validity of the given share's fingerprint as defined by the
 given capability.
-}
validFingerprint :: Verifier -> Share -> Bool
validFingerprint :: Verifier -> Share -> Bool
validFingerprint Verifier
cap = (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Getting ByteString Verifier ByteString -> Verifier -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString Verifier ByteString
Lens' Verifier ByteString
fingerprint Verifier
cap) (ByteString -> Bool) -> (Share -> ByteString) -> Share -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URIExtension -> ByteString
uriExtensionHash (URIExtension -> ByteString)
-> (Share -> URIExtension) -> Share -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Share -> URIExtension
_uriExtension

{- | True if the root of the crypttext hash tree in the share matches the
 crypttext hash root given in the URI extension block.  False otherwise.
-}
matchingCrypttextHashRoot :: Share -> Bool
matchingCrypttextHashRoot :: Share -> Bool
matchingCrypttextHashRoot Share
share = Digest' SHA256d
inShare Digest' SHA256d -> Digest' SHA256d -> Bool
forall a. Eq a => a -> a -> Bool
== Digest' SHA256d
inUEB
  where
    inShare :: Digest' SHA256d
inShare = MerkleTree ByteString SHA256d -> Digest' SHA256d
forall v a. MerkleTree v a -> Digest' a
rootHash (MerkleTree ByteString SHA256d -> Digest' SHA256d)
-> (Share -> MerkleTree ByteString SHA256d)
-> Share
-> Digest' SHA256d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
-> Share -> MerkleTree ByteString SHA256d
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
Lens' Share (MerkleTree ByteString SHA256d)
crypttextHashTree (Share -> Digest' SHA256d) -> Share -> Digest' SHA256d
forall a b. (a -> b) -> a -> b
$ Share
share
    inUEB :: Digest' SHA256d
inUEB = Getting (Digest' SHA256d) Share (Digest' SHA256d)
-> Share -> Digest' SHA256d
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((URIExtension -> Const (Digest' SHA256d) URIExtension)
-> Share -> Const (Digest' SHA256d) Share
Lens' Share URIExtension
uriExtension ((URIExtension -> Const (Digest' SHA256d) URIExtension)
 -> Share -> Const (Digest' SHA256d) Share)
-> ((Digest' SHA256d -> Const (Digest' SHA256d) (Digest' SHA256d))
    -> URIExtension -> Const (Digest' SHA256d) URIExtension)
-> Getting (Digest' SHA256d) Share (Digest' SHA256d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Digest' SHA256d -> Const (Digest' SHA256d) (Digest' SHA256d))
-> URIExtension -> Const (Digest' SHA256d) URIExtension
Lens' URIExtension (Digest' SHA256d)
crypttextRootHash) Share
share

{- | True if the share's own hash in the `shareNeededHashes` list equals the
 root of the share's block hash merkle tree, False otherwise.
-}
matchingBlockHashRoot :: Int -> Share -> Bool
matchingBlockHashRoot :: Int -> Share -> Bool
matchingBlockHashRoot Int
shareNum Share
share =
    -- We should find exactly one element with a share number matching our
    -- share number and the associated hash should match our hash.  If we find
    -- none or more than one then the share is mis-encoded and we should fail
    -- validation (though maybe we should do so with a distinct error value).
    Bool
isMatching
  where
    isMatching :: Bool
isMatching =
        [(Int, Digest' SHA256d)] -> Bool
forall a. [(a, Digest' SHA256d)] -> Bool
checkMatch
            ([(Int, Digest' SHA256d)] -> Bool)
-> ([(Int, Digest' SHA256d)] -> [(Int, Digest' SHA256d)])
-> [(Int, Digest' SHA256d)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Digest' SHA256d)] -> [(Int, Digest' SHA256d)]
forall b. [(Int, b)] -> [(Int, b)]
findOwnHash
            ([(Int, Digest' SHA256d)] -> Bool)
-> [(Int, Digest' SHA256d)] -> Bool
forall a b. (a -> b) -> a -> b
$ Getting [(Int, Digest' SHA256d)] Share [(Int, Digest' SHA256d)]
-> Share -> [(Int, Digest' SHA256d)]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [(Int, Digest' SHA256d)] Share [(Int, Digest' SHA256d)]
Lens' Share [(Int, Digest' SHA256d)]
neededHashes Share
share

    checkMatch :: [(a, Digest' SHA256d)] -> Bool
checkMatch = ([MerkleTree ByteString SHA256d -> Digest' SHA256d
forall v a. MerkleTree v a -> Digest' a
rootHash (Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
-> Share -> MerkleTree ByteString SHA256d
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
Lens' Share (MerkleTree ByteString SHA256d)
blockHashTree Share
share)] [Digest' SHA256d] -> [Digest' SHA256d] -> Bool
forall a. Eq a => a -> a -> Bool
==) ([Digest' SHA256d] -> Bool)
-> ([(a, Digest' SHA256d)] -> [Digest' SHA256d])
-> [(a, Digest' SHA256d)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Digest' SHA256d) -> Digest' SHA256d)
-> [(a, Digest' SHA256d)] -> [Digest' SHA256d]
forall a b. (a -> b) -> [a] -> [b]
map (a, Digest' SHA256d) -> Digest' SHA256d
forall a b. (a, b) -> b
snd

    -- Note that shareNeededHashes contains "node numbers" while our
    -- shareNum is a "leaf number".  So, convert.
    findOwnHash :: [(Int, b)] -> [(Int, b)]
findOwnHash = ((Int, b) -> Bool) -> [(Int, b)] -> [(Int, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nodeNumber) (Int -> Bool) -> ((Int, b) -> Int) -> (Int, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst)

    nodeNumber :: Int
    nodeNumber :: Int
nodeNumber = Int -> Int
forall a. Num a => a -> a
toNodeNumber Int
shareNum

    toNodeNumber :: a -> a
toNodeNumber a
num = a
num a -> a -> a
forall a. Num a => a -> a -> a
+ (a
2 a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
treeHeight) a -> a -> a
forall a. Num a => a -> a -> a
- a
1
    treeHeight :: Int
treeHeight = Total -> Int
forall n. Integral n => n -> Int
heightForLeafCount (Total -> Int) -> (Share -> Total) -> Share -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Total Share Total -> Share -> Total
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((URIExtension -> Const Total URIExtension)
-> Share -> Const Total Share
Lens' Share URIExtension
uriExtension ((URIExtension -> Const Total URIExtension)
 -> Share -> Const Total Share)
-> ((Total -> Const Total Total)
    -> URIExtension -> Const Total URIExtension)
-> Getting Total Share Total
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Total -> Const Total Total)
-> URIExtension -> Const Total URIExtension
Lens' URIExtension Total
totalShares) (Share -> Int) -> Share -> Int
forall a b. (a -> b) -> a -> b
$ Share
share

{- | Determine the validity of each of the given shares' "share root hash"
 values with respect to the other shares in the list.
-}
validShareRootHash :: [(Int, Share)] -> [Bool]
validShareRootHash :: [(Int, Share)] -> [Bool]
validShareRootHash [] = []
validShareRootHash shares :: [(Int, Share)]
shares@((Int
_, Share
aShare) : [(Int, Share)]
_) =
    [Bool]
isValid
  where
    isValid :: [Bool]
isValid = ([(Int, Digest' SHA256d)] -> Digest' SHA256d -> Bool)
-> [[(Int, Digest' SHA256d)]] -> [Digest' SHA256d] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([(Int, Digest' SHA256d)]
-> Digest' SHA256d -> Digest' SHA256d -> Bool
forall n hash.
(Integral n, HashAlgorithm hash) =>
[(n, Digest' hash)] -> Digest' hash -> Digest' hash -> Bool
`checkMerkleProof` Digest' SHA256d
expected) [[(Int, Digest' SHA256d)]]
proofs [Digest' SHA256d]
leafs

    -- You already validated the share fingerprint so the expected share root
    -- hash from the UEB has also been validated and we can use it.  The UEB
    -- is the same for all shares so we can pull this value from an arbitrary
    -- share.
    expected :: Digest' SHA256d
expected = Getting (Digest' SHA256d) Share (Digest' SHA256d)
-> Share -> Digest' SHA256d
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((URIExtension -> Const (Digest' SHA256d) URIExtension)
-> Share -> Const (Digest' SHA256d) Share
Lens' Share URIExtension
uriExtension ((URIExtension -> Const (Digest' SHA256d) URIExtension)
 -> Share -> Const (Digest' SHA256d) Share)
-> ((Digest' SHA256d -> Const (Digest' SHA256d) (Digest' SHA256d))
    -> URIExtension -> Const (Digest' SHA256d) URIExtension)
-> Getting (Digest' SHA256d) Share (Digest' SHA256d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Digest' SHA256d -> Const (Digest' SHA256d) (Digest' SHA256d))
-> URIExtension -> Const (Digest' SHA256d) URIExtension
Lens' URIExtension (Digest' SHA256d)
shareRootHash) Share
aShare

    -- Extract the proof for each share in the given list.
    proofs :: [[(Int, Digest' SHA256d)]]
proofs = (Int -> Share -> [(Int, Digest' SHA256d)])
-> (Int, Share) -> [(Int, Digest' SHA256d)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Share -> [(Int, Digest' SHA256d)]
oneProof ((Int, Share) -> [(Int, Digest' SHA256d)])
-> [(Int, Share)] -> [[(Int, Digest' SHA256d)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Share)]
shares

    -- Also extract each share's leaf hash to supply to the proof checker.
    leafs :: [Digest' SHA256d]
leafs = MerkleTree ByteString SHA256d -> Digest' SHA256d
forall v a. MerkleTree v a -> Digest' a
rootHash (MerkleTree ByteString SHA256d -> Digest' SHA256d)
-> ((Int, Share) -> MerkleTree ByteString SHA256d)
-> (Int, Share)
-> Digest' SHA256d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
-> Share -> MerkleTree ByteString SHA256d
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
Lens' Share (MerkleTree ByteString SHA256d)
blockHashTree (Share -> MerkleTree ByteString SHA256d)
-> ((Int, Share) -> Share)
-> (Int, Share)
-> MerkleTree ByteString SHA256d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Share) -> Share
forall a b. (a, b) -> b
snd ((Int, Share) -> Digest' SHA256d)
-> [(Int, Share)] -> [Digest' SHA256d]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Share)]
shares

    oneProof :: Int -> Share -> [(Int, Digest' SHA256d)]
    oneProof :: Int -> Share -> [(Int, Digest' SHA256d)]
oneProof Int
shareNum Share
share = ((Int, Digest' SHA256d) -> (Int, Digest' SHA256d))
-> [(Int, Digest' SHA256d)] -> [(Int, Digest' SHA256d)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Int) -> (Int, Digest' SHA256d) -> (Int, Digest' SHA256d)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [(Int, Digest' SHA256d)]
proof
      where
        -- The length of the proof equals the height of the tree.
        treeHeight :: Int
treeHeight = [(Int, Digest' SHA256d)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Getting [(Int, Digest' SHA256d)] Share [(Int, Digest' SHA256d)]
-> Share -> [(Int, Digest' SHA256d)]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [(Int, Digest' SHA256d)] Share [(Int, Digest' SHA256d)]
Lens' Share [(Int, Digest' SHA256d)]
neededHashes Share
share)

        -- Since inclusion of our block tree root hash is what the proof is
        -- proving we don't want it.  We need to take it out to use our proof
        -- checker.  That means we need to find it.  The "needed hashes" are
        -- labeled by tree _node number_ and our share number is effectively a
        -- _leaf number_ so we need to convert for comparison.

        -- Nodes are numbered consecutively, starting at 0 for the root node
        -- and proceeding left-to-right depth-first.
        firstLeafNum :: Int
firstLeafNum = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
treeHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        nodeNum :: Int
nodeNum = Int
firstLeafNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
shareNum

        -- The proof is all of the needed hashes except for this share's own
        -- hash which we will feed into the proof checker separately.
        proof :: [(Int, Digest' SHA256d)]
proof = ((Int, Digest' SHA256d) -> Bool)
-> [(Int, Digest' SHA256d)] -> [(Int, Digest' SHA256d)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nodeNum) (Int -> Bool)
-> ((Int, Digest' SHA256d) -> Int)
-> (Int, Digest' SHA256d)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Digest' SHA256d) -> Int
forall a b. (a, b) -> a
fst) ((Int -> Int) -> (Int, Digest' SHA256d) -> (Int, Digest' SHA256d)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int, Digest' SHA256d) -> (Int, Digest' SHA256d))
-> [(Int, Digest' SHA256d)] -> [(Int, Digest' SHA256d)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting [(Int, Digest' SHA256d)] Share [(Int, Digest' SHA256d)]
-> Share -> [(Int, Digest' SHA256d)]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [(Int, Digest' SHA256d)] Share [(Int, Digest' SHA256d)]
Lens' Share [(Int, Digest' SHA256d)]
neededHashes Share
share)

showHashes :: (Show a, Show b) => [(a, b)] -> String
showHashes :: [(a, b)] -> String
showHashes = [String] -> String
unwords ([String] -> String)
-> ([(a, b)] -> [String]) -> [(a, b)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> String) -> [(a, b)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> String
forall a b. (Show a, Show b) => (a, b) -> String
showHash

showHash :: (Show a, Show b) => (a, b) -> String
showHash :: (a, b) -> String
showHash (a
n, b
bs) = [String] -> String
unwords [a -> String
forall a. Show a => a -> String
show a
n, b -> String
forall a. Show a => a -> String
show b
bs]

{- | Get only and all the blocks from the given share with hashes that match
 the values in the Share's "block hash tree".
-}
shareValidBlocks :: Share -> [Maybe LB.ByteString]
shareValidBlocks :: Share -> [Maybe ByteString]
shareValidBlocks Share
share =
    (ByteString -> Digest' SHA256d -> Maybe ByteString)
-> [ByteString] -> [Digest' SHA256d] -> [Maybe ByteString]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ByteString -> Digest' SHA256d -> Maybe ByteString
forall hash.
HashAlgorithm hash =>
ByteString -> Digest' hash -> Maybe ByteString
checkHash (Getting [ByteString] Share [ByteString] -> Share -> [ByteString]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [ByteString] Share [ByteString]
Lens' Share [ByteString]
blocks Share
share) (MerkleTree ByteString SHA256d -> [Digest' SHA256d]
forall v a. MerkleTree v a -> [Digest' a]
leafHashes (Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
-> Share -> MerkleTree ByteString SHA256d
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
Lens' Share (MerkleTree ByteString SHA256d)
blockHashTree Share
share))
  where
    checkHash :: forall hash. HashAlgorithm hash => LB.ByteString -> Digest' hash -> Maybe LB.ByteString
    checkHash :: ByteString -> Digest' hash -> Maybe ByteString
checkHash ByteString
bs Digest' hash
expected
        | ByteString -> Digest' hash
forall hash. HashAlgorithm hash => ByteString -> Digest' hash
blockHash' (ByteString -> ByteString
LB.toStrict ByteString
bs) Digest' hash -> Digest' hash -> Bool
forall a. Eq a => a -> a -> Bool
== Digest' hash
expected = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
        | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing

{- | Compare the hash of one segment to an expected hash value and return
 Nothing if it does not match or Just the segment if it does.
-}
validSegment :: Digest' SHA256d -> Crypttext -> Maybe Crypttext
validSegment :: Digest' SHA256d -> ByteString -> Maybe ByteString
validSegment Digest' SHA256d
expected ByteString
crypttext
    | ByteString -> Digest' SHA256d
forall hash. HashAlgorithm hash => ByteString -> Digest' hash
ciphertextSegmentHash' ByteString
crypttext Digest' SHA256d -> Digest' SHA256d -> Bool
forall a. Eq a => a -> a -> Bool
== Digest' SHA256d
expected = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
crypttext
    | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing

-- | Apply @validSegment@ to lists of values.
validSegments :: [Digest' SHA256d] -> [Crypttext] -> [Maybe Crypttext]
validSegments :: [Digest' SHA256d] -> [ByteString] -> [Maybe ByteString]
validSegments = (Digest' SHA256d -> ByteString -> Maybe ByteString)
-> [Digest' SHA256d] -> [ByteString] -> [Maybe ByteString]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Digest' SHA256d -> ByteString -> Maybe ByteString
validSegment