{-# 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.Fingerprint (
        Fingerprint(..), fingerprint0,
        fingerprintData,
        fingerprintString,
        fingerprintFingerprints,
        getFileHash
   ) where

import GHC.IO
import GHC.Base
import GHC.Num
import GHC.List
import GHC.Real
import GHC.Show
import Foreign
import Foreign.C
import System.IO

import GHC.Fingerprint.Type

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

-- XXX instance Storable Fingerprint
-- defined in 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] -> Fingerprint
forall a. HasCallStack => [a] -> a
head [Fingerprint]
fs))

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 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
            Int
count <- Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr Word8
arrPtr Int
_BUFSIZE
            Bool
eof <- Handle -> IO Bool
hIsEOF Handle
h
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
_BUFSIZE Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> a
errorWithoutStackTrace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"GHC.Fingerprint.getFileHash: only read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bytes"

            Ptr Word8 -> Int -> IO ()
f Ptr Word8
arrPtr Int
count

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
eof) IO ()
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 ()