Fix -Werror failure in GHC.Fingerprint
[packages/base.git] / GHC / Fingerprint.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE NoImplicitPrelude
3 , BangPatterns
4 , ForeignFunctionInterface
5 , EmptyDataDecls
6 #-}
7
8 -- ----------------------------------------------------------------------------
9 --
10 -- (c) The University of Glasgow 2006
11 --
12 -- Fingerprints for recompilation checking and ABI versioning, and
13 -- implementing fast comparison of Typeable.
14 --
15 -- ----------------------------------------------------------------------------
16
17 module GHC.Fingerprint (
18 Fingerprint(..), fingerprint0,
19 fingerprintData,
20 fingerprintString,
21 fingerprintFingerprints,
22 getFileHash
23 ) where
24
25 import GHC.IO
26 import GHC.Base
27 import GHC.Num
28 import GHC.List
29 import GHC.Real
30 import GHC.Show
31 import Foreign
32 import Foreign.C
33 import System.IO
34 import Control.Monad (when)
35
36 import GHC.Fingerprint.Type
37
38 -- for SIZEOF_STRUCT_MD5CONTEXT:
39 #include "HsBaseConfig.h"
40
41 -- XXX instance Storable Fingerprint
42 -- defined in Foreign.Storable to avoid orphan instance
43
44 fingerprint0 :: Fingerprint
45 fingerprint0 = Fingerprint 0 0
46
47 fingerprintFingerprints :: [Fingerprint] -> Fingerprint
48 fingerprintFingerprints fs = unsafeDupablePerformIO $
49 withArrayLen fs $ \len p -> do
50 fingerprintData (castPtr p) (len * sizeOf (head fs))
51
52 fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
53 fingerprintData buf len = do
54 allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
55 c_MD5Init pctxt
56 c_MD5Update pctxt buf (fromIntegral len)
57 allocaBytes 16 $ \pdigest -> do
58 c_MD5Final pdigest pctxt
59 peek (castPtr pdigest :: Ptr Fingerprint)
60
61 -- This is duplicated in compiler/utils/Fingerprint.hsc
62 fingerprintString :: String -> Fingerprint
63 fingerprintString str = unsafeDupablePerformIO $
64 withArrayLen word8s $ \len p ->
65 fingerprintData p len
66 where word8s = concatMap f str
67 f c = let w32 :: Word32
68 w32 = fromIntegral (ord c)
69 in [fromIntegral (w32 `shiftR` 24),
70 fromIntegral (w32 `shiftR` 16),
71 fromIntegral (w32 `shiftR` 8),
72 fromIntegral w32]
73
74 -- | Computes the hash of a given file.
75 -- This function loops over the handle, running in constant memory.
76 getFileHash :: FilePath -> IO Fingerprint
77 getFileHash path = withBinaryFile path ReadMode $ \h -> do
78 allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
79 c_MD5Init pctxt
80
81 processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size))
82
83 allocaBytes 16 $ \pdigest -> do
84 c_MD5Final pdigest pctxt
85 peek (castPtr pdigest :: Ptr Fingerprint)
86
87 where
88 _BUFSIZE = 4096
89
90 -- | Loop over _BUFSIZE sized chunks read from the handle,
91 -- passing the callback a block of bytes and its size.
92 processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO ()
93 processChunks h f = allocaBytes _BUFSIZE $ \arrPtr ->
94
95 let loop = do
96 count <- hGetBuf h arrPtr _BUFSIZE
97 eof <- hIsEOF h
98 when (count /= _BUFSIZE && not eof) $ error $
99 "GHC.Fingerprint.getFileHash: only read " ++ show count ++ " bytes"
100
101 f arrPtr count
102
103 when (not eof) loop
104
105 in loop
106
107 data MD5Context
108
109 foreign import ccall unsafe "__hsbase_MD5Init"
110 c_MD5Init :: Ptr MD5Context -> IO ()
111 foreign import ccall unsafe "__hsbase_MD5Update"
112 c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
113 foreign import ccall unsafe "__hsbase_MD5Final"
114 c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO ()
115