module Crypto.Multihash
(
MultihashDigest
, Base (..)
, Codable (..)
, encode
, encode'
, multihash
, multihashlazy
, checkMultihash
, HashAlgorithm
, SHA1(..)
, SHA256(..)
, SHA512(..)
, SHA3_512(..)
, SHA3_384(..)
, SHA3_256(..)
, SHA3_224(..)
, Blake2b_512(..)
, Blake2s_256(..)
) where
import Crypto.Hash (Digest, hash, hashlazy)
import Crypto.Hash.Algorithms
import Data.ByteArray (ByteArrayAccess, Bytes)
import qualified Data.ByteArray as BA
import qualified Data.ByteArray.Encoding as BE
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base58 as B58
import Data.List (elemIndex)
import Data.Word (Word8)
import Text.Printf (printf)
data Base = Base2
| Base16
| Base32
| Base58
| Base64
deriving (Show, Eq)
data MultihashDigest a = MultihashDigest
{ getAlgorithm :: a
, getLength :: Int
, getDigest :: Digest a
} deriving (Eq)
class Codable a where
toCode :: a -> Int
instance Codable SHA1 where
toCode SHA1 = 0x11
instance Codable SHA256 where
toCode SHA256 = 0x12
instance Codable SHA512 where
toCode SHA512 = 0x13
instance Codable SHA3_512 where
toCode SHA3_512 = 0x14
instance Codable SHA3_384 where
toCode SHA3_384 = 0x15
instance Codable SHA3_256 where
toCode SHA3_256 = 0x16
instance Codable SHA3_224 where
toCode SHA3_224 = 0x17
instance Codable Blake2b_512 where
toCode Blake2b_512 = 0x40
instance Codable Blake2s_256 where
toCode Blake2s_256 = 0x41
instance Show (MultihashDigest a) where
show (MultihashDigest _ _ d) = show d
multihashlazy :: (HashAlgorithm a, Codable a) => a -> BL.ByteString -> MultihashDigest a
multihashlazy alg bs = let digest = hashlazy bs
in MultihashDigest alg (BA.length digest) digest
multihash :: (HashAlgorithm a, Codable a, ByteArrayAccess bs) => a -> bs -> MultihashDigest a
multihash alg bs = let digest = hash bs
in MultihashDigest alg (BA.length digest) digest
encode :: (HashAlgorithm a, Codable a, Show a) => Base -> MultihashDigest a -> Either String String
encode base (MultihashDigest alg len md) = if len == len'
then do
d <- fullDigestUnpacked
return $ map (toEnum . fromIntegral) d
else Left $ printf "Corrupted %s MultihashDigest. Lenght is %d but should be %d." (show alg) len len'
where
len' :: Int
len' = BA.length md
fullDigestUnpacked :: Either String [Word8]
fullDigestUnpacked = do
d <- encoder fullDigest
return $ BA.unpack d
where
encoder :: ByteArrayAccess a => a -> Either String Bytes
encoder bs = case base of
Base2 -> return $ BA.convert bs
Base16 -> return $ BE.convertToBase BE.Base16 bs
Base32 -> Left "Base32 encoder not implemented"
Base58 -> return $ BA.convert $ B58.encodeBase58 B58.bitcoinAlphabet
(BA.convert bs :: BS.ByteString)
Base64 -> return $ BE.convertToBase BE.Base64 bs
fullDigest :: Bytes
fullDigest = BA.pack [dHead, dSize] `BA.append` dTail
where
dHead :: Word8
dHead = fromIntegral $ toCode alg
dSize :: Word8
dSize = fromIntegral len'
dTail :: Bytes
dTail = BA.convert md
encode' :: (HashAlgorithm a, Codable a, Show a) => Base -> MultihashDigest a -> String
encode' base md =
case encode base md of
Right enc -> enc
Left err -> error err
checkMultihash :: ByteArrayAccess bs => BS.ByteString -> bs -> Either String Bool
checkMultihash hash unahshedData = do
base <- getBase hash
mhd <- convertFromBase base hash
m <- getBinaryEncodedMultihash mhd unahshedData
return (C.pack m == mhd)
maybeToEither :: l -> Maybe r -> Either l r
maybeToEither _ (Just res) = Right res
maybeToEither err _ = Left err
convertFromBase :: Base -> BS.ByteString -> Either String BS.ByteString
convertFromBase b bs = case b of
Base2 -> Left "This is not supposed to happen"
Base16 -> BE.convertFromBase BE.Base16 bs
Base32 -> Left "Base32 decoder not implemented"
Base58 -> do
dec <- maybeToEither "Base58 decoding error" (B58.decodeBase58 B58.bitcoinAlphabet bs)
return (BA.convert dec)
Base64 -> BE.convertFromBase BE.Base64 bs
getBase :: BS.ByteString -> Either String Base
getBase h
| startWiths h ["1114", "1220", "1340", "1440", "1530", "1620", "171c", "4040", "4120"] = Right Base16
| startWiths h ["5d", "Qm", "8V", "8t", "G9", "W1", "5d", "S2", "2U"] = Right Base58
| startWiths h ["ER", "Ei", "E0", "FE", "FT", "Fi", "Fx", "QE", "QS"] = Right Base64
| otherwise = Left "Unable to infer an encoding"
where startWiths h = any (`BS.isPrefixOf` h)
getBinaryEncodedMultihash :: ByteArrayAccess bs => BS.ByteString -> bs -> Either String String
getBinaryEncodedMultihash mhd uh = let bitOne = head $ BS.unpack mhd in
case elemIndex bitOne hashCodes of
Just 0 -> rs SHA1 uh
Just 1 -> rs SHA256 uh
Just 2 -> rs SHA512 uh
Just 3 -> rs SHA3_512 uh
Just 4 -> rs SHA3_384 uh
Just 5 -> rs SHA3_256 uh
Just 6 -> rs SHA3_224 uh
Just 7 -> rs Blake2b_512 uh
Just 8 -> rs Blake2s_256 uh
Just _ -> Left "This should be impossible"
Nothing -> Left "Impossible to infer the appropriate hash from the header"
where
rs alg = encode Base2 . multihash alg
hashCodes :: [Word8]
hashCodes = map fromIntegral
([0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x40, 0x41]::[Int])