{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Tahoe.CHK.SHA256d where

import Crypto.Hash (Context, Digest, HashAlgorithm, SHA256, digestFromByteString, hash)
import Crypto.Hash.IO (HashAlgorithm (..))
import qualified Data.ByteArray as BA
import Data.ByteString (packCStringLen, useAsCString)
import qualified Data.ByteString as B
import Data.ByteString.Base32 (decodeBase32Unpadded, encodeBase32Unpadded')
import qualified Data.ByteString.Char8 as C8
import Data.Char (toLower)
import Data.Coerce (coerce)
import Data.Data (Data)
import Data.Maybe (fromJust, fromMaybe)
import Data.Primitive (Ptr)
import Data.Primitive.Ptr (copyPtr)
import Data.String (IsString (..))
import Data.TreeDiff.Class (ToExpr (..))
import Foreign.C (CString)

{- | A newtype wrapper around Digest which comes with the string interpretation
 Tahoe-LAFS is accustomed to (lowercase base32 rather than lowercase base16),
 as well as a ToExpr instance for participation in nice diff computation.
-}
newtype Digest' a = Digest' (Digest a) deriving newtype (Digest' a -> Digest' a -> Bool
(Digest' a -> Digest' a -> Bool)
-> (Digest' a -> Digest' a -> Bool) -> Eq (Digest' a)
forall a. Digest' a -> Digest' a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Digest' a -> Digest' a -> Bool
$c/= :: forall a. Digest' a -> Digest' a -> Bool
== :: Digest' a -> Digest' a -> Bool
$c== :: forall a. Digest' a -> Digest' a -> Bool
Eq, Eq (Digest' a)
Eq (Digest' a)
-> (Digest' a -> Digest' a -> Ordering)
-> (Digest' a -> Digest' a -> Bool)
-> (Digest' a -> Digest' a -> Bool)
-> (Digest' a -> Digest' a -> Bool)
-> (Digest' a -> Digest' a -> Bool)
-> (Digest' a -> Digest' a -> Digest' a)
-> (Digest' a -> Digest' a -> Digest' a)
-> Ord (Digest' a)
Digest' a -> Digest' a -> Bool
Digest' a -> Digest' a -> Ordering
Digest' a -> Digest' a -> Digest' a
forall a. Eq (Digest' a)
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
forall a. Digest' a -> Digest' a -> Bool
forall a. Digest' a -> Digest' a -> Ordering
forall a. Digest' a -> Digest' a -> Digest' a
min :: Digest' a -> Digest' a -> Digest' a
$cmin :: forall a. Digest' a -> Digest' a -> Digest' a
max :: Digest' a -> Digest' a -> Digest' a
$cmax :: forall a. Digest' a -> Digest' a -> Digest' a
>= :: Digest' a -> Digest' a -> Bool
$c>= :: forall a. Digest' a -> Digest' a -> Bool
> :: Digest' a -> Digest' a -> Bool
$c> :: forall a. Digest' a -> Digest' a -> Bool
<= :: Digest' a -> Digest' a -> Bool
$c<= :: forall a. Digest' a -> Digest' a -> Bool
< :: Digest' a -> Digest' a -> Bool
$c< :: forall a. Digest' a -> Digest' a -> Bool
compare :: Digest' a -> Digest' a -> Ordering
$ccompare :: forall a. Digest' a -> Digest' a -> Ordering
$cp1Ord :: forall a. Eq (Digest' a)
Ord)

instance HashAlgorithm hash => Show (Digest' hash) where
    show :: Digest' hash -> String
show (Digest' Digest hash
digest) = (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower ShowS -> (Digest hash -> String) -> Digest hash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
C8.unpack (ByteString -> String)
-> (Digest hash -> ByteString) -> Digest hash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
encodeBase32Unpadded' (ByteString -> ByteString)
-> (Digest hash -> ByteString) -> Digest hash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest hash -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
toBytes (Digest hash -> String) -> Digest hash -> String
forall a b. (a -> b) -> a -> b
$ Digest hash
digest

instance ToExpr (Digest' a) where
    toExpr :: Digest' a -> Expr
toExpr (Digest' Digest a
d) = ByteString -> Expr
forall a. ToExpr a => a -> Expr
toExpr (Digest a -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
toBytes Digest a
d)

deriving instance BA.ByteArrayAccess (Digest' hash)

instance HashAlgorithm hash => IsString (Digest' hash) where
    fromString :: String -> Digest' hash
fromString =
        Digest hash -> Digest' hash
forall a. Digest a -> Digest' a
Digest'
            (Digest hash -> Digest' hash)
-> (String -> Digest hash) -> String -> Digest' hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest hash -> Maybe (Digest hash) -> Digest hash
forall a. a -> Maybe a -> a
fromMaybe (String -> Digest hash
forall a. HasCallStack => String -> a
error String
"invalid base32-encoded digest")
            (Maybe (Digest hash) -> Digest hash)
-> (String -> Maybe (Digest hash)) -> String -> Digest hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe (Digest hash))
-> (ByteString -> Maybe (Digest hash))
-> Either Text ByteString
-> Maybe (Digest hash)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Text -> Maybe (Digest hash)
forall a. HasCallStack => String -> a
error String
"invalid base32-encoded digest") ByteString -> Maybe (Digest hash)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString
            (Either Text ByteString -> Maybe (Digest hash))
-> (String -> Either Text ByteString)
-> String
-> Maybe (Digest hash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text ByteString
decodeBase32Unpadded
            (ByteString -> Either Text ByteString)
-> (String -> ByteString) -> String -> Either Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C8.pack

-- | The all-zero digest value at a specific hash algorithm.
zero :: forall hash. HashAlgorithm hash => Digest' hash
zero :: Digest' hash
zero = Digest hash -> Digest' hash
forall a. Digest a -> Digest' a
Digest' (Digest hash -> Digest' hash)
-> (Word8 -> Digest hash) -> Word8 -> Digest' hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Digest hash) -> Digest hash
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Digest hash) -> Digest hash)
-> (Word8 -> Maybe (Digest hash)) -> Word8 -> Digest hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ba.
(HashAlgorithm hash, ByteArrayAccess ba) =>
ba -> Maybe (Digest hash)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @hash (ByteString -> Maybe (Digest hash))
-> (Word8 -> ByteString) -> Word8 -> Maybe (Digest hash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8 -> ByteString
B.replicate (hash -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize (hash
forall a. HasCallStack => a
undefined :: hash)) (Word8 -> Digest' hash) -> Word8 -> Digest' hash
forall a b. (a -> b) -> a -> b
$ Word8
0

{- | A hash algorithm which computes its digest using the parameterized hash
 algorithm and then computes a digest of _that_ digest with the same hash
 algorithm.
-}
data DoubleHash hash = DoubleHash

-- | The double SHA256 hash algorithm.
type SHA256d = DoubleHash SHA256

deriving instance Show hash => Show (DoubleHash hash)
deriving instance Data hash => Data (DoubleHash hash)

instance HashAlgorithm hash => HashAlgorithm (DoubleHash hash) where
    type HashBlockSize (DoubleHash hash) = HashBlockSize hash
    type HashDigestSize (DoubleHash hash) = HashDigestSize hash
    type HashInternalContextSize (DoubleHash hash) = HashInternalContextSize hash

    -- cryptonite doesn't force the argument and neither will we, allowing the
    -- pattern of passing `undefined` around as the value.
    hashBlockSize :: DoubleHash hash -> Int
hashBlockSize DoubleHash hash
_ = hash -> Int
forall a. HashAlgorithm a => a -> Int
hashBlockSize @hash hash
forall a. HasCallStack => a
undefined
    hashDigestSize :: DoubleHash hash -> Int
hashDigestSize DoubleHash hash
_ = hash -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize @hash hash
forall a. HasCallStack => a
undefined
    hashInternalContextSize :: DoubleHash hash -> Int
hashInternalContextSize DoubleHash hash
_ = hash -> Int
forall a. HashAlgorithm a => a -> Int
hashInternalContextSize @hash hash
forall a. HasCallStack => a
undefined

    -- We'll re-use a Context for the wrapped hash type.
    hashInternalInit :: Ptr (Context (DoubleHash hash)) -> IO ()
hashInternalInit Ptr (Context (DoubleHash hash))
ctxPtr = Ptr (Context hash) -> IO ()
forall a. HashAlgorithm a => Ptr (Context a) -> IO ()
hashInternalInit (Ptr (Context (DoubleHash hash)) -> Ptr (Context hash)
coerce Ptr (Context (DoubleHash hash))
ctxPtr :: Ptr (Context hash))
    hashInternalUpdate :: Ptr (Context (DoubleHash hash)) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate Ptr (Context (DoubleHash hash))
ctxPtr = Ptr (Context hash) -> Ptr Word8 -> Word32 -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate (Ptr (Context (DoubleHash hash)) -> Ptr (Context hash)
coerce Ptr (Context (DoubleHash hash))
ctxPtr :: Ptr (Context hash))
    hashInternalFinalize :: Ptr (Context (DoubleHash hash))
-> Ptr (Digest (DoubleHash hash)) -> IO ()
hashInternalFinalize Ptr (Context (DoubleHash hash))
ctxPtr Ptr (Digest (DoubleHash hash))
digestPtr = do
        -- Do the first pass
        Ptr (Context hash) -> Ptr (Digest hash) -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr (Digest a) -> IO ()
hashInternalFinalize
            (Ptr (Context (DoubleHash hash)) -> Ptr (Context hash)
coerce Ptr (Context (DoubleHash hash))
ctxPtr :: Ptr (Context hash))
            (Ptr (Digest (DoubleHash hash)) -> Ptr (Digest hash)
coerce Ptr (Digest (DoubleHash hash))
digestPtr :: Ptr (Digest hash))
        -- And then a second pass over the result
        ByteString
firstHash <- Ptr (Digest (DoubleHash hash)) -> IO ByteString
forall hash.
HashAlgorithm hash =>
Ptr (Digest hash) -> IO ByteString
digestPtrToByteString Ptr (Digest (DoubleHash hash))
digestPtr
        let secondHash :: Digest hash
secondHash = ByteString -> Digest hash
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash ByteString
firstHash :: Digest hash
        -- And shove the second result into the output
        ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
useAsCString (Digest hash -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
toBytes Digest hash
secondHash) ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
new -> CString -> CString -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Ptr a -> Ptr a -> Int -> m ()
copyPtr (Ptr (Digest (DoubleHash hash)) -> CString
coerce Ptr (Digest (DoubleHash hash))
digestPtr :: CString) CString
new (hash -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize @hash hash
forall a. HasCallStack => a
undefined)

-- | Extract the bytes from a value like a `Digest' hash`.
toBytes :: BA.ByteArrayAccess a => a -> B.ByteString
toBytes :: a -> ByteString
toBytes = [Word8] -> ByteString
B.pack ([Word8] -> ByteString) -> (a -> [Word8]) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Word8]
forall a. ByteArrayAccess a => a -> [Word8]
BA.unpack

{- | Read the digest bytes out of a pointer to a Digest.  This uses some
 coerce trickery.  I hope it's not too broken.
-}
digestPtrToByteString :: forall hash. HashAlgorithm hash => Ptr (Digest hash) -> IO B.ByteString
digestPtrToByteString :: Ptr (Digest hash) -> IO ByteString
digestPtrToByteString = CStringLen -> IO ByteString
packCStringLen (CStringLen -> IO ByteString)
-> (Ptr (Digest hash) -> CStringLen)
-> Ptr (Digest hash)
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,hash -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize @hash hash
forall a. HasCallStack => a
undefined) (CString -> CStringLen)
-> (Ptr (Digest hash) -> CString)
-> Ptr (Digest hash)
-> CStringLen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coercible (Ptr (Digest hash)) CString =>
Ptr (Digest hash) -> CString
coerce @(Ptr (Digest hash)) @CString