--  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
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
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
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
Ord, ReadPrec [Hash]
ReadPrec Hash
Int -> ReadS Hash
ReadS [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 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 (forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 forall a. Eq a => a -> a -> Bool
== Hash
y

data SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32
  deriving (SHA1 -> SHA1 -> Bool
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
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
Ord)

instance Show SHA1 where
  show :: SHA1 -> String
show = ByteString -> String
BC.unpack 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) = forall t. Binary t => t -> Put
put Word32
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Word32
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Word32
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Word32
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Word32
e
  get :: Get SHA1
get = do Word32
a <- forall t. Binary t => Get t
get; Word32
b <- forall t. Binary t => Get t
get; Word32
c <- forall t. Binary t => Get t
get; Word32
d <- forall t. Binary t => Get t
get; Word32
e <- forall t. Binary t => Get t
get; 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 forall a. Bits a => a -> a -> a
`xor` Word32
a2) (Word32
b1 forall a. Bits a => a -> a -> a
`xor` Word32
b2) (Word32
c1 forall a. Bits a => a -> a -> a
`xor` Word32
c2) (Word32
d1 forall a. Bits a => a -> a -> a
`xor` Word32
d2) (Word32
e1 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
H.hashWith SHA1
H.SHA1 where
  fromArray :: ByteString -> SHA1
fromArray = forall a. Binary a => ByteString -> a
decode 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 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
z)
                                 in Char
c seq :: forall a b. a -> b -> b
`seq` Int -> Word32 -> ShowS
showIt (Int
iforall a. Num a => a -> a -> a
-Int
1) Word32
y (Char
cforall 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 forall a. Eq a => a -> a -> Bool
== Int
40
  , (Word8 -> Bool) -> ByteString -> Bool
B.all Word8 -> Bool
is_hex ByteString
bs =
    forall a. a -> Maybe a
Just 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 = forall a. Maybe a
Nothing
  where
    readWord :: Int -> Word32
readWord Int
i = 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 forall a. Bits a => a -> Int -> a
`shiftL` Int
4 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
b forall a. Num a => a -> a -> a
- Word8
ord_0)
              | Word8 -> Bool
btw_a_f Word8
b = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
b forall a. Num a => a -> a -> a
- Word8
ord_a) forall a. Num a => a -> a -> a
+ Word32
10
              | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"impossible case"
    ord_0 :: Word8
    ord_0 :: Word8
ord_0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'0')
    ord_9 :: Word8
    ord_9 :: Word8
ord_9 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'9')
    ord_a :: Word8
    ord_a :: Word8
ord_a = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'a')
    ord_f :: Word8
    ord_f :: Word8
ord_f = 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 forall a. Ord a => a -> a -> Bool
>= Word8
ord_0 Bool -> Bool -> Bool
&& Word8
b forall a. Ord a => a -> a -> Bool
<= Word8
ord_9
    btw_a_f :: Word8 -> Bool
btw_a_f Word8
b = Word8
b forall a. Ord a => a -> a -> Bool
>= Word8
ord_a Bool -> Bool -> Bool
&& Word8
b 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => a -> ByteString
encode