GHC/Fingerprint.hs

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

    -- ----------------------------------------------------------------------------
    --
    --  (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 0 0

    fingerprintFingerprints :: [Fingerprint] -> Fingerprint
    fingerprintFingerprints fs = unsafeDupablePerformIO $
      withArrayLen fs $ \len p -> do
        fingerprintData (castPtr p) (len * sizeOf (head fs))

    fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
    fingerprintData buf len = do
      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 str = unsafeDupablePerformIO $
      withArrayLen word8s $ \len p ->
         fingerprintData p len
        where word8s = concatMap f str
              f c = let w32 :: Word32
                        w32 = fromIntegral (ord c)
                    in [fromIntegral (w32 `shiftR` 24),
                        fromIntegral (w32 `shiftR` 16),
                        fromIntegral (w32 `shiftR` 8),
                        fromIntegral 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 path = withBinaryFile path ReadMode $ \h -> do
      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 = 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 h f = allocaBytes _BUFSIZE $ \arrPtr ->

          let loop = do
                count <- hGetBuf h arrPtr _BUFSIZE
                eof <- hIsEOF h
                when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $
                  "GHC.Fingerprint.getFileHash: only read " ++ show count ++ " bytes"

                f arrPtr count

                when (not eof) loop

          in 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 ()