Ticket #1993: SHA1.lhs

File SHA1.lhs, 10.2 KB (added by igloo, 6 years ago)

Standalone example

Line 
1% Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li>
2
3% This program is free software; you can redistribute it and/or modify
4% it under the terms of the GNU General Public License as published by
5% the Free Software Foundation; either version 2, or (at your option)
6% any later version.
7
8% This program is distributed in the hope that it will be useful,
9% but WITHOUT ANY WARRANTY; without even the implied warranty of
10% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11% GNU General Public License for more details.
12
13% You should have received a copy of the GNU General Public License
14% along with this program; see the file COPYING.  If not, write to
15% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
16% Boston, MA 02110-1301, USA.
17
18\begin{code}
19{-# OPTIONS -fglasgow-exts -fno-warn-name-shadowing #-}
20-- -fglasgow-exts needed for nasty hack below
21-- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4
22module SHA1 (sha1PS) where
23
24import System.Mem ( performGC )
25import Control.Monad
26import Data.Char (intToDigit)
27import Data.Bits (xor, (.&.), (.|.), complement, rotateL)
28import Data.Word (Word8, Word32)
29import Foreign.C
30import Foreign.ForeignPtr
31import Foreign.Ptr
32import Foreign.Marshal.Array (advancePtr)
33import Foreign.Storable (peek, poke)
34import System.IO.Unsafe (unsafePerformIO)
35
36data PackedString = PS !(ForeignPtr Word8) !Int !Int
37
38unsafeWithInternals :: PackedString -> (Ptr Word8 -> Int -> IO a) -> IO a
39unsafeWithInternals (PS fp s l) f
40 = withForeignPtr fp $ \p -> f (p `plusPtr` s) l
41
42debugForeignPtr :: ForeignPtr a -> String -> IO ()
43debugForeignPtr _ _ = return ()
44
45nilPS :: PackedString
46nilPS = unsafePerformIO $ do fp <- mallocForeignPtrx 1
47                             debugForeignPtr fp "nilPS"
48                             return $ PS fp 0 0
49
50mallocForeignPtrx :: Int -> IO (ForeignPtr Word8)
51mallocForeignPtrx l
52    = do when (l > 1000000) performGC
53         mallocForeignPtrArray l
54
55createPS :: Int -> (Ptr Word8 -> IO ()) -> PackedString
56createPS l write_ptr =
57    unsafePerformIO $ do fp <- mallocForeignPtrx l
58                         debugForeignPtr fp "createPS"
59                         withForeignPtr fp $ \p -> write_ptr p
60                         return $ PS fp 0 l
61
62foreign import ccall unsafe "static string.h memcpy" c_memcpy
63    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()
64
65concatLenPS :: Int -> [PackedString] -> PackedString
66concatLenPS n [] = n `seq` nilPS
67concatLenPS _ [ps] = ps
68concatLenPS total_length pss = createPS total_length $ \p-> cpPSs p pss
69    where cpPSs :: Ptr Word8 -> [PackedString] -> IO ()
70          cpPSs p (PS x s l:rest) =
71              do withForeignPtr x $ \pf ->
72                     c_memcpy p (pf `plusPtr` s) (fromIntegral l)
73                 cpPSs (p `plusPtr` l) rest
74          cpPSs _ [] = return ()
75
76packWords :: [Word8] -> PackedString
77packWords = undefined
78
79lengthPS :: PackedString -> Int
80lengthPS = undefined
81
82
83--------------
84
85data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32
86data XYZ = XYZ !Word32 !Word32 !Word32
87
88sha1PS :: PackedString -> String
89sha1PS s = s5
90 where s1_2 = sha1_step_1_2_pad_length s
91       abcde = sha1_step_3_init
92       abcde' = unsafePerformIO
93              $ unsafeWithInternals s1_2 (\ptr len ->
94                    do let ptr' = castPtr ptr
95                       sha1_step_4_main abcde ptr' len)
96       s5 = sha1_step_5_display abcde'
97\end{code}
98
99sha1_step_1_2_pad_length assumes the length is at most 2^61.
100This seems reasonable as the Int used to represent it is normally 32bit,
101but obviously could go wrong with large inputs on 64bit machines.
102The PackedString library should probably move to Word64s if this is an
103issue, though.
104
105\begin{code}
106sha1_step_1_2_pad_length :: PackedString -> PackedString
107sha1_step_1_2_pad_length s
108 = let len = lengthPS s
109       num_nuls = (55 - len) `mod` 64
110       padding = 128:replicate num_nuls 0
111       len_w8s = reverse $ size_split 8 (fromIntegral len*8)
112   in concatLenPS (len + 1 + num_nuls + 8)
113                  [s, packWords padding, packWords len_w8s]
114
115size_split :: Int -> Integer -> [Word8]
116size_split 0 _ = []
117size_split p n = fromIntegral d:size_split (p-1) n'
118 where (n', d) = divMod n 256
119
120sha1_step_3_init :: ABCDE
121sha1_step_3_init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0
122\end{code}
123
124\begin{code}
125sha1_step_4_main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE
126sha1_step_4_main abcde _ 0 = return $! abcde
127sha1_step_4_main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len
128    = do
129         (e, b) <- doit f1 0x5a827999 (x 0) a b c d e
130         (d, a) <- doit f1 0x5a827999 (x 1) e a b c d
131         (c, e) <- doit f1 0x5a827999 (x 2) d e a b c
132         (b, d) <- doit f1 0x5a827999 (x 3) c d e a b
133         (a, c) <- doit f1 0x5a827999 (x 4) b c d e a
134         (e, b) <- doit f1 0x5a827999 (x 5) a b c d e
135         (d, a) <- doit f1 0x5a827999 (x 6) e a b c d
136         (c, e) <- doit f1 0x5a827999 (x 7) d e a b c
137         (b, d) <- doit f1 0x5a827999 (x 8) c d e a b
138         (a, c) <- doit f1 0x5a827999 (x 9) b c d e a
139         (e, b) <- doit f1 0x5a827999 (x 10) a b c d e
140         (d, a) <- doit f1 0x5a827999 (x 11) e a b c d
141         (c, e) <- doit f1 0x5a827999 (x 12) d e a b c
142         (b, d) <- doit f1 0x5a827999 (x 13) c d e a b
143         (a, c) <- doit f1 0x5a827999 (x 14) b c d e a
144         (e, b) <- doit f1 0x5a827999 (x 15) a b c d e
145         (d, a) <- doit f1 0x5a827999 (m 16) e a b c d
146         (c, e) <- doit f1 0x5a827999 (m 17) d e a b c
147         (b, d) <- doit f1 0x5a827999 (m 18) c d e a b
148         (a, c) <- doit f1 0x5a827999 (m 19) b c d e a
149         (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e
150         (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d
151         (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c
152         (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b
153         (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a
154         (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e
155         (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d
156         (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c
157         (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b
158         (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a
159         (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e
160         (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d
161         (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c
162         (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b
163         (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a
164         (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e
165         (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d
166         (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c
167         (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b
168         (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a
169         (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e
170         (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d
171         (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c
172         (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b
173         (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a
174         (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e
175         (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d
176         (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c
177         (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b
178         (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a
179         (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e
180         (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d
181         (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c
182         (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b
183         (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a
184         (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e
185         (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d
186         (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c
187         (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b
188         (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a
189         (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e
190         (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d
191         (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c
192         (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b
193         (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a
194         (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e
195         (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d
196         (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c
197         (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b
198         (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a
199         (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e
200         (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d
201         (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c
202         (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b
203         (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a
204         (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e
205         (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d
206         (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c
207         (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b
208         (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a
209         let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e)
210         sha1_step_4_main abcde' (s `advancePtr` 16) (len - 64)
211 where {-# INLINE f1 #-}
212       f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z)
213       {-# INLINE f2 #-}
214       f2 (XYZ x y z) = x `xor` y `xor` z
215       {-# INLINE f3 #-}
216       f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)
217       {-# INLINE x #-}
218       x n = peek (s `advancePtr` n)
219       {-# INLINE m #-}
220       m n = do let base = s `advancePtr` (n .&. 15)
221                x0 <- peek base
222                x1 <- peek (s `advancePtr` ((n - 14) .&. 15))
223                x2 <- peek (s `advancePtr` ((n - 8) .&. 15))
224                x3 <- peek (s `advancePtr` ((n - 3) .&. 15))
225                let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1
226                poke base res
227                return res
228       {-# INLINE doit #-}
229       doit f k i a b c d e = a `seq` c `seq`
230           do i' <- i
231              return (rotateL a 5 + f (XYZ b c d) + e + i' + k,
232                      rotateL b 30)
233
234sha1_step_5_display :: ABCDE -> String
235sha1_step_5_display (ABCDE a b c d e)
236 = concatMap showAsHex [a, b, c, d, e]
237
238showAsHex :: Word32 -> String
239showAsHex n = showIt 8 n ""
240   where
241    showIt :: Int -> Word32 -> String -> String
242    showIt 0 _ r = r
243    showIt i x r = case quotRem x 16 of
244                       (y, z) -> let c = intToDigit (fromIntegral z)
245                                 in c `seq` showIt (i-1) y (c:r)
246\end{code}
247