{-# LANGUAGE OverloadedStrings #-} import Control.Monad (zipWithM, forM_) import Crypto.Multihash import Crypto.Multihash.Weak (weakMultihash, checkWeakMultihash, toWeakMultihash) import Data.ByteString (ByteString, pack, unpack) import Text.Printf (printf) import Test.Hspec import Test.QuickCheck -- TODO: -- * use QuickCheck to test Multihash serializatio/deserializatio/check properties -- especially now that we infer the decoding for arbitrary truncations -- * test for valid and invalid truncated multihashes instance Arbitrary ByteString where arbitrary = pack `fmap` arbitrary --coarbitrary = coarbitrary . unpack testString :: ByteString testString = "test" failTestString :: ByteString failTestString = "test1" weakAlgos = [ "sha1", "sha256", "sha512", "sha3-512" , "sha3-384", "sha3-256", "sha3-224" , "blake2b-512", "blake2s-256" ] -- Useful for testing, generated in Weak by -- tester = map (\(a,_) -> _getLength $ weakMultihash' a ("test"::ByteString)) allowedAlgos maxHashLengths = [20,32,64,64,48,32,28,64,32] main :: IO () main = runSpec prop_gen_check :: ByteString -> Property prop_gen_check str = let m = multihash SHA1 str enc :: ByteString enc = encode' Base16 m in check' enc m === True prop_get_base :: Base -> ByteString -> Property prop_get_base base str = let m = multihash SHA1 str enc :: ByteString enc = encode' base m in getBase enc === Right base runQC = quickCheck prop_gen_check runSpec = hspec $ do ------------------------------------------------------------------------ describe "Multihash: check properties with QuickCheck" $ do it "correctly encodes and checks SHA1" $ property prop_gen_check forM_ [Base16, Base32, Base58, Base64] $ \b -> it ("correctly infer" ++ show b ++ "encodings on full-length hashes") $ property (prop_get_base b) ------------------------------------------------------------------------ mhEncoding SHA1 h1 mhCheck mh checkMultihash SHA1 h1 mhEncoding SHA256 h2 mhCheck mh checkMultihash SHA256 h2 mhEncoding SHA512 h3 mhCheck mh checkMultihash SHA512 h3 mhEncoding SHA3_512 h4 mhCheck mh checkMultihash SHA3_512 h4 mhEncoding SHA3_384 h5 mhCheck mh checkMultihash SHA3_384 h5 mhEncoding SHA3_256 h6 mhCheck mh checkMultihash SHA3_256 h6 mhEncoding SHA3_224 h7 mhCheck mh checkMultihash SHA3_224 h7 mhEncoding Blake2b_512 h8 mhCheck mh checkMultihash Blake2b_512 h8 mhEncoding Blake2s_256 h9 mhCheck mh checkMultihash Blake2s_256 h9 ------------------------------------------------------------------------ traverse (uncurry wmhEncoding) (zip weakAlgos h) traverse (uncurry (mhCheck wmh checkWeakMultihash)) (zip weakAlgos h) ------------------------------------------------------------------------ describe "Multihash: fails correctly when" $ do it "checking an invalid truncated multihash" $ checkMultihash ("1340ee26b0dd4af7e749aa1a8e"::ByteString) testString `shouldBe` Left "Corrupted MultihasDigest: invalid length" it "checking an invalid truncated multihash" $ checkMultihash ("dd4af7e749aa1a8e1340ee26b0"::ByteString) testString `shouldBe` Left "Corrupted MultihasDigest: invalid length" describe "Weak Multihash: fails correctly when" $ do it "checking an invalid truncated multihash" $ checkWeakMultihash ("1340ee26b0dd4af7e749aa1a8e"::ByteString) testString `shouldBe` Left "Corrupted MultihasDigest: invalid length" it "checking an invalid truncated multihash" $ checkWeakMultihash ("dd4af7e749aa1a8e1340ee26b0"::ByteString) testString `shouldBe` Left "Corrupted MultihasDigest: invalid length" ------------------------------------------------------------------------ where mh = "Multihash"::String wmh = "Weak Multihash"::String mhEncoding :: (HashAlgorithm a, Codable a, Show a) => a -> (ByteString, ByteString, ByteString, ByteString) -> SpecWith () mhEncoding alg (sm16, sm32, sm58, sm64) = let m = multihash alg testString in describe (printf "Multihash: encoding %s multihash" (show alg)) $ do it "returns the correct Base16 hash" $ encode' Base16 m `shouldBe` sm16 it "returns the correct Base32 hash" $ encode' Base32 m `shouldBe` sm32 it "returns the correct Base58 hash" $ encode' Base58 m `shouldBe` sm58 it "returns the correct Base64 hash" $ encode' Base64 m `shouldBe` sm64 wmhEncoding :: ByteString -> (ByteString, ByteString, ByteString, ByteString) -> SpecWith () wmhEncoding alg (sm16, sm32, sm58, sm64) = let m = case weakMultihash alg testString of Right val -> val Left err -> error err in do describe (printf "Weak Multihash: encoding %s multihash" (show alg)) $ do it "returns the correct Base16 hash" $ encode' Base16 m `shouldBe` sm16 it "returns the correct Base32 hash" $ encode' Base32 m `shouldBe` sm32 it "returns the correct Base58 hash" $ encode' Base58 m `shouldBe` sm58 it "returns the correct Base64 hash" $ encode' Base64 m `shouldBe` sm64 describe (printf "Weak Multihash: decoding %s multihash" (show alg)) $ do it "imports the correct hash from Base16" $ toWeakMultihash sm16 `shouldBe` Right m it "imports the correct hash from Base32" $ toWeakMultihash sm32 `shouldBe` Right m it "imports the correct hash from Base58" $ toWeakMultihash sm58 `shouldBe` Right m it "imports the correct hash from Base64" $ toWeakMultihash sm64 `shouldBe` Right m -- hashChecker :: (HashAlgorithm a, Codable a, Show a) => a -- -> (ByteString, ByteString, ByteString, ByteString) -> SpecWith () mhCheck t checker alg (e16, e32, e58, e64) = describe (printf "%s: using checkPayload on %s hashes" t (show alg)) $ do it "checks correctly Base16 hashes" $ checker e16 testString `shouldBe` Right True it "fails correctly on Base16 hashes" $ checker e16 failTestString `shouldBe` Right False it "checks correctly Base32 hashes" $ checker e32 testString `shouldBe` Right True it "fails correctly on Base32 hashes" $ checker e32 failTestString `shouldBe` Right False it "checks correctly Base58 hashes" $ checker e58 testString `shouldBe` Right True it "fails correctly on Base58 hashes" $ checker e58 failTestString `shouldBe` Right False it "checks correctly Base64 hashes" $ checker e64 testString `shouldBe` Right True it "fails correctly on Base64 hashes" $ checker e64 failTestString `shouldBe` Right False -- array of triples of hashes of the string "test" h@[h1, h2, h3, h4, h5, h6, h7, h8, h9] = [ ( "1114a94a8fe5ccb19ba61c4c0873d391e987982fbbd3" , "CEKKSSUP4XGLDG5GDRGAQ46TSHUYPGBPXPJQ====" , "5dt9CqvXK9qs7vazf7k7ZRqe28VPTg" , "ERSpSo/lzLGbphxMCHPTkemHmC+70w==") , ( "12209f86d081884c7d659a2feaa0c55ad015a3bf4f1b2b0b822cd15d6c15b0f00a08" , "CIQJ7BWQQGEEY7LFTIX6VIGFLLIBLI57J4NSWC4CFTIV23AVWDYAUCA=" , "QmZ5NmGeStdit7tV6gdak1F8FyZhPsfA843YS9f2ywKH6w" , "EiCfhtCBiEx9ZZov6qDFWtAVo79PGysLgizRXWwVsPAKCA==") , ( "1340ee26b0dd4af7e749aa1a8ee3c10ae9923f618980772e473f8819a5d4940e0db27ac185f8a0e1d5f84f88bc887fd67b143732c304cc5fa9ad8e6f57f50028a8ff" , "CNAO4JVQ3VFPPZ2JVINI5Y6BBLUZEP3BRGAHOLSHH6EBTJOUSQHA3MT2YGC7RIHB2X4E7CF4RB75M6YUG4ZMGBGML6U23DTPK72QAKFI74======" , "8VxYhLL7s5BvLogtUGgNJ7DebZ5Ba9mG3izfc7v6o4RZ28x469vJaifa3TQ13Z9DycmAuJWnp7ErkZofm4rsMo78fQ" , "E0DuJrDdSvfnSaoajuPBCumSP2GJgHcuRz+IGaXUlA4NsnrBhfig4dX4T4i8iH/WexQ3MsMEzF+prY5vV/UAKKj/") , ( "14409ece086e9bac491fac5c1d1046ca11d737b92a2b2ebd93f005d7b710110c0a678288166e7fbe796883a4f2e9b3ca9f484f521d0ce464345cc1aec96779149c14" , "CRAJ5TQIN2N2YSI7VROB2ECGZII5ON5ZFIVS5PMT6AC5PNYQCEGAUZ4CRALG4756PFUIHJHS5GZ4VH2IJ5JB2DHEMQ2FZQNOZFTXSFE4CQ======" , "8tXEcJyq2MCx27UHYbZxmte37ezBawV35QhfKPtq5QeSnX66q4DDf1cwMYUh2pUVbxdQgrDaSjbrPrfNxzvSSLQAtT" , "FECezghum6xJH6xcHRBGyhHXN7kqKy69k/AF17cQEQwKZ4KIFm5/vnlog6Ty6bPKn0hPUh0M5GQ0XMGuyWd5FJwU") , ( "1530e516dabb23b6e30026863543282780a3ae0dccf05551cf0295178d7ff0f1b41eecb9db3ff219007c4e097260d58621bd" , "CUYOKFW2XMR3NYYAE2DDKQZIE6AKHLQNZTYFKUOPAKKRPDL76DY3IHXMXHNT74QZAB6E4CLSMDKYMIN5" , "G9LerVN7c3uUAAymoAGkCGZPn53PZi1SHwPJ2nznLp82jcM2M1KLwpfrZh3F1QRVG3f2" , "FTDlFtq7I7bjACaGNUMoJ4Cjrg3M8FVRzwKVF41/8PG0Huy52z/yGQB8TglyYNWGIb0=") , ( "162036f028580bb02cc8272a9a020f4200e346e276ae664e45ee80745574e2f5ab80" , "CYQDN4BILAF3ALGIE4VJUAQPIIAOGRXCO2XGMTSF52AHIVLU4L22XAA=" , "W1d9SeHn1mCnY3jZMs5YeqfFbwEnq5gQy1VDymGoPK28RD" , "FiA28ChYC7AsyCcqmgIPQgDjRuJ2rmZORe6AdFV04vWrgA==") , ( "171c3797bf0afbbfca4a7bbba7602a2b552746876517a7f9b7ce2db0ae7b" , "C4ODPF57BL537SSKPO52OYBKFNKSORUHMUL2P6NXZYW3BLT3" , "5daZNVMeTfSuCvu7rBKsFkzEMebnuGjNpos1ThF1c" , "Fxw3l78K+7/KSnu7p2AqK1UnRodlF6f5t84tsK57") , ( "4040a71079d42853dea26e453004338670a53814b78137ffbed07603a41d76a483aa9bc33b582f77d30a65e6f29a896c0411f38312e1d66e0bf16386c86a89bea572" , "IBAKOEDZ2QUFHXVCNZCTABBTQZYKKOAUW6ATP7562B3AHJA5O2SIHKU3YM5VQL3X2MFGLZXSTKEWYBAR6OBRFYOWNYF7CY4GZBVITPVFOI======" , "S2XUqUDxz3MHMZtJpCZKt5oRjXHQ34gsyDBT759qNwoSP9rDBHVHxjQUQtXfExotxTqf4rMEXQkNmXE3N9mhoZX6wK" , "QECnEHnUKFPeom5FMAQzhnClOBS3gTf/vtB2A6QddqSDqpvDO1gvd9MKZebymolsBBHzgxLh1m4L8WOGyGqJvqVy") , ( "4120f308fc02ce9172ad02a7d75800ecfc027109bc67987ea32aba9b8dcc7b10150e" , "IEQPGCH4ALHJC4VNAKT5OWAA5T6AE4IJXRTZQ7VDFK5JXDOMPMIBKDQ=" , "2UPuEK7FVakwP3yUak5jKQhZb6pgpbcqYoRZ2tDzgeCfVr5" , "QSDzCPwCzpFyrQKn11gA7PwCcQm8Z5h+oyq6m43MexAVDg==") ]