{-# LANGUAGE CPP               #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Trustworthy       #-}

-- ----------------------------------------------------------------------------
--
--  (c) The University of Glasgow 2006
--
-- Fingerprints for recompilation checking and ABI versioning, and
-- implementing fast comparison of Typeable.
--
-- ----------------------------------------------------------------------------

module GHC.Internal.Fingerprint (
        Fingerprint(..), fingerprint0,
        fingerprintData,
        fingerprintString,
        fingerprintFingerprints,
        getFileHash
   ) where

import GHC.Internal.IO
import GHC.Internal.Base
import GHC.Internal.Bits
import GHC.Internal.Num
import GHC.Internal.List
import GHC.Internal.Real
import GHC.Internal.Word
import GHC.Internal.Show
import GHC.Internal.Ptr
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.Marshal.Alloc
import GHC.Internal.Foreign.Marshal.Array
import GHC.Internal.Foreign.Storable
import GHC.Internal.System.IO

import GHC.Internal.Fingerprint.Type

-- for SIZEOF_STRUCT_MD5CONTEXT:
#include "HsBaseConfig.h"

-- XXX instance Storable Fingerprint
-- defined in GHC.Internal.Foreign.Storable to avoid orphan instance

fingerprint0 :: Fingerprint
fingerprint0 :: Fingerprint
fingerprint0 = Word64 -> Word64 -> Fingerprint
Fingerprint Word64
0 Word64
0

fingerprintFingerprints :: [Fingerprint] -> Fingerprint
fingerprintFingerprints :: [Fingerprint] -> Fingerprint
fingerprintFingerprints [Fingerprint]
fs = IO Fingerprint -> Fingerprint
forall a. IO a -> a
unsafeDupablePerformIO (IO Fingerprint -> Fingerprint) -> IO Fingerprint -> Fingerprint
forall a b. (a -> b) -> a -> b
$
  [Fingerprint]
-> (Int -> Ptr Fingerprint -> IO Fingerprint) -> IO Fingerprint
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [Fingerprint]
fs ((Int -> Ptr Fingerprint -> IO Fingerprint) -> IO Fingerprint)
-> (Int -> Ptr Fingerprint -> IO Fingerprint) -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ \Int
len Ptr Fingerprint
p ->
    Ptr Word8 -> Int -> IO Fingerprint
fingerprintData (Ptr Fingerprint -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Fingerprint
p) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Fingerprint -> Int
forall a. Storable a => a -> Int
sizeOf (Fingerprint
forall a. HasCallStack => a
undefined :: Fingerprint))

fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
fingerprintData Ptr Word8
buf Int
len =
  Int -> (Ptr MD5Context -> IO Fingerprint) -> IO Fingerprint
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
    c_MD5Init pctxt
    c_MD5Update pctxt buf (fromIntegral len)
    allocaBytes 16 $ \pdigest -> do
      c_MD5Final pdigest pctxt
      peek (castPtr pdigest :: Ptr Fingerprint)

fingerprintString :: String -> Fingerprint
fingerprintString :: String -> Fingerprint
fingerprintString String
str = IO Fingerprint -> Fingerprint
forall a. IO a -> a
unsafeDupablePerformIO (IO Fingerprint -> Fingerprint) -> IO Fingerprint -> Fingerprint
forall a b. (a -> b) -> a -> b
$
  [Word8] -> (Int -> Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [Word8]
word8s ((Int -> Ptr Word8 -> IO Fingerprint) -> IO Fingerprint)
-> (Int -> Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ \Int
len Ptr Word8
p ->
     Ptr Word8 -> Int -> IO Fingerprint
fingerprintData Ptr Word8
p Int
len
    where word8s :: [Word8]
word8s = (Char -> [Word8]) -> String -> [Word8]
forall a b. (a -> [b]) -> [a] -> [b]
concatMap Char -> [Word8]
forall {a}. Num a => Char -> [a]
f String
str
          f :: Char -> [a]
f Char
c = let w32 :: Word32
                    w32 :: Word32
w32 = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c)
                in [Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24),
                    Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
                    Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8),
                    Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w32]

-- | Computes the hash of a given file.
-- This function loops over the handle, running in constant memory.
--
-- @since base-4.7.0.0
getFileHash :: FilePath -> IO Fingerprint
getFileHash :: String -> IO Fingerprint
getFileHash String
path = String -> IOMode -> (Handle -> IO Fingerprint) -> IO Fingerprint
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
ReadMode ((Handle -> IO Fingerprint) -> IO Fingerprint)
-> (Handle -> IO Fingerprint) -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
  Int -> (Ptr MD5Context -> IO Fingerprint) -> IO Fingerprint
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
    c_MD5Init pctxt

    processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size))

    allocaBytes 16 $ \pdigest -> do
      c_MD5Final pdigest pctxt
      peek (castPtr pdigest :: Ptr Fingerprint)

  where
    _BUFSIZE :: Int
_BUFSIZE = Int
4096

    -- Loop over _BUFSIZE sized chunks read from the handle,
    -- passing the callback a block of bytes and its size.
    processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO ()
    processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO ()
processChunks Handle
h Ptr Word8 -> Int -> IO ()
f = Int -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
_BUFSIZE ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
arrPtr ->

      let loop :: IO ()
loop = do
            count <- Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr Word8
arrPtr Int
_BUFSIZE
            eof <- hIsEOF h
            when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $
              "GHC.Internal.Fingerprint.getFileHash: only read " ++ show count ++ " bytes"

            f arrPtr count

            when (not eof) loop

      in IO ()
loop

data MD5Context

foreign import ccall unsafe "__hsbase_MD5Init"
   c_MD5Init   :: Ptr MD5Context -> IO ()
foreign import ccall unsafe "__hsbase_MD5Update"
   c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
foreign import ccall unsafe "__hsbase_MD5Final"
   c_MD5Final  :: Ptr Word8 -> Ptr MD5Context -> IO ()