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 {-# OPTIONS_GHC -fno-warn-name-shadowing -cpp #-} 19 {-# LANGUAGE CPP #-} 20 21 22 -- {-# OPTIONS_GHC -fglasgow-exts -fno-warn-name-shadowing #-} 23 -- -fglasgow-exts needed for nasty hack below 24 -- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4 25 module SHA1 (sha1PS) where 26 27 import ByteStringUtils (unsafeWithInternals) 28 import qualified Data.ByteString as B (ByteString, pack, length, concat) 29 30 import Data.Char (intToDigit) 31 import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR) 32 import Data.Word (Word8, Word32) 33 import Foreign.Ptr (Ptr, castPtr) 34 import Foreign.Marshal.Array (advancePtr) 35 import Foreign.Storable (peek, poke) 36 import System.IO.Unsafe (unsafePerformIO) 37 38 data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32 39 data XYZ = XYZ !Word32 !Word32 !Word32 40 41 sha1PS :: B.ByteString -> String 42 sha1PS s = s5 43 where s1_2 = sha1_step_1_2_pad_length s 44 abcde = sha1_step_3_init 45 abcde' = unsafePerformIO 46 $ unsafeWithInternals s1_2 (\ptr len -> 47 do let ptr' = castPtr ptr 48 #ifndef BIGENDIAN 49 fiddle_endianness ptr' len 50 #endif 51 sha1_step_4_main abcde ptr' len) 52 s5 = sha1_step_5_display abcde' 53 54 fiddle_endianness :: Ptr Word32 -> Int -> IO () 55 fiddle_endianness p 0 = p `seq` return () 56 fiddle_endianness p n 57 = do x <- peek p 58 poke p $ shiftL x 24 59 .|. shiftL (x .&. 0xff00) 8 60 .|. (shiftR x 8 .&. 0xff00) 61 .|. shiftR x 24 62 fiddle_endianness (p `advancePtr` 1) (n - 4) 63 64 -- sha1_step_1_2_pad_length assumes the length is at most 2^61. 65 -- This seems reasonable as the Int used to represent it is normally 32bit, 66 -- but obviously could go wrong with large inputs on 64bit machines. 67 -- The B.ByteString library should probably move to Word64s if this is an 68 -- issue, though. 69 70 sha1_step_1_2_pad_length :: B.ByteString -> B.ByteString 71 sha1_step_1_2_pad_length s 72 = let len = B.length s 73 num_nuls = (55 - len) `mod` 64 74 padding = 128:replicate num_nuls 0 75 len_w8s = reverse $ size_split 8 (fromIntegral len*8) 76 in B.concat [s, B.pack padding, B.pack len_w8s] 77 78 size_split :: Int -> Integer -> [Word8] 79 size_split 0 _ = [] 80 size_split p n = fromIntegral d:size_split (p-1) n' 81 where (n', d) = divMod n 256 82 83 sha1_step_3_init :: ABCDE 84 sha1_step_3_init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 85 86 sha1_step_4_main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE 87 sha1_step_4_main abcde _ 0 = return $! abcde 88 sha1_step_4_main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len 89 = do 90 (e, b) <- doit f1 0x5a827999 (x 0) a b c d e 91 (d, a) <- doit f1 0x5a827999 (x 1) e a b c d 92 (c, e) <- doit f1 0x5a827999 (x 2) d e a b c 93 (b, d) <- doit f1 0x5a827999 (x 3) c d e a b 94 (a, c) <- doit f1 0x5a827999 (x 4) b c d e a 95 (e, b) <- doit f1 0x5a827999 (x 5) a b c d e 96 (d, a) <- doit f1 0x5a827999 (x 6) e a b c d 97 (c, e) <- doit f1 0x5a827999 (x 7) d e a b c 98 (b, d) <- doit f1 0x5a827999 (x 8) c d e a b 99 (a, c) <- doit f1 0x5a827999 (x 9) b c d e a 100 (e, b) <- doit f1 0x5a827999 (x 10) a b c d e 101 (d, a) <- doit f1 0x5a827999 (x 11) e a b c d 102 (c, e) <- doit f1 0x5a827999 (x 12) d e a b c 103 (b, d) <- doit f1 0x5a827999 (x 13) c d e a b 104 (a, c) <- doit f1 0x5a827999 (x 14) b c d e a 105 (e, b) <- doit f1 0x5a827999 (x 15) a b c d e 106 (d, a) <- doit f1 0x5a827999 (m 16) e a b c d 107 (c, e) <- doit f1 0x5a827999 (m 17) d e a b c 108 (b, d) <- doit f1 0x5a827999 (m 18) c d e a b 109 (a, c) <- doit f1 0x5a827999 (m 19) b c d e a 110 (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e 111 (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d 112 (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c 113 (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b 114 (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a 115 (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e 116 (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d 117 (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c 118 (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b 119 (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a 120 (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e 121 (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d 122 (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c 123 (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b 124 (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a 125 (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e 126 (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d 127 (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c 128 (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b 129 (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a 130 (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e 131 (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d 132 (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c 133 (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b 134 (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a 135 (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e 136 (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d 137 (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c 138 (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b 139 (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a 140 (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e 141 (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d 142 (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c 143 (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b 144 (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a 145 (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e 146 (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d 147 (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c 148 (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b 149 (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a 150 (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e 151 (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d 152 (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c 153 (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b 154 (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a 155 (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e 156 (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d 157 (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c 158 (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b 159 (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a 160 (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e 161 (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d 162 (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c 163 (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b 164 (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a 165 (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e 166 (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d 167 (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c 168 (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b 169 (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a 170 let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e) 171 sha1_step_4_main abcde' (s `advancePtr` 16) (len - 64) 172 where {-# INLINE f1 #-} 173 f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z) 174 {-# INLINE f2 #-} 175 f2 (XYZ x y z) = x `xor` y `xor` z 176 {-# INLINE f3 #-} 177 f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z) 178 {-# INLINE x #-} 179 x n = peek (s `advancePtr` n) 180 {-# INLINE m #-} 181 m n = do let base = s `advancePtr` (n .&. 15) 182 x0 <- peek base 183 x1 <- peek (s `advancePtr` ((n - 14) .&. 15)) 184 x2 <- peek (s `advancePtr` ((n - 8) .&. 15)) 185 x3 <- peek (s `advancePtr` ((n - 3) .&. 15)) 186 let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1 187 poke base res 188 return res 189 {-# INLINE doit #-} 190 doit f k i a b c d e = a `seq` c `seq` 191 do i' <- i 192 return (rotateL a 5 + f (XYZ b c d) + e + i' + k, 193 rotateL b 30) 194 195 sha1_step_5_display :: ABCDE -> String 196 sha1_step_5_display (ABCDE a b c d e) 197 = concatMap showAsHex [a, b, c, d, e] 198 199 showAsHex :: Word32 -> String 200 showAsHex n = showIt 8 n "" 201 where 202 showIt :: Int -> Word32 -> String -> String 203 showIt 0 _ r = r 204 showIt i x r = case quotRem x 16 of 205 (y, z) -> let c = intToDigit (fromIntegral z) 206 in c `seq` showIt (i-1) y (c:r)