Cabal-syntax/src/Distribution/Utils/MD5.hs

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