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

{-# LANGUAGE CPP, DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

-- TODO switch to cryptonite

module Darcs.Util.Hash
    ( Hash(..)
    , encodeBase16, decodeBase16, sha256, sha256sum, rawHash
    , match
    -- SHA1 related (patch metadata hash)
    , sha1PS, SHA1, showAsHex, sha1Xor, sha1zero, sha1short
 ) where

import qualified Crypto.Hash.SHA256 as SHA256 ( hashlazy, hash )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Internal as BI ( toForeignPtr )

import qualified Codec.Binary.Base16 as B16

import Data.Maybe( isJust, fromJust )
import Data.Char( toLower, toUpper, intToDigit )

import Data.Binary ( Binary(..) )
import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR)
import Data.Word (Word8, Word32)
import Data.Data( Data )
import Data.Typeable( Typeable )
import Foreign.ForeignPtr ( withForeignPtr )
import Foreign.Ptr (Ptr, castPtr, plusPtr)
import Foreign.Marshal.Array (advancePtr)
import Foreign.Storable (peek, poke)
import System.IO.Unsafe (unsafePerformIO)


data Hash = SHA256 !B.ByteString
          | NoHash
            deriving (Show, Eq, Ord, Read, Typeable, Data)

base16 :: B.ByteString -> B.ByteString
debase16 :: B.ByteString -> Maybe B.ByteString

base16 = BC.map toLower . B16.b16Enc
debase16 bs = case B16.b16Dec $ BC.map toUpper bs of
                Right (s, _) -> Just s
                Left _ -> Nothing

-- | 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 (SHA256 bs) = base16 bs
encodeBase16 NoHash = 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 bs | B.length bs == 64 && isJust (debase16 bs) = SHA256 (fromJust $ debase16 bs)
                | otherwise = NoHash

-- | Compute a sha256 of a (lazy) ByteString.
sha256 :: BL.ByteString -> Hash
sha256 bits = SHA256 $ SHA256.hashlazy bits

-- | Same as previous but general purpose.
sha256sum :: B.ByteString -> String
sha256sum = BC.unpack . base16 . SHA256.hash

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

match :: Hash -> Hash -> Bool
NoHash `match` _ = False
_ `match` NoHash = False
x `match` y = x == y

data SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32
  deriving (Eq,Ord)
data XYZ = XYZ !Word32 !Word32 !Word32

instance Show SHA1 where
 show (SHA1 a b c d e) = concatMap showAsHex [a, b, c, d, e]

instance Binary SHA1 where
  put (SHA1 a b c d e) = put a >> put b >> put c >> put d >> put e
  get = do a <- get ; b <- get ; c <- get ; d <- get ; e <- get ; return (SHA1 a b c d e)

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

sha1zero :: SHA1
sha1zero = SHA1 0 0 0 0 0

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

-- | Do something with the internals of a PackedString. Beware of
-- altering the contents!
unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
unsafeWithInternals ps f
 = case BI.toForeignPtr ps of
   (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l

sha1PS:: B.ByteString -> SHA1
sha1PS s = abcde'
 where s1_2 = sha1Step12PadLength s
       abcde = sha1Step3Init
       abcde' = unsafePerformIO
              $ unsafeWithInternals s1_2 (\ptr len ->
                    do let ptr' = castPtr ptr
#ifndef BIGENDIAN
                       fiddleEndianness ptr' len
#endif
                       sha1Step4Main abcde ptr' len)

fiddleEndianness :: Ptr Word32 -> Int -> IO ()
fiddleEndianness p 0 = p `seq` return ()
fiddleEndianness p n
 = do x <- peek p
      poke p $ shiftL x 24
           .|. shiftL (x .&. 0xff00) 8
           .|. (shiftR x 8 .&. 0xff00)
           .|. shiftR x 24
      fiddleEndianness (p `advancePtr` 1) (n - 4)

-- sha1Step12PadLength assumes the length is at most 2^61.
-- This seems reasonable as the Int used to represent it is normally 32bit,
-- but obviously could go wrong with large inputs on 64bit machines.
-- The B.ByteString library should probably move to Word64s if this is an
-- issue, though.

sha1Step12PadLength :: B.ByteString -> B.ByteString
sha1Step12PadLength s
 = let len = B.length s
       num_nuls = (55 - len) `mod` 64
       padding = 128:replicate num_nuls 0
       len_w8s = reverse $ sizeSplit 8 (fromIntegral len*8)
   in B.concat [s, B.pack padding, B.pack len_w8s]

sizeSplit :: Int -> Integer -> [Word8]
sizeSplit 0 _ = []
sizeSplit p n = fromIntegral d:sizeSplit (p-1) n'
 where (n', d) = divMod n 256

sha1Step3Init :: SHA1
sha1Step3Init = SHA1 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0

sha1Step4Main :: SHA1 -> Ptr Word32 -> Int -> IO SHA1
sha1Step4Main abcde _ 0 = return $! abcde
sha1Step4Main (SHA1 a0@a b0@b c0@c d0@d e0@e) s len
    = do
         (e, b) <- doit f1 0x5a827999 (x 0) a b c d e
         (d, a) <- doit f1 0x5a827999 (x 1) e a b c d
         (c, e) <- doit f1 0x5a827999 (x 2) d e a b c
         (b, d) <- doit f1 0x5a827999 (x 3) c d e a b
         (a, c) <- doit f1 0x5a827999 (x 4) b c d e a
         (e, b) <- doit f1 0x5a827999 (x 5) a b c d e
         (d, a) <- doit f1 0x5a827999 (x 6) e a b c d
         (c, e) <- doit f1 0x5a827999 (x 7) d e a b c
         (b, d) <- doit f1 0x5a827999 (x 8) c d e a b
         (a, c) <- doit f1 0x5a827999 (x 9) b c d e a
         (e, b) <- doit f1 0x5a827999 (x 10) a b c d e
         (d, a) <- doit f1 0x5a827999 (x 11) e a b c d
         (c, e) <- doit f1 0x5a827999 (x 12) d e a b c
         (b, d) <- doit f1 0x5a827999 (x 13) c d e a b
         (a, c) <- doit f1 0x5a827999 (x 14) b c d e a
         (e, b) <- doit f1 0x5a827999 (x 15) a b c d e
         (d, a) <- doit f1 0x5a827999 (m 16) e a b c d
         (c, e) <- doit f1 0x5a827999 (m 17) d e a b c
         (b, d) <- doit f1 0x5a827999 (m 18) c d e a b
         (a, c) <- doit f1 0x5a827999 (m 19) b c d e a
         (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e
         (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d
         (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c
         (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b
         (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a
         (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e
         (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d
         (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c
         (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b
         (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a
         (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e
         (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d
         (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c
         (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b
         (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a
         (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e
         (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d
         (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c
         (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b
         (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a
         (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e
         (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d
         (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c
         (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b
         (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a
         (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e
         (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d
         (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c
         (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b
         (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a
         (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e
         (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d
         (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c
         (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b
         (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a
         (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e
         (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d
         (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c
         (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b
         (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a
         (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e
         (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d
         (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c
         (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b
         (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a
         (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e
         (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d
         (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c
         (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b
         (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a
         (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e
         (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d
         (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c
         (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b
         (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a
         (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e
         (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d
         (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c
         (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b
         (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a
         let abcde' = SHA1 (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e)
         sha1Step4Main abcde' (s `advancePtr` 16) (len - 64)
 where {-# INLINE f1 #-}
       f1 (XYZ x y z) = (x .&. y) .|. (complement x .&. z)
       {-# INLINE f2 #-}
       f2 (XYZ x y z) = x `xor` y `xor` z
       {-# INLINE f3 #-}
       f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)
       {-# INLINE x #-}
       x n = peek (s `advancePtr` n)
       {-# INLINE m #-}
       m n = do let base = s `advancePtr` (n .&. 15)
                x0 <- peek base
                x1 <- peek (s `advancePtr` ((n - 14) .&. 15))
                x2 <- peek (s `advancePtr` ((n - 8) .&. 15))
                x3 <- peek (s `advancePtr` ((n - 3) .&. 15))
                let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1
                poke base res
                return res
       {-# INLINE doit #-}
       doit f k i a b c d e = a `seq` c `seq`
           do i' <- i
              return (rotateL a 5 + f (XYZ b c d) + e + i' + k,
                      rotateL b 30)

showAsHex :: Word32 -> String
showAsHex n = showIt 8 n ""
   where
    showIt :: Int -> Word32 -> String -> String
    showIt 0 _ r = r
    showIt i x r = case quotRem x 16 of
                       (y, z) -> let c = intToDigit (fromIntegral z)
                                 in c `seq` showIt (i-1) y (c:r)