--  Copyright (C) 2009-2011 Petr Rockai BSD3
--  Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li>

{-# LANGUAGE CPP #-}
module Darcs.Util.Hash
    ( Hash(..)
    , encodeBase16, decodeBase16, sha256, sha256sum, rawHash
    , match
    -- SHA1 related (patch metadata hash)
    , sha1PS, SHA1(..), showAsHex, sha1Xor, sha1zero, sha1short
    , sha1Show, sha1Read
 ) where

-- we currently have to depend on the memory package in addition to cryptonite
-- just so that we can import this single function
import Data.ByteArray ( convert )

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Base16 as B16

import qualified Crypto.Hash as H

import Data.Char( intToDigit, ord )

import Data.Binary ( Binary(..), decode, encode )
import Data.Bits ( xor, shiftL, (.|.) )
import Data.Word ( Word8, Word32 )

import Darcs.Prelude


data Hash = SHA256 !B.ByteString
          | NoHash
            deriving (Int -> Hash -> ShowS
[Hash] -> ShowS
Hash -> String
(Int -> Hash -> ShowS)
-> (Hash -> String) -> ([Hash] -> ShowS) -> Show Hash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Hash] -> ShowS
$cshowList :: [Hash] -> ShowS
show :: Hash -> String
$cshow :: Hash -> String
showsPrec :: Int -> Hash -> ShowS
$cshowsPrec :: Int -> Hash -> ShowS
Show, Hash -> Hash -> Bool
(Hash -> Hash -> Bool) -> (Hash -> Hash -> Bool) -> Eq Hash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hash -> Hash -> Bool
$c/= :: Hash -> Hash -> Bool
== :: Hash -> Hash -> Bool
$c== :: Hash -> Hash -> Bool
Eq, Eq Hash
Eq Hash
-> (Hash -> Hash -> Ordering)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Hash)
-> (Hash -> Hash -> Hash)
-> Ord Hash
Hash -> Hash -> Bool
Hash -> Hash -> Ordering
Hash -> Hash -> Hash
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
min :: Hash -> Hash -> Hash
$cmin :: Hash -> Hash -> Hash
max :: Hash -> Hash -> Hash
$cmax :: Hash -> Hash -> Hash
>= :: Hash -> Hash -> Bool
$c>= :: Hash -> Hash -> Bool
> :: Hash -> Hash -> Bool
$c> :: Hash -> Hash -> Bool
<= :: Hash -> Hash -> Bool
$c<= :: Hash -> Hash -> Bool
< :: Hash -> Hash -> Bool
$c< :: Hash -> Hash -> Bool
compare :: Hash -> Hash -> Ordering
$ccompare :: Hash -> Hash -> Ordering
$cp1Ord :: Eq Hash
Ord, ReadPrec [Hash]
ReadPrec Hash
Int -> ReadS Hash
ReadS [Hash]
(Int -> ReadS Hash)
-> ReadS [Hash] -> ReadPrec Hash -> ReadPrec [Hash] -> Read Hash
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Hash]
$creadListPrec :: ReadPrec [Hash]
readPrec :: ReadPrec Hash
$creadPrec :: ReadPrec Hash
readList :: ReadS [Hash]
$creadList :: ReadS [Hash]
readsPrec :: Int -> ReadS Hash
$creadsPrec :: Int -> ReadS Hash
Read)

-- | Produce a base16 (ascii-hex) encoded string from a hash. This can be
-- turned back into a Hash (see "decodeBase16". This is a loss-less process.
encodeBase16 :: Hash -> B.ByteString
encodeBase16 :: Hash -> ByteString
encodeBase16 (SHA256 ByteString
bs) = ByteString -> ByteString
B16.encode ByteString
bs
encodeBase16 Hash
NoHash = ByteString
B.empty

-- | Take a base16-encoded string and decode it as a "Hash". If the string is
-- malformed, yields NoHash.
decodeBase16 :: B.ByteString -> Hash
decodeBase16 :: ByteString -> Hash
decodeBase16 ByteString
bs
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
64
#if MIN_VERSION_base16_bytestring(1,0,0)
  , Right ByteString
dbs <- ByteString -> Either String ByteString
B16.decode ByteString
bs = ByteString -> Hash
SHA256 ByteString
dbs
#else
  , (dbs, rest) <- B16.decode bs, B.null rest = SHA256 dbs
#endif
  | Bool
otherwise = Hash
NoHash

-- | Compute a sha256 of a (lazy) ByteString.
sha256 :: BL.ByteString -> Hash
sha256 :: ByteString -> Hash
sha256 ByteString
bits = ByteString -> Hash
SHA256 (Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (ByteString -> Digest SHA256
forall a. HashAlgorithm a => ByteString -> Digest a
H.hashlazy ByteString
bits :: H.Digest H.SHA256))

-- | Same as previous but general purpose.
sha256sum :: B.ByteString -> String
sha256sum :: ByteString -> String
sha256sum = ByteString -> String
BC.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Digest SHA256 -> ByteString)
-> (ByteString -> Digest SHA256) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA256 -> ByteString -> Digest SHA256
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
H.hashWith SHA256
H.SHA256

rawHash :: Hash -> B.ByteString
rawHash :: Hash -> ByteString
rawHash Hash
NoHash = String -> ByteString
forall a. HasCallStack => String -> a
error String
"Cannot obtain raw hash from NoHash."
rawHash (SHA256 ByteString
s) = ByteString
s

match :: Hash -> Hash -> Bool
Hash
NoHash match :: Hash -> Hash -> Bool
`match` Hash
_ = Bool
False
Hash
_ `match` Hash
NoHash = Bool
False
Hash
x `match` Hash
y = Hash
x Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
y

data SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32
  deriving (SHA1 -> SHA1 -> Bool
(SHA1 -> SHA1 -> Bool) -> (SHA1 -> SHA1 -> Bool) -> Eq SHA1
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SHA1 -> SHA1 -> Bool
$c/= :: SHA1 -> SHA1 -> Bool
== :: SHA1 -> SHA1 -> Bool
$c== :: SHA1 -> SHA1 -> Bool
Eq,Eq SHA1
Eq SHA1
-> (SHA1 -> SHA1 -> Ordering)
-> (SHA1 -> SHA1 -> Bool)
-> (SHA1 -> SHA1 -> Bool)
-> (SHA1 -> SHA1 -> Bool)
-> (SHA1 -> SHA1 -> Bool)
-> (SHA1 -> SHA1 -> SHA1)
-> (SHA1 -> SHA1 -> SHA1)
-> Ord SHA1
SHA1 -> SHA1 -> Bool
SHA1 -> SHA1 -> Ordering
SHA1 -> SHA1 -> SHA1
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
min :: SHA1 -> SHA1 -> SHA1
$cmin :: SHA1 -> SHA1 -> SHA1
max :: SHA1 -> SHA1 -> SHA1
$cmax :: SHA1 -> SHA1 -> SHA1
>= :: SHA1 -> SHA1 -> Bool
$c>= :: SHA1 -> SHA1 -> Bool
> :: SHA1 -> SHA1 -> Bool
$c> :: SHA1 -> SHA1 -> Bool
<= :: SHA1 -> SHA1 -> Bool
$c<= :: SHA1 -> SHA1 -> Bool
< :: SHA1 -> SHA1 -> Bool
$c< :: SHA1 -> SHA1 -> Bool
compare :: SHA1 -> SHA1 -> Ordering
$ccompare :: SHA1 -> SHA1 -> Ordering
$cp1Ord :: Eq SHA1
Ord)

instance Show SHA1 where
  show :: SHA1 -> String
show = ByteString -> String
BC.unpack (ByteString -> String) -> (SHA1 -> ByteString) -> SHA1 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA1 -> ByteString
sha1Show

instance Binary SHA1 where
  put :: SHA1 -> Put
put (SHA1 Word32
a Word32
b Word32
c Word32
d Word32
e) = Word32 -> Put
forall t. Binary t => t -> Put
put Word32
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
forall t. Binary t => t -> Put
put Word32
b Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
forall t. Binary t => t -> Put
put Word32
c Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
forall t. Binary t => t -> Put
put Word32
d Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
forall t. Binary t => t -> Put
put Word32
e
  get :: Get SHA1
get = do Word32
a <- Get Word32
forall t. Binary t => Get t
get; Word32
b <- Get Word32
forall t. Binary t => Get t
get; Word32
c <- Get Word32
forall t. Binary t => Get t
get; Word32
d <- Get Word32
forall t. Binary t => Get t
get; Word32
e <- Get Word32
forall t. Binary t => Get t
get; SHA1 -> Get SHA1
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> SHA1
SHA1 Word32
a Word32
b Word32
c Word32
d Word32
e)

sha1Xor :: SHA1 -> SHA1 -> SHA1
sha1Xor :: SHA1 -> SHA1 -> SHA1
sha1Xor (SHA1 Word32
a1 Word32
b1 Word32
c1 Word32
d1 Word32
e1) (SHA1 Word32
a2 Word32
b2 Word32
c2 Word32
d2 Word32
e2) =
  Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> SHA1
SHA1 (Word32
a1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
a2) (Word32
b1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
b2) (Word32
c1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
c2) (Word32
d1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
d2) (Word32
e1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
e2)

sha1zero :: SHA1
sha1zero :: SHA1
sha1zero = Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> SHA1
SHA1 Word32
0 Word32
0 Word32
0 Word32
0 Word32
0

sha1short :: SHA1 -> Word32
sha1short :: SHA1 -> Word32
sha1short (SHA1 Word32
a Word32
_ Word32
_ Word32
_ Word32
_) = Word32
a

sha1PS:: B.ByteString -> SHA1
sha1PS :: ByteString -> SHA1
sha1PS = ByteString -> SHA1
fromArray (ByteString -> SHA1)
-> (ByteString -> ByteString) -> ByteString -> SHA1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Digest SHA1 -> ByteString)
-> (ByteString -> Digest SHA1) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA1 -> ByteString -> Digest SHA1
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
H.hashWith SHA1
H.SHA1 where
  fromArray :: ByteString -> SHA1
fromArray = ByteString -> SHA1
forall a. Binary a => ByteString -> a
decode (ByteString -> SHA1)
-> (ByteString -> ByteString) -> ByteString -> SHA1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict

showAsHex :: Word32 -> String
showAsHex :: Word32 -> String
showAsHex Word32
n = Int -> Word32 -> ShowS
showIt Int
8 Word32
n String
""
   where
    showIt :: Int -> Word32 -> String -> String
    showIt :: Int -> Word32 -> ShowS
showIt Int
0 Word32
_ String
r = String
r
    showIt Int
i Word32
x String
r = case Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
quotRem Word32
x Word32
16 of
                       (Word32
y, Word32
z) -> let c :: Char
c = Int -> Char
intToDigit (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
z)
                                 in Char
c Char -> ShowS
`seq` Int -> Word32 -> ShowS
showIt (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Word32
y (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
r)

-- | Parse a 'SHA1' directly from its B16 encoding, given as a 'B.ByteString',
-- or return 'Nothing'. The implementation is quite low-level and optimized
-- because the current implementation of RepoPatchV3 has to read lots of 'SHA1'
-- hashes, and profiling showed that this is a bottleneck.
sha1Read :: B.ByteString -> Maybe SHA1
sha1Read :: ByteString -> Maybe SHA1
sha1Read ByteString
bs
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
40
  , (Word8 -> Bool) -> ByteString -> Bool
B.all Word8 -> Bool
is_hex ByteString
bs =
    SHA1 -> Maybe SHA1
forall a. a -> Maybe a
Just (SHA1 -> Maybe SHA1) -> SHA1 -> Maybe SHA1
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> SHA1
SHA1 (Int -> Word32
readWord Int
0) (Int -> Word32
readWord Int
8) (Int -> Word32
readWord Int
16) (Int -> Word32
readWord Int
24) (Int -> Word32
readWord Int
32)
  | Bool
otherwise = Maybe SHA1
forall a. Maybe a
Nothing
  where
    readWord :: Int -> Word32
readWord Int
i = (Word32 -> Word8 -> Word32) -> Word32 -> ByteString -> Word32
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' Word32 -> Word8 -> Word32
readByte Word32
0 (Int -> ByteString -> ByteString
B.take Int
8 (Int -> ByteString -> ByteString
B.drop Int
i ByteString
bs))
    readByte :: Word32 -> Word8 -> Word32
    readByte :: Word32 -> Word8 -> Word32
readByte Word32
r Word8
b = Word32
r Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
4 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word32
fromHex Word8
b)
    fromHex :: Word8 -> Word32
    fromHex :: Word8 -> Word32
fromHex Word8
b | Word8 -> Bool
btw_0_9 Word8
b = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
b Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
ord_0)
              | Word8 -> Bool
btw_a_f Word8
b = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
b Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
ord_a) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
10
              | Bool
otherwise = String -> Word32
forall a. HasCallStack => String -> a
error String
"impossible case"
    ord_0 :: Word8
    ord_0 :: Word8
ord_0 = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'0')
    ord_9 :: Word8
    ord_9 :: Word8
ord_9 = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'9')
    ord_a :: Word8
    ord_a :: Word8
ord_a = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'a')
    ord_f :: Word8
    ord_f :: Word8
ord_f = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'f')
    btw_0_9 :: Word8 -> Bool
btw_0_9 Word8
b = Word8
b Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
ord_0 Bool -> Bool -> Bool
&& Word8
b Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
ord_9
    btw_a_f :: Word8 -> Bool
btw_a_f Word8
b = Word8
b Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
ord_a Bool -> Bool -> Bool
&& Word8
b Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
ord_f
    is_hex :: Word8 -> Bool
is_hex Word8
b = Word8 -> Bool
btw_0_9 Word8
b Bool -> Bool -> Bool
|| Word8 -> Bool
btw_a_f Word8
b

{-# INLINE sha1Show #-}
sha1Show :: SHA1 -> B.ByteString
sha1Show :: SHA1 -> ByteString
sha1Show = ByteString -> ByteString
B16.encode (ByteString -> ByteString)
-> (SHA1 -> ByteString) -> SHA1 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (SHA1 -> ByteString) -> SHA1 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA1 -> ByteString
forall a. Binary a => a -> ByteString
encode