-- | An implementation of 'HashAlgorithm' for MD5 (https://www.ietf.org/rfc/rfc1321.txt).
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CApiFFI #-}
module Data.LargeHashable.MD5 (

    MD5Hash(..), md5HashAlgorithm, runMD5

) where

-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")
import Data.LargeHashable.Intern
import Data.LargeHashable.LargeWord
import Data.Word
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BSC

newtype MD5Hash = MD5Hash { MD5Hash -> Word128
unMD5Hash :: Word128 }
    deriving (MD5Hash -> MD5Hash -> Bool
(MD5Hash -> MD5Hash -> Bool)
-> (MD5Hash -> MD5Hash -> Bool) -> Eq MD5Hash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MD5Hash -> MD5Hash -> Bool
== :: MD5Hash -> MD5Hash -> Bool
$c/= :: MD5Hash -> MD5Hash -> Bool
/= :: MD5Hash -> MD5Hash -> Bool
Eq, Eq MD5Hash
Eq MD5Hash =>
(MD5Hash -> MD5Hash -> Ordering)
-> (MD5Hash -> MD5Hash -> Bool)
-> (MD5Hash -> MD5Hash -> Bool)
-> (MD5Hash -> MD5Hash -> Bool)
-> (MD5Hash -> MD5Hash -> Bool)
-> (MD5Hash -> MD5Hash -> MD5Hash)
-> (MD5Hash -> MD5Hash -> MD5Hash)
-> Ord MD5Hash
MD5Hash -> MD5Hash -> Bool
MD5Hash -> MD5Hash -> Ordering
MD5Hash -> MD5Hash -> MD5Hash
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
$ccompare :: MD5Hash -> MD5Hash -> Ordering
compare :: MD5Hash -> MD5Hash -> Ordering
$c< :: MD5Hash -> MD5Hash -> Bool
< :: MD5Hash -> MD5Hash -> Bool
$c<= :: MD5Hash -> MD5Hash -> Bool
<= :: MD5Hash -> MD5Hash -> Bool
$c> :: MD5Hash -> MD5Hash -> Bool
> :: MD5Hash -> MD5Hash -> Bool
$c>= :: MD5Hash -> MD5Hash -> Bool
>= :: MD5Hash -> MD5Hash -> Bool
$cmax :: MD5Hash -> MD5Hash -> MD5Hash
max :: MD5Hash -> MD5Hash -> MD5Hash
$cmin :: MD5Hash -> MD5Hash -> MD5Hash
min :: MD5Hash -> MD5Hash -> MD5Hash
Ord)

instance Show MD5Hash where
    show :: MD5Hash -> String
show (MD5Hash Word128
w) =
        ByteString -> String
BSC.unpack (ByteString -> ByteString
Base16.encode (Word128 -> ByteString
w128ToBs Word128
w))

instance Read MD5Hash where
    -- readsPrec :: Read a => Int -> String -> [(a, String)]
    readsPrec :: Int -> ReadS MD5Hash
readsPrec Int
_ String
s =
        let n :: Int
n = Int
32
            (String
prefix, String
suffix) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n String
s
        in
            if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n
                then []
                else
                    case ByteString -> Either String ByteString
Base16.decode (String -> ByteString
BSC.pack String
prefix) of
                        Left String
_ -> []
                        Right ByteString
bs -> [(Word128 -> MD5Hash
MD5Hash (ByteString -> Word128
bsToW128 ByteString
bs), String
suffix)]

foreign import capi unsafe "md5.h md5_init"
    c_md5_init :: Ptr RawCtx -> IO ()

foreign import capi unsafe "md5.h md5_update"
    c_md5_update :: Ptr RawCtx -> Ptr Word8 -> Int -> IO ()

foreign import capi unsafe "md5.h md5_update_uchar"
    c_md5_update_uchar :: Ptr RawCtx -> Word8 -> IO ()

foreign import capi unsafe "md5.h md5_update_ushort"
    c_md5_update_ushort :: Ptr RawCtx -> Word16 -> IO ()

foreign import capi unsafe "md5.h md5_update_uint"
    c_md5_update_uint :: Ptr RawCtx -> Word32 -> IO ()

foreign import capi unsafe "md5.h md5_update_ulong"
    c_md5_update_ulong :: Ptr RawCtx -> Word64 -> IO ()

foreign import capi unsafe "md5.h md5_finalize"
    c_md5_finalize :: Ptr RawCtx -> Ptr Word8 -> IO ()

{-# INLINE digestSize #-}
digestSize :: Int
digestSize :: Int
digestSize = Int
16

{-# INLINE sizeCtx #-}
sizeCtx :: Int
sizeCtx :: Int
sizeCtx = Int
96

data RawCtx -- phantom type argument

newtype Ctx = Ctx { Ctx -> Ptr RawCtx
_unCtx :: Ptr RawCtx }

withCtx :: (Ctx -> IO ()) -> IO MD5Hash
withCtx :: (Ctx -> IO ()) -> IO MD5Hash
withCtx Ctx -> IO ()
f =
    Int -> (Ptr RawCtx -> IO MD5Hash) -> IO MD5Hash
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeCtx ((Ptr RawCtx -> IO MD5Hash) -> IO MD5Hash)
-> (Ptr RawCtx -> IO MD5Hash) -> IO MD5Hash
forall a b. (a -> b) -> a -> b
$ \(Ptr RawCtx
ptr :: Ptr RawCtx) ->
    do Ptr RawCtx -> IO ()
c_md5_init Ptr RawCtx
ptr
       Ctx -> IO ()
f (Ptr RawCtx -> Ctx
Ctx Ptr RawCtx
ptr)
       Int -> (Ptr Word8 -> IO MD5Hash) -> IO MD5Hash
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
digestSize ((Ptr Word8 -> IO MD5Hash) -> IO MD5Hash)
-> (Ptr Word8 -> IO MD5Hash) -> IO MD5Hash
forall a b. (a -> b) -> a -> b
$ \(Ptr Word8
resPtr :: Ptr Word8) ->
           do Ptr RawCtx -> Ptr Word8 -> IO ()
c_md5_finalize Ptr RawCtx
ptr Ptr Word8
resPtr
              let first :: Ptr Word64
first = Ptr Word8 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
resPtr :: Ptr Word64
              Word64
w1 <- Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
first
              let second :: Ptr Word64
second = Ptr Any -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr (Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
resPtr (Word64 -> Int
forall a. Storable a => a -> Int
sizeOf Word64
w1)) :: Ptr Word64
              Word64
w2 <- Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
second
              MD5Hash -> IO MD5Hash
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word128 -> MD5Hash
MD5Hash (Word64 -> Word64 -> Word128
Word128 Word64
w1 Word64
w2))

md5HashAlgorithm :: HashAlgorithm MD5Hash
md5HashAlgorithm :: HashAlgorithm MD5Hash
md5HashAlgorithm =
    HashAlgorithm
    { ha_run :: (HashUpdates -> IO ()) -> IO MD5Hash
ha_run = (HashUpdates -> IO ()) -> IO MD5Hash
run
    , ha_xor :: MD5Hash -> MD5Hash -> MD5Hash
ha_xor = MD5Hash -> MD5Hash -> MD5Hash
xorMD5
    , ha_updateHash :: HashUpdates -> MD5Hash -> IO ()
ha_updateHash = HashUpdates -> MD5Hash -> IO ()
updateHash
    }
    where
      xorMD5 :: MD5Hash -> MD5Hash -> MD5Hash
xorMD5 (MD5Hash Word128
h1) (MD5Hash Word128
h2) = Word128 -> MD5Hash
MD5Hash (Word128
h1 Word128 -> Word128 -> Word128
`xorW128` Word128
h2)
      updateHash :: HashUpdates -> MD5Hash -> IO ()
updateHash HashUpdates
updates (MD5Hash Word128
h) =
          let f :: Word64 -> IO ()
f = HashUpdates -> Word64 -> IO ()
hu_updateULong HashUpdates
updates
          in do Word64 -> IO ()
f (Word128 -> Word64
w128_first Word128
h)
                Word64 -> IO ()
f (Word128 -> Word64
w128_second Word128
h)
      run :: (HashUpdates -> IO ()) -> IO MD5Hash
run HashUpdates -> IO ()
f =
          (Ctx -> IO ()) -> IO MD5Hash
withCtx ((Ctx -> IO ()) -> IO MD5Hash) -> (Ctx -> IO ()) -> IO MD5Hash
forall a b. (a -> b) -> a -> b
$ \(Ctx Ptr RawCtx
ctxPtr) ->
              let !updates :: HashUpdates
updates =
                      HashUpdates
                      { hu_updatePtr :: Ptr Word8 -> Int -> IO ()
hu_updatePtr = Ptr RawCtx -> Ptr Word8 -> Int -> IO ()
c_md5_update Ptr RawCtx
ctxPtr
                      , hu_updateUChar :: Word8 -> IO ()
hu_updateUChar = Ptr RawCtx -> Word8 -> IO ()
c_md5_update_uchar Ptr RawCtx
ctxPtr
                      , hu_updateUShort :: Word16 -> IO ()
hu_updateUShort = Ptr RawCtx -> Word16 -> IO ()
c_md5_update_ushort Ptr RawCtx
ctxPtr
                      , hu_updateUInt :: Word32 -> IO ()
hu_updateUInt = Ptr RawCtx -> Word32 -> IO ()
c_md5_update_uint Ptr RawCtx
ctxPtr
                      , hu_updateULong :: Word64 -> IO ()
hu_updateULong = Ptr RawCtx -> Word64 -> IO ()
c_md5_update_ulong Ptr RawCtx
ctxPtr
                      }
              in HashUpdates -> IO ()
f HashUpdates
updates

runMD5 :: LH () -> MD5Hash
runMD5 :: LH () -> MD5Hash
runMD5 = HashAlgorithm MD5Hash -> LH () -> MD5Hash
forall h. HashAlgorithm h -> LH () -> h
runLH HashAlgorithm MD5Hash
md5HashAlgorithm