1module Distribution.Utils.MD5 (
2    MD5,
3    showMD5,
4    md5,
5    -- * Helpers
6    md5FromInteger,
7    -- * Binary
8    binaryPutMD5,
9    binaryGetMD5,
10    ) where
11
12import Data.Binary      (Get, Put)
13import Data.Binary.Get  (getWord64le)
14import Data.Binary.Put  (putWord64le)
15import Data.Bits        (complement, shiftR, (.&.))
16import Foreign.Ptr      (castPtr)
17import GHC.Fingerprint  (Fingerprint (..), fingerprintData)
18import Numeric          (showHex)
19import System.IO.Unsafe (unsafeDupablePerformIO)
20
21import qualified Data.ByteString        as BS
22import qualified Data.ByteString.Unsafe as BS
23
24type MD5 = Fingerprint
25
26-- | Show 'MD5' in human readable form
27--
28-- >>> showMD5 (Fingerprint 123 456)
29-- "000000000000007b00000000000001c8"
30--
31-- >>> showMD5 $ md5 $ BS.pack [0..127]
32-- "37eff01866ba3f538421b30b7cbefcac"
33--
34-- @since  3.2.0.0
35showMD5 :: MD5 -> String
36showMD5 (Fingerprint a b) = pad a' ++ pad b' where
37    a' = showHex a ""
38    b' = showHex b ""
39    pad s = replicate (16 - length s) '0' ++ s
40
41-- | @since  3.2.0.0
42md5 :: BS.ByteString -> MD5
43md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->
44    fingerprintData (castPtr ptr) len
45
46-- | @since  3.2.0.0
47binaryPutMD5 :: MD5 -> Put
48binaryPutMD5 (Fingerprint a b) = do
49    putWord64le a
50    putWord64le b
51
52-- | @since  3.2.0.0
53binaryGetMD5 :: Get MD5
54binaryGetMD5 = do
55    a <- getWord64le
56    b <- getWord64le
57    return (Fingerprint a b)
58
59-- |
60--
61-- >>> showMD5 $ md5FromInteger 0x37eff01866ba3f538421b30b7cbefcac
62-- "37eff01866ba3f538421b30b7cbefcac"
63--
64-- Note: the input is truncated:
65--
66-- >>> showMD5 $ md5FromInteger 0x1230000037eff01866ba3f538421b30b7cbefcac
67-- "37eff01866ba3f538421b30b7cbefcac"
68--
69-- Yet, negative numbers are not a problem...
70--
71-- >>> showMD5 $ md5FromInteger (-1)
72-- "ffffffffffffffffffffffffffffffff"
73--
74-- @since 3.4.0.0
75md5FromInteger :: Integer -> MD5
76md5FromInteger i = Fingerprint hi lo where
77    mask = complement 0
78    lo   = mask .&. fromInteger i
79    hi   = mask .&. fromInteger (i `shiftR` 64)
80