diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,18 @@ +See also http://pvp.haskell.org/faq + +### 4.2.5.2 + +- Compatibility fix for `base-4.12` which made `accumArray` stricter causing SHA-1's implementation to hang +- Modernize package description from the ancient cabal spec version 1.2 to version 2.2 and declare test executables as actual test-unit executables (and make them pass) +- Drop support for `base < 4.3` (i.e. GHC < 7.0) +- Reduce dependency footprint of main library by dropping the dependecies on the test specific `HUnit` and `QuickCheck` libraries; these are now only depended upon by the actual test suites +- Reduce compile warnings + +### 4.2.5.1 + +- Compatibility fix for `base-4.6` (`Bits` class not implying `Num` anymore) + +## 4.2.5 + +- Compatibility fix for `base-4.5` (`Num` class not implying `Show` anymore) + diff --git a/Codec/Binary/BubbleBabble.hs b/Codec/Binary/BubbleBabble.hs deleted file mode 100644 --- a/Codec/Binary/BubbleBabble.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Codec.Binary.BubbleBabble(encode) where - - -import Data.Array.Unboxed -import Data.Bits -import Data.Word - -import Codec.Utils - - -vowel :: UArray Int Char -vowel = listArray (0,5) "aeiouy" - -consonant :: UArray Int Char -consonant = listArray (0,16) "bcdfghklmnprstvzx" - - --- | Encode binary data into the bubble babble human readable encoding. --- Bubble Babble is an encoding that represents binary data as psuedowords --- which are more pronouncable and memorable than standard hexadecimal encoding. --- --- It is mainly used for representing cryptographic fingerprints. --- In addition, there is an amount of redundancy and error correction built into --- the representation so that transcription errors can be more readily identified. --- --- see: http://en.wikipedia.org/wiki/Bubble_Babble --- - -encode :: [Octet] -> String -encode cs = 'x' : bb 1 (map fromIntegral cs) where - bb seed [] = vcvx ((seed `mod` 6),16,(seed `div` 6)) - bb seed [x] = vcvx ((((x `shiftR` 6) .&. 3) + seed) `mod` 6, (x `shiftR` 2) .&. 15, ((x .&. 3) + (seed `div` 6)) `mod` 6) - bb seed (x:y:xs) = vcvcc (a,b,c,d,e) $ bb ((seed * 5 + (x * 7 + y)) `mod` 36) xs where - a = (((x `shiftR` 6) .&. 3) + seed) `mod` 6 - b = (x `shiftR` 2) .&. 15 - c = ((x .&. 3) + (seed `div` 6)) `mod` 6 - d = (y `shiftR` 4) .&. 15 - e = y .&. 15 - vcvx (a,b,c) = vowel!a : consonant!b : vowel!c : "x" - vcvcc (a,b,c,d,e) xs = vowel!a : consonant!b : vowel!c : consonant!d : '-' : consonant!e : xs - diff --git a/Codec/Encryption/AES.hs b/Codec/Encryption/AES.hs deleted file mode 100644 --- a/Codec/Encryption/AES.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Codec.Encryption.AES --- Copyright : (c) Dominic Steinitz 2004 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- Takes the AES module supplied by Lukasz Anforowicz and wraps it so it can --- used with the standard modes. --- ------------------------------------------------------------------------------ - -module Codec.Encryption.AES ( - -- * Function Types - encrypt, decrypt, AESKey) where - -import Codec.Encryption.AESAux -import Data.LargeWord -import Codec.Utils -import Data.Word -import Data.Bits - -class (Bits a, Integral a) => AESKeyIndirection a -class AESKeyIndirection a => AESKey a - -instance AESKeyIndirection Word128 -instance AESKeyIndirection Word192 -instance AESKeyIndirection Word256 - -instance AESKey Word128 -instance AESKey Word192 -instance AESKey Word256 - --- | Basic AES encryption which takes a key and a block of plaintext --- and returns the encrypted block of ciphertext according to the standard. - -encrypt :: AESKey a => a -> Word128 -> Word128 -encrypt k p = - case bitSize k of - 128 -> f aes128Encrypt k p - 192 -> f aes192Encrypt k p - 256 -> f aes256Encrypt k p - -f g k p = - fromIntegral $ fromOctets 256 $ - g (i2osp (bitSize k `div` bitSize (0::Octet)) $ fromIntegral k) - (i2osp (bitSize p `div` bitSize (0::Octet)) $ fromIntegral p) - --- | Basic AES decryption which takes a key and a block of ciphertext and --- returns the decrypted block of plaintext according to the standard. - -decrypt :: AESKey a => a -> Word128 -> Word128 -decrypt k p = - case bitSize k of - 128 -> f aes128Decrypt k p - 192 -> f aes192Decrypt k p - 256 -> f aes256Decrypt k p - diff --git a/Codec/Encryption/AESAux.hs b/Codec/Encryption/AESAux.hs deleted file mode 100644 --- a/Codec/Encryption/AESAux.hs +++ /dev/null @@ -1,1008 +0,0 @@ --- | Advanced Encryption System (specification can be found in FIPS-197) -module Codec.Encryption.AESAux( - aes128Encrypt, - aes192Encrypt, - aes256Encrypt, - aes128Decrypt, - aes192Decrypt, - aes256Decrypt, -) where - -import Data.Bits -import Data.Int(Int) -import Data.Word(Word32) - -import Codec.Utils(Octet) - -aes128Encrypt :: [Octet] -- ^ key (16 octets) - -> [Octet] -- ^ msg (16 octets) - -> [Octet] -- ^ enciphered msg (16 octets) -aes128Encrypt = aesEncrypt 10 4 - -aes192Encrypt :: [Octet] -- ^ key (24 octets) - -> [Octet] -- ^ msg (16 octets) - -> [Octet] -- ^ enciphered msg (16 octets) -aes192Encrypt = aesEncrypt 12 6 - -aes256Encrypt :: [Octet] -- ^ key (32 octets) - -> [Octet] -- ^ msg (16 octets) - -> [Octet] -- ^ enciphered msg (16 octets) -aes256Encrypt = aesEncrypt 14 8 - -aes128Decrypt :: [Octet] -- ^ key (16 octets) - -> [Octet] -- ^ enciphered msg (16 octets) - -> [Octet] -- ^ deciphered msg (16 octets) -aes128Decrypt = aesDecrypt 10 4 - -aes192Decrypt :: [Octet] -- ^ key (24 octets) - -> [Octet] -- ^ enciphered msg (16 octets) - -> [Octet] -- ^ deciphered msg (16 octets) -aes192Decrypt = aesDecrypt 12 6 - -aes256Decrypt :: [Octet] -- ^ key (32 octets) - -> [Octet] -- ^ enciphered msg (16 octets) - -> [Octet] -- ^ deciphered msg (16 octets) -aes256Decrypt = aesDecrypt 14 8 - -aesEncrypt :: Int -- ^ nr - -> Int -- ^ nk - -> [Octet] -- ^ key - -> [Octet] -- ^ msg - -> [Octet] -- ^ enciphered msg -aesEncrypt nr nk key - [i00, i10, i20, i30, - i01, i11, i21, i31, - i02, i12, i22, i32, - i03, i13, i23, i33] = - [fo o00, fo o10, fo o20, fo o30, - fo o01, fo o11, fo o21, fo o31, - fo o02, fo o12, fo o22, fo o32, - fo o03, fo o13, fo o23, fo o33] - where State (o00, o01, o02, o03) - (o10, o11, o12, o13) - (o20, o21, o22, o23) - (o30, o31, o32, o33) = transform ( - State(fi i00, fi i01, fi i02, fi i03) - (fi i10, fi i11, fi i12, fi i13) - (fi i20, fi i21, fi i22, fi i23) - (fi i30, fi i31, fi i32, fi i33)) - fi = (fromIntegral :: Octet -> Word32) - fo = (fromIntegral :: Word32 -> Octet) - (kt0:kts) = genAddRoundKey (generateKeys nr nk key) - transform = foldr (.) kt0 (reverse rest) - mss = replicate (nr - 1) (mixColumns . shiftRows . subBytes) - rest = zipWith (.) kts (mss ++ [shiftRows . subBytes ]) - - -aesDecrypt :: Int -- ^ nr - -> Int -- ^ nk - -> [Octet] -- ^ key - -> [Octet] -- ^ enciphered msg - -> [Octet] -- ^ deciphered msg -aesDecrypt nr nk key - [i00, i10, i20, i30, - i01, i11, i21, i31, - i02, i12, i22, i32, - i03, i13, i23, i33] = - [fo o00, fo o10, fo o20, fo o30, - fo o01, fo o11, fo o21, fo o31, - fo o02, fo o12, fo o22, fo o32, - fo o03, fo o13, fo o23, fo o33] - where State (o00, o01, o02, o03) - (o10, o11, o12, o13) - (o20, o21, o22, o23) - (o30, o31, o32, o33) = transform ( - State(fi i00, fi i01, fi i02, fi i03) - (fi i10, fi i11, fi i12, fi i13) - (fi i20, fi i21, fi i22, fi i23) - (fi i30, fi i31, fi i32, fi i33)) - fi = (fromIntegral :: Octet -> Word32) - fo = (fromIntegral :: Word32 -> Octet) - (kt0:kts) = reverse (genAddRoundKey (generateKeys nr nk key)) - transform = foldr (.) kt0 (reverse rest) - ssm = replicate (nr - 1) - (subBytesRev . shiftRowsRev . mixColumnsRev) - rest = zipWith (.) kts ([subBytesRev . shiftRowsRev] ++ ssm) - - - -data State = State !(Word32, Word32, Word32, Word32) - !(Word32, Word32, Word32, Word32) - !(Word32, Word32, Word32, Word32) - !(Word32, Word32, Word32, Word32) - -sbox :: Word32 -> Word32 -sboxRev :: Word32 -> Word32 - -sbox 0x00 = 0x63 -sbox 0x01 = 0x7C -sbox 0x02 = 0x77 -sbox 0x03 = 0x7B -sbox 0x04 = 0xF2 -sbox 0x05 = 0x6B -sbox 0x06 = 0x6F -sbox 0x07 = 0xC5 - -sbox 0x08 = 0x30 -sbox 0x09 = 0x01 -sbox 0x0a = 0x67 -sbox 0x0b = 0x2B -sbox 0x0c = 0xFE -sbox 0x0d = 0xD7 -sbox 0x0e = 0xAB -sbox 0x0f = 0x76 - -sbox 0x10 = 0xCA -sbox 0x11 = 0x82 -sbox 0x12 = 0xC9 -sbox 0x13 = 0x7D -sbox 0x14 = 0xFA -sbox 0x15 = 0x59 -sbox 0x16 = 0x47 -sbox 0x17 = 0xF0 - -sbox 0x18 = 0xAD -sbox 0x19 = 0xD4 -sbox 0x1a = 0xA2 -sbox 0x1b = 0xAF -sbox 0x1c = 0x9C -sbox 0x1d = 0xA4 -sbox 0x1e = 0x72 -sbox 0x1f = 0xC0 - -sbox 0x20 = 0xB7 -sbox 0x21 = 0xFD -sbox 0x22 = 0x93 -sbox 0x23 = 0x26 -sbox 0x24 = 0x36 -sbox 0x25 = 0x3F -sbox 0x26 = 0xF7 -sbox 0x27 = 0xCC - -sbox 0x28 = 0x34 -sbox 0x29 = 0xA5 -sbox 0x2a = 0xE5 -sbox 0x2b = 0xF1 -sbox 0x2c = 0x71 -sbox 0x2d = 0xD8 -sbox 0x2e = 0x31 -sbox 0x2f = 0x15 - -sbox 0x30 = 0x04 -sbox 0x31 = 0xC7 -sbox 0x32 = 0x23 -sbox 0x33 = 0xC3 -sbox 0x34 = 0x18 -sbox 0x35 = 0x96 -sbox 0x36 = 0x05 -sbox 0x37 = 0x9A - -sbox 0x38 = 0x07 -sbox 0x39 = 0x12 -sbox 0x3a = 0x80 -sbox 0x3b = 0xE2 -sbox 0x3c = 0xEB -sbox 0x3d = 0x27 -sbox 0x3e = 0xB2 -sbox 0x3f = 0x75 - -sbox 0x40 = 0x09 -sbox 0x41 = 0x83 -sbox 0x42 = 0x2C -sbox 0x43 = 0x1A -sbox 0x44 = 0x1B -sbox 0x45 = 0x6E -sbox 0x46 = 0x5A -sbox 0x47 = 0xA0 - -sbox 0x48 = 0x52 -sbox 0x49 = 0x3B -sbox 0x4a = 0xD6 -sbox 0x4b = 0xB3 -sbox 0x4c = 0x29 -sbox 0x4d = 0xE3 -sbox 0x4e = 0x2F -sbox 0x4f = 0x84 - -sbox 0x50 = 0x53 -sbox 0x51 = 0xD1 -sbox 0x52 = 0x00 -sbox 0x53 = 0xED -sbox 0x54 = 0x20 -sbox 0x55 = 0xFC -sbox 0x56 = 0xB1 -sbox 0x57 = 0x5B - -sbox 0x58 = 0x6A -sbox 0x59 = 0xCB -sbox 0x5a = 0xBE -sbox 0x5b = 0x39 -sbox 0x5c = 0x4A -sbox 0x5d = 0x4C -sbox 0x5e = 0x58 -sbox 0x5f = 0xCF - -sbox 0x60 = 0xD0 -sbox 0x61 = 0xEF -sbox 0x62 = 0xAA -sbox 0x63 = 0xFB -sbox 0x64 = 0x43 -sbox 0x65 = 0x4D -sbox 0x66 = 0x33 -sbox 0x67 = 0x85 - -sbox 0x68 = 0x45 -sbox 0x69 = 0xF9 -sbox 0x6a = 0x02 -sbox 0x6b = 0x7F -sbox 0x6c = 0x50 -sbox 0x6d = 0x3C -sbox 0x6e = 0x9F -sbox 0x6f = 0xA8 - -sbox 0x70 = 0x51 -sbox 0x71 = 0xA3 -sbox 0x72 = 0x40 -sbox 0x73 = 0x8F -sbox 0x74 = 0x92 -sbox 0x75 = 0x9D -sbox 0x76 = 0x38 -sbox 0x77 = 0xF5 - -sbox 0x78 = 0xBC -sbox 0x79 = 0xB6 -sbox 0x7a = 0xDA -sbox 0x7b = 0x21 -sbox 0x7c = 0x10 -sbox 0x7d = 0xFF -sbox 0x7e = 0xF3 -sbox 0x7f = 0xD2 - -sbox 0x80 = 0xCD -sbox 0x81 = 0x0C -sbox 0x82 = 0x13 -sbox 0x83 = 0xEC -sbox 0x84 = 0x5F -sbox 0x85 = 0x97 -sbox 0x86 = 0x44 -sbox 0x87 = 0x17 - -sbox 0x88 = 0xC4 -sbox 0x89 = 0xA7 -sbox 0x8a = 0x7E -sbox 0x8b = 0x3D -sbox 0x8c = 0x64 -sbox 0x8d = 0x5D -sbox 0x8e = 0x19 -sbox 0x8f = 0x73 - -sbox 0x90 = 0x60 -sbox 0x91 = 0x81 -sbox 0x92 = 0x4F -sbox 0x93 = 0xDC -sbox 0x94 = 0x22 -sbox 0x95 = 0x2A -sbox 0x96 = 0x90 -sbox 0x97 = 0x88 - -sbox 0x98 = 0x46 -sbox 0x99 = 0xEE -sbox 0x9a = 0xB8 -sbox 0x9b = 0x14 -sbox 0x9c = 0xDE -sbox 0x9d = 0x5E -sbox 0x9e = 0x0B -sbox 0x9f = 0xDB - -sbox 0xa0 = 0xE0 -sbox 0xa1 = 0x32 -sbox 0xa2 = 0x3A -sbox 0xa3 = 0x0A -sbox 0xa4 = 0x49 -sbox 0xa5 = 0x06 -sbox 0xa6 = 0x24 -sbox 0xa7 = 0x5C - -sbox 0xa8 = 0xC2 -sbox 0xa9 = 0xD3 -sbox 0xaa = 0xAC -sbox 0xab = 0x62 -sbox 0xac = 0x91 -sbox 0xad = 0x95 -sbox 0xae = 0xE4 -sbox 0xaf = 0x79 - -sbox 0xb0 = 0xE7 -sbox 0xb1 = 0xC8 -sbox 0xb2 = 0x37 -sbox 0xb3 = 0x6D -sbox 0xb4 = 0x8D -sbox 0xb5 = 0xD5 -sbox 0xb6 = 0x4E -sbox 0xb7 = 0xA9 - -sbox 0xb8 = 0x6C -sbox 0xb9 = 0x56 -sbox 0xba = 0xF4 -sbox 0xbb = 0xEA -sbox 0xbc = 0x65 -sbox 0xbd = 0x7A -sbox 0xbe = 0xAE -sbox 0xbf = 0x08 - -sbox 0xc0 = 0xBA -sbox 0xc1 = 0x78 -sbox 0xc2 = 0x25 -sbox 0xc3 = 0x2E -sbox 0xc4 = 0x1C -sbox 0xc5 = 0xA6 -sbox 0xc6 = 0xB4 -sbox 0xc7 = 0xC6 - -sbox 0xc8 = 0xE8 -sbox 0xc9 = 0xDD -sbox 0xca = 0x74 -sbox 0xcb = 0x1F -sbox 0xcc = 0x4B -sbox 0xcd = 0xBD -sbox 0xce = 0x8B -sbox 0xcf = 0x8A - -sbox 0xd0 = 0x70 -sbox 0xd1 = 0x3E -sbox 0xd2 = 0xB5 -sbox 0xd3 = 0x66 -sbox 0xd4 = 0x48 -sbox 0xd5 = 0x03 -sbox 0xd6 = 0xF6 -sbox 0xd7 = 0x0E - -sbox 0xd8 = 0x61 -sbox 0xd9 = 0x35 -sbox 0xda = 0x57 -sbox 0xdb = 0xB9 -sbox 0xdc = 0x86 -sbox 0xdd = 0xC1 -sbox 0xde = 0x1D -sbox 0xdf = 0x9E - -sbox 0xe0 = 0xE1 -sbox 0xe1 = 0xF8 -sbox 0xe2 = 0x98 -sbox 0xe3 = 0x11 -sbox 0xe4 = 0x69 -sbox 0xe5 = 0xD9 -sbox 0xe6 = 0x8E -sbox 0xe7 = 0x94 - -sbox 0xe8 = 0x9B -sbox 0xe9 = 0x1E -sbox 0xea = 0x87 -sbox 0xeb = 0xE9 -sbox 0xec = 0xCE -sbox 0xed = 0x55 -sbox 0xee = 0x28 -sbox 0xef = 0xDF - -sbox 0xf0 = 0x8C -sbox 0xf1 = 0xA1 -sbox 0xf2 = 0x89 -sbox 0xf3 = 0x0D -sbox 0xf4 = 0xBF -sbox 0xf5 = 0xE6 -sbox 0xf6 = 0x42 -sbox 0xf7 = 0x68 - -sbox 0xf8 = 0x41 -sbox 0xf9 = 0x99 -sbox 0xfa = 0x2D -sbox 0xfb = 0x0F -sbox 0xfc = 0xB0 -sbox 0xfd = 0x54 -sbox 0xfe = 0xBB -sbox 0xff = 0x16 - -{----} - -sboxRev 0x63 = 0x00 -sboxRev 0x7C = 0x01 -sboxRev 0x77 = 0x02 -sboxRev 0x7B = 0x03 -sboxRev 0xF2 = 0x04 -sboxRev 0x6B = 0x05 -sboxRev 0x6F = 0x06 -sboxRev 0xC5 = 0x07 - -sboxRev 0x30 = 0x08 -sboxRev 0x01 = 0x09 -sboxRev 0x67 = 0x0a -sboxRev 0x2B = 0x0b -sboxRev 0xFE = 0x0c -sboxRev 0xD7 = 0x0d -sboxRev 0xAB = 0x0e -sboxRev 0x76 = 0x0f - -sboxRev 0xCA = 0x10 -sboxRev 0x82 = 0x11 -sboxRev 0xC9 = 0x12 -sboxRev 0x7D = 0x13 -sboxRev 0xFA = 0x14 -sboxRev 0x59 = 0x15 -sboxRev 0x47 = 0x16 -sboxRev 0xF0 = 0x17 - -sboxRev 0xAD = 0x18 -sboxRev 0xD4 = 0x19 -sboxRev 0xA2 = 0x1a -sboxRev 0xAF = 0x1b -sboxRev 0x9C = 0x1c -sboxRev 0xA4 = 0x1d -sboxRev 0x72 = 0x1e -sboxRev 0xC0 = 0x1f - -sboxRev 0xB7 = 0x20 -sboxRev 0xFD = 0x21 -sboxRev 0x93 = 0x22 -sboxRev 0x26 = 0x23 -sboxRev 0x36 = 0x24 -sboxRev 0x3F = 0x25 -sboxRev 0xF7 = 0x26 -sboxRev 0xCC = 0x27 - -sboxRev 0x34 = 0x28 -sboxRev 0xA5 = 0x29 -sboxRev 0xE5 = 0x2a -sboxRev 0xF1 = 0x2b -sboxRev 0x71 = 0x2c -sboxRev 0xD8 = 0x2d -sboxRev 0x31 = 0x2e -sboxRev 0x15 = 0x2f - -sboxRev 0x04 = 0x30 -sboxRev 0xC7 = 0x31 -sboxRev 0x23 = 0x32 -sboxRev 0xC3 = 0x33 -sboxRev 0x18 = 0x34 -sboxRev 0x96 = 0x35 -sboxRev 0x05 = 0x36 -sboxRev 0x9A = 0x37 - -sboxRev 0x07 = 0x38 -sboxRev 0x12 = 0x39 -sboxRev 0x80 = 0x3a -sboxRev 0xE2 = 0x3b -sboxRev 0xEB = 0x3c -sboxRev 0x27 = 0x3d -sboxRev 0xB2 = 0x3e -sboxRev 0x75 = 0x3f - -sboxRev 0x09 = 0x40 -sboxRev 0x83 = 0x41 -sboxRev 0x2C = 0x42 -sboxRev 0x1A = 0x43 -sboxRev 0x1B = 0x44 -sboxRev 0x6E = 0x45 -sboxRev 0x5A = 0x46 -sboxRev 0xA0 = 0x47 - -sboxRev 0x52 = 0x48 -sboxRev 0x3B = 0x49 -sboxRev 0xD6 = 0x4a -sboxRev 0xB3 = 0x4b -sboxRev 0x29 = 0x4c -sboxRev 0xE3 = 0x4d -sboxRev 0x2F = 0x4e -sboxRev 0x84 = 0x4f - -sboxRev 0x53 = 0x50 -sboxRev 0xD1 = 0x51 -sboxRev 0x00 = 0x52 -sboxRev 0xED = 0x53 -sboxRev 0x20 = 0x54 -sboxRev 0xFC = 0x55 -sboxRev 0xB1 = 0x56 -sboxRev 0x5B = 0x57 - -sboxRev 0x6A = 0x58 -sboxRev 0xCB = 0x59 -sboxRev 0xBE = 0x5a -sboxRev 0x39 = 0x5b -sboxRev 0x4A = 0x5c -sboxRev 0x4C = 0x5d -sboxRev 0x58 = 0x5e -sboxRev 0xCF = 0x5f - -sboxRev 0xD0 = 0x60 -sboxRev 0xEF = 0x61 -sboxRev 0xAA = 0x62 -sboxRev 0xFB = 0x63 -sboxRev 0x43 = 0x64 -sboxRev 0x4D = 0x65 -sboxRev 0x33 = 0x66 -sboxRev 0x85 = 0x67 - -sboxRev 0x45 = 0x68 -sboxRev 0xF9 = 0x69 -sboxRev 0x02 = 0x6a -sboxRev 0x7F = 0x6b -sboxRev 0x50 = 0x6c -sboxRev 0x3C = 0x6d -sboxRev 0x9F = 0x6e -sboxRev 0xA8 = 0x6f - -sboxRev 0x51 = 0x70 -sboxRev 0xA3 = 0x71 -sboxRev 0x40 = 0x72 -sboxRev 0x8F = 0x73 -sboxRev 0x92 = 0x74 -sboxRev 0x9D = 0x75 -sboxRev 0x38 = 0x76 -sboxRev 0xF5 = 0x77 - -sboxRev 0xBC = 0x78 -sboxRev 0xB6 = 0x79 -sboxRev 0xDA = 0x7a -sboxRev 0x21 = 0x7b -sboxRev 0x10 = 0x7c -sboxRev 0xFF = 0x7d -sboxRev 0xF3 = 0x7e -sboxRev 0xD2 = 0x7f - -sboxRev 0xCD = 0x80 -sboxRev 0x0C = 0x81 -sboxRev 0x13 = 0x82 -sboxRev 0xEC = 0x83 -sboxRev 0x5F = 0x84 -sboxRev 0x97 = 0x85 -sboxRev 0x44 = 0x86 -sboxRev 0x17 = 0x87 - -sboxRev 0xC4 = 0x88 -sboxRev 0xA7 = 0x89 -sboxRev 0x7E = 0x8a -sboxRev 0x3D = 0x8b -sboxRev 0x64 = 0x8c -sboxRev 0x5D = 0x8d -sboxRev 0x19 = 0x8e -sboxRev 0x73 = 0x8f - -sboxRev 0x60 = 0x90 -sboxRev 0x81 = 0x91 -sboxRev 0x4F = 0x92 -sboxRev 0xDC = 0x93 -sboxRev 0x22 = 0x94 -sboxRev 0x2A = 0x95 -sboxRev 0x90 = 0x96 -sboxRev 0x88 = 0x97 - -sboxRev 0x46 = 0x98 -sboxRev 0xEE = 0x99 -sboxRev 0xB8 = 0x9a -sboxRev 0x14 = 0x9b -sboxRev 0xDE = 0x9c -sboxRev 0x5E = 0x9d -sboxRev 0x0B = 0x9e -sboxRev 0xDB = 0x9f - -sboxRev 0xE0 = 0xa0 -sboxRev 0x32 = 0xa1 -sboxRev 0x3A = 0xa2 -sboxRev 0x0A = 0xa3 -sboxRev 0x49 = 0xa4 -sboxRev 0x06 = 0xa5 -sboxRev 0x24 = 0xa6 -sboxRev 0x5C = 0xa7 - -sboxRev 0xC2 = 0xa8 -sboxRev 0xD3 = 0xa9 -sboxRev 0xAC = 0xaa -sboxRev 0x62 = 0xab -sboxRev 0x91 = 0xac -sboxRev 0x95 = 0xad -sboxRev 0xE4 = 0xae -sboxRev 0x79 = 0xaf - -sboxRev 0xE7 = 0xb0 -sboxRev 0xC8 = 0xb1 -sboxRev 0x37 = 0xb2 -sboxRev 0x6D = 0xb3 -sboxRev 0x8D = 0xb4 -sboxRev 0xD5 = 0xb5 -sboxRev 0x4E = 0xb6 -sboxRev 0xA9 = 0xb7 - -sboxRev 0x6C = 0xb8 -sboxRev 0x56 = 0xb9 -sboxRev 0xF4 = 0xba -sboxRev 0xEA = 0xbb -sboxRev 0x65 = 0xbc -sboxRev 0x7A = 0xbd -sboxRev 0xAE = 0xbe -sboxRev 0x08 = 0xbf - -sboxRev 0xBA = 0xc0 -sboxRev 0x78 = 0xc1 -sboxRev 0x25 = 0xc2 -sboxRev 0x2E = 0xc3 -sboxRev 0x1C = 0xc4 -sboxRev 0xA6 = 0xc5 -sboxRev 0xB4 = 0xc6 -sboxRev 0xC6 = 0xc7 - -sboxRev 0xE8 = 0xc8 -sboxRev 0xDD = 0xc9 -sboxRev 0x74 = 0xca -sboxRev 0x1F = 0xcb -sboxRev 0x4B = 0xcc -sboxRev 0xBD = 0xcd -sboxRev 0x8B = 0xce -sboxRev 0x8A = 0xcf - -sboxRev 0x70 = 0xd0 -sboxRev 0x3E = 0xd1 -sboxRev 0xB5 = 0xd2 -sboxRev 0x66 = 0xd3 -sboxRev 0x48 = 0xd4 -sboxRev 0x03 = 0xd5 -sboxRev 0xF6 = 0xd6 -sboxRev 0x0E = 0xd7 - -sboxRev 0x61 = 0xd8 -sboxRev 0x35 = 0xd9 -sboxRev 0x57 = 0xda -sboxRev 0xB9 = 0xdb -sboxRev 0x86 = 0xdc -sboxRev 0xC1 = 0xdd -sboxRev 0x1D = 0xde -sboxRev 0x9E = 0xdf - -sboxRev 0xE1 = 0xe0 -sboxRev 0xF8 = 0xe1 -sboxRev 0x98 = 0xe2 -sboxRev 0x11 = 0xe3 -sboxRev 0x69 = 0xe4 -sboxRev 0xD9 = 0xe5 -sboxRev 0x8E = 0xe6 -sboxRev 0x94 = 0xe7 - -sboxRev 0x9B = 0xe8 -sboxRev 0x1E = 0xe9 -sboxRev 0x87 = 0xea -sboxRev 0xE9 = 0xeb -sboxRev 0xCE = 0xec -sboxRev 0x55 = 0xed -sboxRev 0x28 = 0xee -sboxRev 0xDF = 0xef - -sboxRev 0x8C = 0xf0 -sboxRev 0xA1 = 0xf1 -sboxRev 0x89 = 0xf2 -sboxRev 0x0D = 0xf3 -sboxRev 0xBF = 0xf4 -sboxRev 0xE6 = 0xf5 -sboxRev 0x42 = 0xf6 -sboxRev 0x68 = 0xf7 - -sboxRev 0x41 = 0xf8 -sboxRev 0x99 = 0xf9 -sboxRev 0x2D = 0xfa -sboxRev 0x0F = 0xfb -sboxRev 0xB0 = 0xfc -sboxRev 0x54 = 0xfd -sboxRev 0xBB = 0xfe -sboxRev 0x16 = 0xff - -xtime :: Word32 -> Word32 -xtime x = b - where a = x `shiftL` 1 - b = if a .&. (0x0100) == 0 then a else a `xor` 0x11b - -xtimeX2 :: Word32 -> Word32 ---xtimeX2 = xtime . xtime -xtimeX2 x = c - where a = x `shiftL` 2 - b = if a .&. (0x0200) == 0 then a else a `xor` 0x236 - c = if b .&. (0x0100) == 0 then b else b `xor` 0x11b - -xtimeX3 :: Word32 -> Word32 ---xtimeX3 = xtime . xtime . xtime -xtimeX3 x = d - where a = x `shiftL` 3 - b = if a .&. (0x0400) == 0 then a else a `xor` 0x46c - c = if b .&. (0x0200) == 0 then b else b `xor` 0x236 - d = if c .&. (0x0100) == 0 then c else c `xor` 0x11b - -xtime03 :: Word32 -> Word32 -xtime03 x = x `xor` (xtime x) - -xtime0e :: Word32 -> Word32 -xtime0e x = xtime (x `xor` (xtime (x `xor` (xtime x)))) - -xtime09 :: Word32 -> Word32 -xtime09 x = x `xor` (xtimeX3 x) - -xtime0d :: Word32 -> Word32 -xtime0d x = x `xor` (xtimeX2 (x `xor` (xtime x))) - -xtime0b :: Word32 -> Word32 -xtime0b x = x `xor` (xtime (x `xor` (xtimeX2 x))) - -generateKey :: Int -> Int -> Word32 -> Word32 -> Word32 -generateKey nk i wIminus1 wIminusNk = - (temp' `xor` wIminusNk) - where temp' = - if (i `mod` nk) == 0 then (subword(rotword temp)) `xor` rcon - else if (nk > 6) && ((i `mod` nk) == 4) then subword temp - else temp - temp = wIminus1 - subword :: Word32 -> Word32 - subword w = (a `shiftL` 24) .|. (b `shiftL` 16) .|. - (c `shiftL` 8) .|. d - where a = sbox ((w `shiftR` 24) .&. 0xff) - b = sbox ((w `shiftR` 16) .&. 0xff) - c = sbox ((w `shiftR` 8) .&. 0xff) - d = sbox ( w .&. 0xff) - rotword :: Word32 -> Word32 - rotword w = w `rotateL` 8 - rcon :: Word32 - rcon = ((fromIntegral rconMSB)::Word32) `shiftL` 24 - rconMSB = (iterate xtime 0x01) !! ((i `div` nk) - 1) - -wordify :: [Octet] -> [Word32] -wordify [] = [] -wordify octets = firstWord:otherWords - where - (firstWord, otherOctets) = getWord32 octets - otherWords = wordify otherOctets - -generateKeys :: Int -> Int -> [Octet] -> [Word32] -generateKeys nr nk mainKey = - -- assert ((nk * 4) == length mainKey) $ - (take (4 * (nr + 1)) xs) - where - xs = (wordify mainKey) ++ (zipWith3 (generateKey nk) - (drop nk [0,1..]) - (drop (nk - 1) xs) - xs - ) - -subBytes :: State -> State -subBytes (State (s00, s01, s02, s03) - (s10, s11, s12, s13) - (s20, s21, s22, s23) - (s30, s31, s32, s33)) = - State (sbox s00, sbox s01, sbox s02, sbox s03) - (sbox s10, sbox s11, sbox s12, sbox s13) - (sbox s20, sbox s21, sbox s22, sbox s23) - (sbox s30, sbox s31, sbox s32, sbox s33) - -subBytesRev :: State -> State -subBytesRev (State (s00, s01, s02, s03) - (s10, s11, s12, s13) - (s20, s21, s22, s23) - (s30, s31, s32, s33)) = - State (sboxRev s00, sboxRev s01, sboxRev s02, sboxRev s03) - (sboxRev s10, sboxRev s11, sboxRev s12, sboxRev s13) - (sboxRev s20, sboxRev s21, sboxRev s22, sboxRev s23) - (sboxRev s30, sboxRev s31, sboxRev s32, sboxRev s33) - -shiftRows :: State -> State -shiftRows (State (s00, s01, s02, s03) - (s10, s11, s12, s13) - (s20, s21, s22, s23) - (s30, s31, s32, s33)) = - State (s00, s01, s02, s03) - (s11, s12, s13, s10) - (s22, s23, s20, s21) - (s33, s30, s31, s32) - -shiftRowsRev :: State -> State -shiftRowsRev (State (s00, s01, s02, s03) - (s10, s11, s12, s13) - (s20, s21, s22, s23) - (s30, s31, s32, s33)) = - State (s00, s01, s02, s03) - (s13, s10, s11, s12) - (s22, s23, s20, s21) - (s31, s32, s33, s30) - -mixColumn:: (Word32, Word32, Word32, Word32) -> (Word32, Word32, Word32, Word32) -mixColumn (s0,s1,s2,s3) = - ((xtime s0) `xor` (xtime03 s1) `xor` s2 `xor` s3 , - s0 `xor` (xtime s1) `xor` (xtime03 s2) `xor` s3 , - s0 `xor` s1 `xor` (xtime s2) `xor` (xtime03 s3), - (xtime03 s0) `xor` s1 `xor` s2 `xor` (xtime s3)) - -mixColumns :: State -> State -mixColumns (State (s00, s01, s02, s03) - (s10, s11, s12, s13) - (s20, s21, s22, s23) - (s30, s31, s32, s33)) = - State (r00, r01, r02, r03) - (r10, r11, r12, r13) - (r20, r21, r22, r23) - (r30, r31, r32, r33) - where (r00, r10, r20, r30) = mixColumn (s00, s10, s20, s30) - (r01, r11, r21, r31) = mixColumn (s01, s11, s21, s31) - (r02, r12, r22, r32) = mixColumn (s02, s12, s22, s32) - (r03, r13, r23, r33) = mixColumn (s03, s13, s23, s33) - -mixColumnRev :: (Word32, Word32, Word32, Word32) - -> (Word32, Word32, Word32, Word32) -mixColumnRev (s0,s1,s2,s3) = - ((xtime0e s0) `xor` (xtime0b s1) `xor` (xtime0d s2) `xor` (xtime09 s3), - (xtime09 s0) `xor` (xtime0e s1) `xor` (xtime0b s2) `xor` (xtime0d s3), - (xtime0d s0) `xor` (xtime09 s1) `xor` (xtime0e s2) `xor` (xtime0b s3), - (xtime0b s0) `xor` (xtime0d s1) `xor` (xtime09 s2) `xor` (xtime0e s3)) - -mixColumnsRev :: State -> State -mixColumnsRev (State (s00, s01, s02, s03) - (s10, s11, s12, s13) - (s20, s21, s22, s23) - (s30, s31, s32, s33)) = - State (r00, r01, r02, r03) - (r10, r11, r12, r13) - (r20, r21, r22, r23) - (r30, r31, r32, r33) - where (r00, r10, r20, r30) = mixColumnRev (s00, s10, s20, s30) - (r01, r11, r21, r31) = mixColumnRev (s01, s11, s21, s31) - (r02, r12, r22, r32) = mixColumnRev (s02, s12, s22, s32) - (r03, r13, r23, r33) = mixColumnRev (s03, s13, s23, s33) - -addRoundKey :: State -> State -> State -addRoundKey (State (k00, k01, k02, k03) - (k10, k11, k12, k13) - (k20, k21, k22, k23) - (k30, k31, k32, k33)) - (State (s00, s01, s02, s03) - (s10, s11, s12, s13) - (s20, s21, s22, s23) - (s30, s31, s32, s33)) = - State (s00 `xor` k00, s01 `xor` k01, s02 `xor` k02, s03 `xor` k03) - (s10 `xor` k10, s11 `xor` k11, s12 `xor` k12, s13 `xor` k13) - (s20 `xor` k20, s21 `xor` k21, s22 `xor` k22, s23 `xor` k23) - (s30 `xor` k30, s31 `xor` k31, s32 `xor` k32, s33 `xor` k33) - -genAddRoundKey :: [Word32] -> [State -> State] -genAddRoundKey [] = [] -genAddRoundKey (a:b:c:d:ks) = (addRoundKey k):(genAddRoundKey ks) - where k = State (fromIntegral s00, fromIntegral s01, - fromIntegral s02, fromIntegral s03) - (fromIntegral s10, fromIntegral s11, - fromIntegral s12, fromIntegral s13) - (fromIntegral s20, fromIntegral s21, - fromIntegral s22, fromIntegral s23) - (fromIntegral s30, fromIntegral s31, - fromIntegral s32, fromIntegral s33) - [s00, s10, s20, s30] = putWord32 a - [s01, s11, s21, s31] = putWord32 b - [s02, s12, s22, s32] = putWord32 c - [s03, s13, s23, s33] = putWord32 d - -getWord32 :: [Octet] -> (Word32, [Octet]) -getWord32 (a:b:c:d:xs) = (x, xs) - where - x = ((fromIntegral a) `shiftL` 24) .|. - ((fromIntegral b) `shiftL` 16) .|. - ((fromIntegral c) `shiftL` 8) .|. - ((fromIntegral d) ) - -putWord32 :: Word32 -> [Octet] ---a bit slower putWord32 x = map fromIntegral [a,b,c,d] -putWord32 x = [fromIntegral a, fromIntegral b, fromIntegral c, fromIntegral d] - where - a = (x `shiftR` 24) - b = (x `shiftR` 16) .&. 255 - c = (x `shiftR` 8) .&. 255 - d = (x ) .&. 255 - -{- -testGenerateKeys128 :: Test -testGenerateKeys128 = - let key = [0x2b, 0x7e, 0x15, 0x16, - 0x28, 0xae, 0xd2, 0xa6, - 0xab, 0xf7, 0x15, 0x88, - 0x09, 0xcf, 0x4f, 0x3c] - expected = [0x2b7e1516, 0x28aed2a6, 0xabf71588, 0x09cf4f3c, - 0xa0fafe17, 0x88542cb1, 0x23a33939, 0x2a6c7605, - 0xf2c295f2, 0x7a96b943, 0x5935807a, 0x7359f67f, - 0x3d80477d, 0x4716fe3e, 0x1e237e44, 0x6d7a883b, - 0xef44a541, 0xa8525b7f, 0xb671253b, 0xdb0bad00, - 0xd4d1c6f8, 0x7c839d87, 0xcaf2b8bc, 0x11f915bc, - 0x6d88a37a, 0x110b3efd, 0xdbf98641, 0xca0093fd, - 0x4e54f70e, 0x5f5fc9f3, 0x84a64fb2, 0x4ea6dc4f, - 0xead27321, 0xb58dbad2, 0x312bf560, 0x7f8d292f, - 0xac7766f3, 0x19fadc21, 0x28d12941, 0x575c006e, - 0xd014f9a8, 0xc9ee2589, 0xe13f0cc8, 0xb6630ca6 - ] - in TestCase (do - assertEqual "" expected (generateKeys 10 4 key) - ) - - -testGenerateKeys192 :: Test -testGenerateKeys192 = - let key = [0x8e, 0x73, 0xb0, 0xf7, - 0xda, 0x0e, 0x64, 0x52, - 0xc8, 0x10, 0xf3, 0x2b, - 0x80, 0x90, 0x79, 0xe5, - 0x62, 0xf8, 0xea, 0xd2, - 0x52, 0x2c, 0x6b, 0x7b] - expected = [0x8e73b0f7, 0xda0e6452, 0xc810f32b, 0x809079e5, - 0x62f8ead2, 0x522c6b7b, 0xfe0c91f7, 0x2402f5a5, - 0xec12068e, 0x6c827f6b, 0x0e7a95b9, 0x5c56fec2, - 0x4db7b4bd, 0x69b54118, 0x85a74796, 0xe92538fd, - 0xe75fad44, 0xbb095386, 0x485af057, 0x21efb14f - ] - in TestCase (do - assertEqual "" expected - (take (length expected) (generateKeys 12 6 key)) - ) - -testGenerateKeys256 :: Test -testGenerateKeys256 = - let key = [0x60, 0x3d, 0xeb, 0x10, - 0x15, 0xca, 0x71, 0xbe, - 0x2b, 0x73, 0xae, 0xf0, - 0x85, 0x7d, 0x77, 0x81, - 0x1f, 0x35, 0x2c, 0x07, - 0x3b, 0x61, 0x08, 0xd7, - 0x2d, 0x98, 0x10, 0xa3, - 0x09, 0x14, 0xdf, 0xf4] - expected = [0x603deb10, 0x15ca71be, 0x2b73aef0, 0x857d7781, - 0x1f352c07, 0x3b6108d7, 0x2d9810a3, 0x0914dff4, - 0x9ba35411, 0x8e6925af, 0xa51a8b5f, 0x2067fcde, - 0xa8b09c1a, 0x93d194cd, 0xbe49846e, 0xb75d5b9a, - 0xd59aecb8, 0x5bf3c917, 0xfee94248, 0xde8ebe96 - ] - in TestCase (do - assertEqual "" expected - (take (length expected) (generateKeys 14 8 key)) - ) - -testAes128 :: Test -testAes128 = - let key = [0x2b, 0x7e, 0x15, 0x16, - 0x28, 0xae, 0xd2, 0xa6, - 0xab, 0xf7, 0x15, 0x88, - 0x09, 0xcf, 0x4f, 0x3c] - input = [0x32, 0x43, 0xf6, 0xa8, - 0x88, 0x5a, 0x30, 0x8d, - 0x31, 0x31, 0x98, 0xa2, - 0xe0, 0x37, 0x07, 0x34] - output = [0x39, 0x25, 0x84, 0x1d, - 0x02, 0xdc, 0x09, 0xfb, - 0xdc, 0x11, 0x85, 0x97, - 0x19, 0x6a, 0x0b, 0x32] - in TestCase (do - assertEqual "encrypt test" output (aes128Encrypt key input) - assertEqual "encrypt/decrypt test" input - (aes128Decrypt key (aes128Encrypt key input)) - ) - -testAesRandom :: Test -testAesRandom = - TestCase (do - key128 <- getRandomOctets 16 - key192 <- getRandomOctets 24 - key256 <- getRandomOctets 32 - msg <- getRandomOctets 16 - assertEqual "aes128" msg - (aes128Decrypt key128 (aes128Encrypt key128 msg)) - assertEqual "aes192" msg - (aes192Decrypt key192 (aes192Encrypt key192 msg)) - assertEqual "aes256" msg - (aes256Decrypt key256 (aes256Encrypt key256 msg)) - ) - --- | HUnit tests -tests :: Test -tests = TestList [ - TestLabel "testGenerateKeys128" testGenerateKeys128, - TestLabel "testGenerateKeys192" testGenerateKeys192, - TestLabel "testGenerateKeys256" testGenerateKeys256, - TestLabel "testAes128" testAes128, - TestLabel "testAesRandom" testAesRandom - ] --} - diff --git a/Codec/Encryption/Blowfish.hs b/Codec/Encryption/Blowfish.hs deleted file mode 100644 --- a/Codec/Encryption/Blowfish.hs +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Coded.Encryption.Blowfish --- Copyright : (c) Dominic Steinitz 2003 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : non-portable --- --- Takes the Blowfish module supplied by Doug Hoyte and wraps it so it can --- used with the standard modes. --- ------------------------------------------------------------------------------ - -module Codec.Encryption.Blowfish - ( - -- * Function Types - encrypt, - decrypt - ) where - -import Data.Bits -import Data.Word -import Data.Char -import Codec.Utils -import Codec.Encryption.BlowfishAux - --- * Basic Blowfish Encryption - --- | Basic Blowfish encryption which takes a key and a block of plaintext --- and returns the encrypted block of ciphertext according to the standard. --- Typical keys are Word8, Word16, Word32, Word64, Word128. See --- . - -encrypt :: (Integral a) => a -> Word64 -> Word64 -encrypt k p = mergeWord32 (lo,hi) where - lo = head e - hi = head $ tail e - e = bfEnc (bfMakeKey (map (chr . fromIntegral) (toOctets 256 k))) [lo',hi'] - (lo',hi') = (splitZord64 p) - --- | Basic Blowfish decryption which takes a key and a block of ciphertext --- and returns the decrypted block of plaintext. - -decrypt :: (Integral a) => a -> Word64 -> Word64 -decrypt k p = mergeWord32 (lo,hi) where - lo = head d - hi = head $ tail d - d = bfDec (bfMakeKey (map (chr . fromIntegral) (toOctets 256 k))) [lo',hi'] - (lo',hi') = splitZord64 p - -splitZord64 :: Word64 -> (Word32,Word32) -splitZord64 x = (fromIntegral (shiftR (x .&. 0xffffffff00000000) 32), - fromIntegral (x .&. 0x00000000ffffffff)) - -mergeWord32 :: (Word32,Word32) -> Word64 -mergeWord32 (lo,hi) = shift (fromIntegral lo) 32 + fromIntegral hi diff --git a/Codec/Encryption/BlowfishAux.hs b/Codec/Encryption/BlowfishAux.hs deleted file mode 100644 --- a/Codec/Encryption/BlowfishAux.hs +++ /dev/null @@ -1,282 +0,0 @@ --- BlowfishAux.hs (C) 2002 HardCore SoftWare, Doug Hoyte --- --- Doug has kindly agreed to release this under BSD. --- --- Haskell implementation of Bruce Schneier's blowfish encryption algorithm. --- This implementation uses 16 rounds and produces the same ciphertext as --- the OpenBSD and Paul Kocher 16-round implementations. --- --- The function bfMakeKey should be passed a list of Chars. These represent --- the key. It will return a datatype called "BF", which contains the --- initialized key information. --- --- The function bfEnc is passed a BF datatype representing the key and a --- list of 2 Word32s (the plaintext). It returns a list of 2 Word32s --- (the ciphertext). --- --- The function bfDec is passed a BF datatype representing the key and a list --- of 2 Word32s (the ciphertext) and a BF datatype representing the key. It --- returns a list of 2 Word32s (the plaintext). - -module Codec.Encryption.BlowfishAux - (bfMakeKey, - bfEnc, - bfDec) where - -import Data.Array -import Data.Bits -import Data.Word -import Data.Char - -type Pbox = Array Word32 Word32 -type Sbox = Array Word32 Word32 - -data BF = BF Pbox Sbox Sbox Sbox Sbox - - - -bfEnc :: BF -> [Word32] -> [Word32] -bfEnc a b = aux a b 0 - where - aux :: BF -> [Word32] -> Word32 -> [Word32] - aux bs@(BF p s0 s1 s2 s3) (l:r:[]) 16 = (r `xor` p!17):(l `xor` p!16):[] - aux bs@(BF p s0 s1 s2 s3) (l:r:[]) i = aux bs (newr:newl:[]) (i+1) - where newl = l `xor` (p ! i) - newr = r `xor` (f newl) - f :: Word32 -> Word32 - f t = ((s0!a + s1!b) `xor` (s2 ! c)) + (s3 ! d) - where a = (t `shiftR` 24) - b = ((t `shiftL` 8) `shiftR` 24) - c = ((t `shiftL` 16) `shiftR` 24) - d = ((t `shiftL` 24) `shiftR` 24) - - -bfDec :: BF -> [Word32] -> [Word32] -bfDec (BF p s0 s1 s2 s3) a = bfEnc (BF (revP p) s0 s1 s2 s3) a - where revP :: Pbox -> Pbox - revP x = x//[(i, x ! (17-i)) | i <- [0..17]] - - -bfMakeKey :: [Char] -> BF -bfMakeKey [] = procKey [0,0] (BF iPbox iSbox0 iSbox1 iSbox2 iSbox3) 0 -bfMakeKey k = procKey [0,0] (BF (string2Pbox k) iSbox0 iSbox1 iSbox2 iSbox3) 0 - - -string2Pbox :: [Char] -> Pbox -string2Pbox k = array (0,17) [(fromIntegral i,xtext!!i) | i <- [0..17]] - where xtext = zipWith (xor) - (compress4 (doShift (makeTo72 (charsToWord32s k) 0) 0)) - [iPbox ! (fromIntegral i) | i <- [0..17]] - charsToWord32s [] = [] - charsToWord32s (k:ks) = (fromIntegral $ fromEnum k) : charsToWord32s ks - makeTo72 k 72 = [] - makeTo72 k i = k!!(i `mod` (length k)) : makeTo72 k (i+1) - doShift [] i = [] - doShift (w:ws) i = w `shiftL` (8*(3 - (i `mod` 4))) : doShift ws (i+1) - compress4 [] = [] - compress4 (a:b:c:d:etc) = (a .|. b .|. c .|. d) : compress4 etc - - -procKey :: [Word32] -> BF -> Word32 -> BF -procKey (l:r:[]) tpbf@(BF p s0 s1 s2 s3) 1042 = tpbf -procKey (l:r:[]) tpbf@(BF p s0 s1 s2 s3) i = procKey [nl,nr] (newbf i) (i+2) - where [nl,nr] = bfEnc tpbf [l,r] - newbf x | x < 18 = (BF (p//[(x,nl),(x+1,nr)]) s0 s1 s2 s3) - | x < 274 = (BF p (s0//[(x-18,nl),(x-17,nr)]) s1 s2 s3) - | x < 530 = (BF p s0 (s1//[(x-274,nl),(x-273,nr)]) s2 s3) - | x < 786 = (BF p s0 s1 (s2//[(x-530,nl),(x-529,nr)]) s3) - | x < 1042 = (BF p s0 s1 s2 (s3//[(x-786,nl),(x-785,nr)])) - - - ----------- INITIAL S AND P BOXES ARE THE HEXADECIMAL DIGITS OF PI ------------ - -iPbox :: Pbox -iPbox = array (0,17) (zip [0..17] - [0x243f6a88, 0x85a308d3, 0x13198a2e, 0x03707344, 0xa4093822, 0x299f31d0, - 0x082efa98, 0xec4e6c89, 0x452821e6, 0x38d01377, 0xbe5466cf, 0x34e90c6c, - 0xc0ac29b7, 0xc97c50dd, 0x3f84d5b5, 0xb5470917, 0x9216d5d9, 0x8979fb1b]) - -iSbox0 :: Sbox -iSbox0 = array (0,255) (zip [0..255] - [0xd1310ba6, 0x98dfb5ac, 0x2ffd72db, 0xd01adfb7, 0xb8e1afed, 0x6a267e96, - 0xba7c9045, 0xf12c7f99, 0x24a19947, 0xb3916cf7, 0x0801f2e2, 0x858efc16, - 0x636920d8, 0x71574e69, 0xa458fea3, 0xf4933d7e, 0x0d95748f, 0x728eb658, - 0x718bcd58, 0x82154aee, 0x7b54a41d, 0xc25a59b5, 0x9c30d539, 0x2af26013, - 0xc5d1b023, 0x286085f0, 0xca417918, 0xb8db38ef, 0x8e79dcb0, 0x603a180e, - 0x6c9e0e8b, 0xb01e8a3e, 0xd71577c1, 0xbd314b27, 0x78af2fda, 0x55605c60, - 0xe65525f3, 0xaa55ab94, 0x57489862, 0x63e81440, 0x55ca396a, 0x2aab10b6, - 0xb4cc5c34, 0x1141e8ce, 0xa15486af, 0x7c72e993, 0xb3ee1411, 0x636fbc2a, - 0x2ba9c55d, 0x741831f6, 0xce5c3e16, 0x9b87931e, 0xafd6ba33, 0x6c24cf5c, - 0x7a325381, 0x28958677, 0x3b8f4898, 0x6b4bb9af, 0xc4bfe81b, 0x66282193, - 0x61d809cc, 0xfb21a991, 0x487cac60, 0x5dec8032, 0xef845d5d, 0xe98575b1, - 0xdc262302, 0xeb651b88, 0x23893e81, 0xd396acc5, 0x0f6d6ff3, 0x83f44239, - 0x2e0b4482, 0xa4842004, 0x69c8f04a, 0x9e1f9b5e, 0x21c66842, 0xf6e96c9a, - 0x670c9c61, 0xabd388f0, 0x6a51a0d2, 0xd8542f68, 0x960fa728, 0xab5133a3, - 0x6eef0b6c, 0x137a3be4, 0xba3bf050, 0x7efb2a98, 0xa1f1651d, 0x39af0176, - 0x66ca593e, 0x82430e88, 0x8cee8619, 0x456f9fb4, 0x7d84a5c3, 0x3b8b5ebe, - 0xe06f75d8, 0x85c12073, 0x401a449f, 0x56c16aa6, 0x4ed3aa62, 0x363f7706, - 0x1bfedf72, 0x429b023d, 0x37d0d724, 0xd00a1248, 0xdb0fead3, 0x49f1c09b, - 0x075372c9, 0x80991b7b, 0x25d479d8, 0xf6e8def7, 0xe3fe501a, 0xb6794c3b, - 0x976ce0bd, 0x04c006ba, 0xc1a94fb6, 0x409f60c4, 0x5e5c9ec2, 0x196a2463, - 0x68fb6faf, 0x3e6c53b5, 0x1339b2eb, 0x3b52ec6f, 0x6dfc511f, 0x9b30952c, - 0xcc814544, 0xaf5ebd09, 0xbee3d004, 0xde334afd, 0x660f2807, 0x192e4bb3, - 0xc0cba857, 0x45c8740f, 0xd20b5f39, 0xb9d3fbdb, 0x5579c0bd, 0x1a60320a, - 0xd6a100c6, 0x402c7279, 0x679f25fe, 0xfb1fa3cc, 0x8ea5e9f8, 0xdb3222f8, - 0x3c7516df, 0xfd616b15, 0x2f501ec8, 0xad0552ab, 0x323db5fa, 0xfd238760, - 0x53317b48, 0x3e00df82, 0x9e5c57bb, 0xca6f8ca0, 0x1a87562e, 0xdf1769db, - 0xd542a8f6, 0x287effc3, 0xac6732c6, 0x8c4f5573, 0x695b27b0, 0xbbca58c8, - 0xe1ffa35d, 0xb8f011a0, 0x10fa3d98, 0xfd2183b8, 0x4afcb56c, 0x2dd1d35b, - 0x9a53e479, 0xb6f84565, 0xd28e49bc, 0x4bfb9790, 0xe1ddf2da, 0xa4cb7e33, - 0x62fb1341, 0xcee4c6e8, 0xef20cada, 0x36774c01, 0xd07e9efe, 0x2bf11fb4, - 0x95dbda4d, 0xae909198, 0xeaad8e71, 0x6b93d5a0, 0xd08ed1d0, 0xafc725e0, - 0x8e3c5b2f, 0x8e7594b7, 0x8ff6e2fb, 0xf2122b64, 0x8888b812, 0x900df01c, - 0x4fad5ea0, 0x688fc31c, 0xd1cff191, 0xb3a8c1ad, 0x2f2f2218, 0xbe0e1777, - 0xea752dfe, 0x8b021fa1, 0xe5a0cc0f, 0xb56f74e8, 0x18acf3d6, 0xce89e299, - 0xb4a84fe0, 0xfd13e0b7, 0x7cc43b81, 0xd2ada8d9, 0x165fa266, 0x80957705, - 0x93cc7314, 0x211a1477, 0xe6ad2065, 0x77b5fa86, 0xc75442f5, 0xfb9d35cf, - 0xebcdaf0c, 0x7b3e89a0, 0xd6411bd3, 0xae1e7e49, 0x00250e2d, 0x2071b35e, - 0x226800bb, 0x57b8e0af, 0x2464369b, 0xf009b91e, 0x5563911d, 0x59dfa6aa, - 0x78c14389, 0xd95a537f, 0x207d5ba2, 0x02e5b9c5, 0x83260376, 0x6295cfa9, - 0x11c81968, 0x4e734a41, 0xb3472dca, 0x7b14a94a, 0x1b510052, 0x9a532915, - 0xd60f573f, 0xbc9bc6e4, 0x2b60a476, 0x81e67400, 0x08ba6fb5, 0x571be91f, - 0xf296ec6b, 0x2a0dd915, 0xb6636521, 0xe7b9f9b6, 0xff34052e, 0xc5855664, - 0x53b02d5d, 0xa99f8fa1, 0x08ba4799, 0x6e85076a]) - -iSbox1 :: Sbox -iSbox1 = array (0,255) (zip [0..255] - [0x4b7a70e9, 0xb5b32944, 0xdb75092e, 0xc4192623, 0xad6ea6b0, 0x49a7df7d, - 0x9cee60b8, 0x8fedb266, 0xecaa8c71, 0x699a17ff, 0x5664526c, 0xc2b19ee1, - 0x193602a5, 0x75094c29, 0xa0591340, 0xe4183a3e, 0x3f54989a, 0x5b429d65, - 0x6b8fe4d6, 0x99f73fd6, 0xa1d29c07, 0xefe830f5, 0x4d2d38e6, 0xf0255dc1, - 0x4cdd2086, 0x8470eb26, 0x6382e9c6, 0x021ecc5e, 0x09686b3f, 0x3ebaefc9, - 0x3c971814, 0x6b6a70a1, 0x687f3584, 0x52a0e286, 0xb79c5305, 0xaa500737, - 0x3e07841c, 0x7fdeae5c, 0x8e7d44ec, 0x5716f2b8, 0xb03ada37, 0xf0500c0d, - 0xf01c1f04, 0x0200b3ff, 0xae0cf51a, 0x3cb574b2, 0x25837a58, 0xdc0921bd, - 0xd19113f9, 0x7ca92ff6, 0x94324773, 0x22f54701, 0x3ae5e581, 0x37c2dadc, - 0xc8b57634, 0x9af3dda7, 0xa9446146, 0x0fd0030e, 0xecc8c73e, 0xa4751e41, - 0xe238cd99, 0x3bea0e2f, 0x3280bba1, 0x183eb331, 0x4e548b38, 0x4f6db908, - 0x6f420d03, 0xf60a04bf, 0x2cb81290, 0x24977c79, 0x5679b072, 0xbcaf89af, - 0xde9a771f, 0xd9930810, 0xb38bae12, 0xdccf3f2e, 0x5512721f, 0x2e6b7124, - 0x501adde6, 0x9f84cd87, 0x7a584718, 0x7408da17, 0xbc9f9abc, 0xe94b7d8c, - 0xec7aec3a, 0xdb851dfa, 0x63094366, 0xc464c3d2, 0xef1c1847, 0x3215d908, - 0xdd433b37, 0x24c2ba16, 0x12a14d43, 0x2a65c451, 0x50940002, 0x133ae4dd, - 0x71dff89e, 0x10314e55, 0x81ac77d6, 0x5f11199b, 0x043556f1, 0xd7a3c76b, - 0x3c11183b, 0x5924a509, 0xf28fe6ed, 0x97f1fbfa, 0x9ebabf2c, 0x1e153c6e, - 0x86e34570, 0xeae96fb1, 0x860e5e0a, 0x5a3e2ab3, 0x771fe71c, 0x4e3d06fa, - 0x2965dcb9, 0x99e71d0f, 0x803e89d6, 0x5266c825, 0x2e4cc978, 0x9c10b36a, - 0xc6150eba, 0x94e2ea78, 0xa5fc3c53, 0x1e0a2df4, 0xf2f74ea7, 0x361d2b3d, - 0x1939260f, 0x19c27960, 0x5223a708, 0xf71312b6, 0xebadfe6e, 0xeac31f66, - 0xe3bc4595, 0xa67bc883, 0xb17f37d1, 0x018cff28, 0xc332ddef, 0xbe6c5aa5, - 0x65582185, 0x68ab9802, 0xeecea50f, 0xdb2f953b, 0x2aef7dad, 0x5b6e2f84, - 0x1521b628, 0x29076170, 0xecdd4775, 0x619f1510, 0x13cca830, 0xeb61bd96, - 0x0334fe1e, 0xaa0363cf, 0xb5735c90, 0x4c70a239, 0xd59e9e0b, 0xcbaade14, - 0xeecc86bc, 0x60622ca7, 0x9cab5cab, 0xb2f3846e, 0x648b1eaf, 0x19bdf0ca, - 0xa02369b9, 0x655abb50, 0x40685a32, 0x3c2ab4b3, 0x319ee9d5, 0xc021b8f7, - 0x9b540b19, 0x875fa099, 0x95f7997e, 0x623d7da8, 0xf837889a, 0x97e32d77, - 0x11ed935f, 0x16681281, 0x0e358829, 0xc7e61fd6, 0x96dedfa1, 0x7858ba99, - 0x57f584a5, 0x1b227263, 0x9b83c3ff, 0x1ac24696, 0xcdb30aeb, 0x532e3054, - 0x8fd948e4, 0x6dbc3128, 0x58ebf2ef, 0x34c6ffea, 0xfe28ed61, 0xee7c3c73, - 0x5d4a14d9, 0xe864b7e3, 0x42105d14, 0x203e13e0, 0x45eee2b6, 0xa3aaabea, - 0xdb6c4f15, 0xfacb4fd0, 0xc742f442, 0xef6abbb5, 0x654f3b1d, 0x41cd2105, - 0xd81e799e, 0x86854dc7, 0xe44b476a, 0x3d816250, 0xcf62a1f2, 0x5b8d2646, - 0xfc8883a0, 0xc1c7b6a3, 0x7f1524c3, 0x69cb7492, 0x47848a0b, 0x5692b285, - 0x095bbf00, 0xad19489d, 0x1462b174, 0x23820e00, 0x58428d2a, 0x0c55f5ea, - 0x1dadf43e, 0x233f7061, 0x3372f092, 0x8d937e41, 0xd65fecf1, 0x6c223bdb, - 0x7cde3759, 0xcbee7460, 0x4085f2a7, 0xce77326e, 0xa6078084, 0x19f8509e, - 0xe8efd855, 0x61d99735, 0xa969a7aa, 0xc50c06c2, 0x5a04abfc, 0x800bcadc, - 0x9e447a2e, 0xc3453484, 0xfdd56705, 0x0e1e9ec9, 0xdb73dbd3, 0x105588cd, - 0x675fda79, 0xe3674340, 0xc5c43465, 0x713e38d8, 0x3d28f89e, 0xf16dff20, - 0x153e21e7, 0x8fb03d4a, 0xe6e39f2b, 0xdb83adf7]) - -iSbox2 :: Sbox -iSbox2 = array (0,255) (zip [0..255] - [0xe93d5a68, 0x948140f7, 0xf64c261c, 0x94692934, 0x411520f7, 0x7602d4f7, - 0xbcf46b2e, 0xd4a20068, 0xd4082471, 0x3320f46a, 0x43b7d4b7, 0x500061af, - 0x1e39f62e, 0x97244546, 0x14214f74, 0xbf8b8840, 0x4d95fc1d, 0x96b591af, - 0x70f4ddd3, 0x66a02f45, 0xbfbc09ec, 0x03bd9785, 0x7fac6dd0, 0x31cb8504, - 0x96eb27b3, 0x55fd3941, 0xda2547e6, 0xabca0a9a, 0x28507825, 0x530429f4, - 0x0a2c86da, 0xe9b66dfb, 0x68dc1462, 0xd7486900, 0x680ec0a4, 0x27a18dee, - 0x4f3ffea2, 0xe887ad8c, 0xb58ce006, 0x7af4d6b6, 0xaace1e7c, 0xd3375fec, - 0xce78a399, 0x406b2a42, 0x20fe9e35, 0xd9f385b9, 0xee39d7ab, 0x3b124e8b, - 0x1dc9faf7, 0x4b6d1856, 0x26a36631, 0xeae397b2, 0x3a6efa74, 0xdd5b4332, - 0x6841e7f7, 0xca7820fb, 0xfb0af54e, 0xd8feb397, 0x454056ac, 0xba489527, - 0x55533a3a, 0x20838d87, 0xfe6ba9b7, 0xd096954b, 0x55a867bc, 0xa1159a58, - 0xcca92963, 0x99e1db33, 0xa62a4a56, 0x3f3125f9, 0x5ef47e1c, 0x9029317c, - 0xfdf8e802, 0x04272f70, 0x80bb155c, 0x05282ce3, 0x95c11548, 0xe4c66d22, - 0x48c1133f, 0xc70f86dc, 0x07f9c9ee, 0x41041f0f, 0x404779a4, 0x5d886e17, - 0x325f51eb, 0xd59bc0d1, 0xf2bcc18f, 0x41113564, 0x257b7834, 0x602a9c60, - 0xdff8e8a3, 0x1f636c1b, 0x0e12b4c2, 0x02e1329e, 0xaf664fd1, 0xcad18115, - 0x6b2395e0, 0x333e92e1, 0x3b240b62, 0xeebeb922, 0x85b2a20e, 0xe6ba0d99, - 0xde720c8c, 0x2da2f728, 0xd0127845, 0x95b794fd, 0x647d0862, 0xe7ccf5f0, - 0x5449a36f, 0x877d48fa, 0xc39dfd27, 0xf33e8d1e, 0x0a476341, 0x992eff74, - 0x3a6f6eab, 0xf4f8fd37, 0xa812dc60, 0xa1ebddf8, 0x991be14c, 0xdb6e6b0d, - 0xc67b5510, 0x6d672c37, 0x2765d43b, 0xdcd0e804, 0xf1290dc7, 0xcc00ffa3, - 0xb5390f92, 0x690fed0b, 0x667b9ffb, 0xcedb7d9c, 0xa091cf0b, 0xd9155ea3, - 0xbb132f88, 0x515bad24, 0x7b9479bf, 0x763bd6eb, 0x37392eb3, 0xcc115979, - 0x8026e297, 0xf42e312d, 0x6842ada7, 0xc66a2b3b, 0x12754ccc, 0x782ef11c, - 0x6a124237, 0xb79251e7, 0x06a1bbe6, 0x4bfb6350, 0x1a6b1018, 0x11caedfa, - 0x3d25bdd8, 0xe2e1c3c9, 0x44421659, 0x0a121386, 0xd90cec6e, 0xd5abea2a, - 0x64af674e, 0xda86a85f, 0xbebfe988, 0x64e4c3fe, 0x9dbc8057, 0xf0f7c086, - 0x60787bf8, 0x6003604d, 0xd1fd8346, 0xf6381fb0, 0x7745ae04, 0xd736fccc, - 0x83426b33, 0xf01eab71, 0xb0804187, 0x3c005e5f, 0x77a057be, 0xbde8ae24, - 0x55464299, 0xbf582e61, 0x4e58f48f, 0xf2ddfda2, 0xf474ef38, 0x8789bdc2, - 0x5366f9c3, 0xc8b38e74, 0xb475f255, 0x46fcd9b9, 0x7aeb2661, 0x8b1ddf84, - 0x846a0e79, 0x915f95e2, 0x466e598e, 0x20b45770, 0x8cd55591, 0xc902de4c, - 0xb90bace1, 0xbb8205d0, 0x11a86248, 0x7574a99e, 0xb77f19b6, 0xe0a9dc09, - 0x662d09a1, 0xc4324633, 0xe85a1f02, 0x09f0be8c, 0x4a99a025, 0x1d6efe10, - 0x1ab93d1d, 0x0ba5a4df, 0xa186f20f, 0x2868f169, 0xdcb7da83, 0x573906fe, - 0xa1e2ce9b, 0x4fcd7f52, 0x50115e01, 0xa70683fa, 0xa002b5c4, 0x0de6d027, - 0x9af88c27, 0x773f8641, 0xc3604c06, 0x61a806b5, 0xf0177a28, 0xc0f586e0, - 0x006058aa, 0x30dc7d62, 0x11e69ed7, 0x2338ea63, 0x53c2dd94, 0xc2c21634, - 0xbbcbee56, 0x90bcb6de, 0xebfc7da1, 0xce591d76, 0x6f05e409, 0x4b7c0188, - 0x39720a3d, 0x7c927c24, 0x86e3725f, 0x724d9db9, 0x1ac15bb4, 0xd39eb8fc, - 0xed545578, 0x08fca5b5, 0xd83d7cd3, 0x4dad0fc4, 0x1e50ef5e, 0xb161e6f8, - 0xa28514d9, 0x6c51133c, 0x6fd5c7e7, 0x56e14ec4, 0x362abfce, 0xddc6c837, - 0xd79a3234, 0x92638212, 0x670efa8e, 0x406000e0]) - -iSbox3 :: Sbox -iSbox3 = array (0,255) (zip [0..255] - [0x3a39ce37, 0xd3faf5cf, 0xabc27737, 0x5ac52d1b, 0x5cb0679e, 0x4fa33742, - 0xd3822740, 0x99bc9bbe, 0xd5118e9d, 0xbf0f7315, 0xd62d1c7e, 0xc700c47b, - 0xb78c1b6b, 0x21a19045, 0xb26eb1be, 0x6a366eb4, 0x5748ab2f, 0xbc946e79, - 0xc6a376d2, 0x6549c2c8, 0x530ff8ee, 0x468dde7d, 0xd5730a1d, 0x4cd04dc6, - 0x2939bbdb, 0xa9ba4650, 0xac9526e8, 0xbe5ee304, 0xa1fad5f0, 0x6a2d519a, - 0x63ef8ce2, 0x9a86ee22, 0xc089c2b8, 0x43242ef6, 0xa51e03aa, 0x9cf2d0a4, - 0x83c061ba, 0x9be96a4d, 0x8fe51550, 0xba645bd6, 0x2826a2f9, 0xa73a3ae1, - 0x4ba99586, 0xef5562e9, 0xc72fefd3, 0xf752f7da, 0x3f046f69, 0x77fa0a59, - 0x80e4a915, 0x87b08601, 0x9b09e6ad, 0x3b3ee593, 0xe990fd5a, 0x9e34d797, - 0x2cf0b7d9, 0x022b8b51, 0x96d5ac3a, 0x017da67d, 0xd1cf3ed6, 0x7c7d2d28, - 0x1f9f25cf, 0xadf2b89b, 0x5ad6b472, 0x5a88f54c, 0xe029ac71, 0xe019a5e6, - 0x47b0acfd, 0xed93fa9b, 0xe8d3c48d, 0x283b57cc, 0xf8d56629, 0x79132e28, - 0x785f0191, 0xed756055, 0xf7960e44, 0xe3d35e8c, 0x15056dd4, 0x88f46dba, - 0x03a16125, 0x0564f0bd, 0xc3eb9e15, 0x3c9057a2, 0x97271aec, 0xa93a072a, - 0x1b3f6d9b, 0x1e6321f5, 0xf59c66fb, 0x26dcf319, 0x7533d928, 0xb155fdf5, - 0x03563482, 0x8aba3cbb, 0x28517711, 0xc20ad9f8, 0xabcc5167, 0xccad925f, - 0x4de81751, 0x3830dc8e, 0x379d5862, 0x9320f991, 0xea7a90c2, 0xfb3e7bce, - 0x5121ce64, 0x774fbe32, 0xa8b6e37e, 0xc3293d46, 0x48de5369, 0x6413e680, - 0xa2ae0810, 0xdd6db224, 0x69852dfd, 0x09072166, 0xb39a460a, 0x6445c0dd, - 0x586cdecf, 0x1c20c8ae, 0x5bbef7dd, 0x1b588d40, 0xccd2017f, 0x6bb4e3bb, - 0xdda26a7e, 0x3a59ff45, 0x3e350a44, 0xbcb4cdd5, 0x72eacea8, 0xfa6484bb, - 0x8d6612ae, 0xbf3c6f47, 0xd29be463, 0x542f5d9e, 0xaec2771b, 0xf64e6370, - 0x740e0d8d, 0xe75b1357, 0xf8721671, 0xaf537d5d, 0x4040cb08, 0x4eb4e2cc, - 0x34d2466a, 0x0115af84, 0xe1b00428, 0x95983a1d, 0x06b89fb4, 0xce6ea048, - 0x6f3f3b82, 0x3520ab82, 0x011a1d4b, 0x277227f8, 0x611560b1, 0xe7933fdc, - 0xbb3a792b, 0x344525bd, 0xa08839e1, 0x51ce794b, 0x2f32c9b7, 0xa01fbac9, - 0xe01cc87e, 0xbcc7d1f6, 0xcf0111c3, 0xa1e8aac7, 0x1a908749, 0xd44fbd9a, - 0xd0dadecb, 0xd50ada38, 0x0339c32a, 0xc6913667, 0x8df9317c, 0xe0b12b4f, - 0xf79e59b7, 0x43f5bb3a, 0xf2d519ff, 0x27d9459c, 0xbf97222c, 0x15e6fc2a, - 0x0f91fc71, 0x9b941525, 0xfae59361, 0xceb69ceb, 0xc2a86459, 0x12baa8d1, - 0xb6c1075e, 0xe3056a0c, 0x10d25065, 0xcb03a442, 0xe0ec6e0e, 0x1698db3b, - 0x4c98a0be, 0x3278e964, 0x9f1f9532, 0xe0d392df, 0xd3a0342b, 0x8971f21e, - 0x1b0a7441, 0x4ba3348c, 0xc5be7120, 0xc37632d8, 0xdf359f8d, 0x9b992f2e, - 0xe60b6f47, 0x0fe3f11d, 0xe54cda54, 0x1edad891, 0xce6279cf, 0xcd3e7e6f, - 0x1618b166, 0xfd2c1d05, 0x848fd2c5, 0xf6fb2299, 0xf523f357, 0xa6327623, - 0x93a83531, 0x56cccd02, 0xacf08162, 0x5a75ebb5, 0x6e163697, 0x88d273cc, - 0xde966292, 0x81b949d0, 0x4c50901b, 0x71c65614, 0xe6c6c7bd, 0x327a140a, - 0x45e1d006, 0xc3f27b9a, 0xc9aa53fd, 0x62a80f00, 0xbb25bfe2, 0x35bdd2f6, - 0x71126905, 0xb2040222, 0xb6cbcf7c, 0xcd769c2b, 0x53113ec0, 0x1640e3d3, - 0x38abbd60, 0x2547adf0, 0xba38209c, 0xf746ce76, 0x77afa1c5, 0x20756060, - 0x85cbfe4e, 0x8ae88dd8, 0x7aaaf9b0, 0x4cf9aa7e, 0x1948c25c, 0x02fb8a8c, - 0x01c36ae4, 0xd6ebe1f9, 0x90d4f869, 0xa65cdea0, 0x3f09252d, 0xc208e69f, - 0xb74e6132, 0xce77e25b, 0x578fdfe3, 0x3ac372e6]) diff --git a/Codec/Encryption/DES.hs b/Codec/Encryption/DES.hs deleted file mode 100644 --- a/Codec/Encryption/DES.hs +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Codec.Encryption.DES --- Copyright : (c) Dominic Steinitz 2003 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- Takes the DES module supplied by Ian Lynagh and wraps it so it can --- used with the standard modes. --- --- See . --- ------------------------------------------------------------------------------ - -module Codec.Encryption.DES ( - -- * Function Types - encrypt, decrypt) where - -import Codec.Encryption.DESAux -import Data.Word - --- | Basic DES encryption which takes a key and a block of plaintext --- and returns the encrypted block of ciphertext according to the standard. - -encrypt :: Word64 -> Word64 -> Word64 -encrypt = flip des_enc - --- | Basic DES decryption which takes a key and a block of ciphertext and --- returns the decrypted block of plaintext according to the standard. - -decrypt :: Word64 -> Word64 -> Word64 -decrypt = flip des_dec diff --git a/Codec/Encryption/DESAux.hs b/Codec/Encryption/DESAux.hs deleted file mode 100644 --- a/Codec/Encryption/DESAux.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - -module Codec.Encryption.DESAux (des_enc, des_dec) where - -import Data.Word -import Data.Bits - -type Rotation = Int -type Key = Word64 -type Message = Word64 -type Enc = Word64 - -type BitsX = [Bool] -type Bits4 = [Bool] -type Bits6 = [Bool] -type Bits32 = [Bool] -type Bits48 = [Bool] -type Bits56 = [Bool] -type Bits64 = [Bool] - -instance Num [Bool] - -instance Bits [Bool] where - a `xor` b = (zipWith (\x y -> (not x && y) || (x && not y)) a b) - rotate bits rot = drop rot' bits ++ take rot' bits - where rot' = rot `mod` (length bits) - -bitify :: Word64 -> Bits64 -bitify w = map (\b -> w .&. (shiftL 1 b) /= 0) [63,62..0] - -unbitify :: Bits64 -> Word64 -unbitify bs = foldl (\i b -> if b then 1 + shiftL i 1 else shiftL i 1) 0 bs - -initial_permutation :: Bits64 -> Bits64 -initial_permutation mb = map ((!!) mb) i - where i = [57, 49, 41, 33, 25, 17, 9, 1, 59, 51, 43, 35, 27, 19, 11, 3, - 61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7, - 56, 48, 40, 32, 24, 16, 8, 0, 58, 50, 42, 34, 26, 18, 10, 2, - 60, 52, 44, 36, 28, 20, 12, 4, 62, 54, 46, 38, 30, 22, 14, 6] - -key_transformation :: Bits64 -> Bits56 -key_transformation kb = map ((!!) kb) i - where i = [56, 48, 40, 32, 24, 16, 8, 0, 57, 49, 41, 33, 25, 17, - 9, 1, 58, 50, 42, 34, 26, 18, 10, 2, 59, 51, 43, 35, - 62, 54, 46, 38, 30, 22, 14, 6, 61, 53, 45, 37, 29, 21, - 13, 5, 60, 52, 44, 36, 28, 20, 12, 4, 27, 19, 11, 3] - -des_enc :: Message -> Key -> Enc -des_enc = do_des [1,2,4,6,8,10,12,14,15,17,19,21,23,25,27,28] - -des_dec :: Message -> Key -> Enc -des_dec = do_des [28,27,25,23,21,19,17,15,14,12,10,8,6,4,2,1] - -do_des :: [Rotation] -> Message -> Key -> Enc -do_des rots m k = des_work rots (takeDrop 32 mb) kb - where kb = key_transformation $ bitify k - mb = initial_permutation $ bitify m - -des_work :: [Rotation] -> (Bits32, Bits32) -> Bits56 -> Enc -des_work [] (ml, mr) _ = unbitify $ final_perm $ (mr ++ ml) -des_work (r:rs) mb kb = des_work rs mb' kb - where mb' = do_round r mb kb - -do_round :: Rotation -> (Bits32, Bits32) -> Bits56 -> (Bits32, Bits32) -do_round r (ml, mr) kb = (mr, m') - where kb' = get_key kb r - comp_kb = compression_permutation kb' - expa_mr = expansion_permutation mr - res = comp_kb `xor` expa_mr - res' = tail $ iterate (trans 6) ([], res) - trans n (_, b) = (take n b, drop n b) - res_s = concat $ zipWith (\f (x,_) -> f x) [s_box_1, s_box_2, - s_box_3, s_box_4, - s_box_5, s_box_6, - s_box_7, s_box_8] res' - res_p = p_box res_s - m' = res_p `xor` ml - -get_key :: Bits56 -> Rotation -> Bits56 -get_key kb r = kb' - where (kl, kr) = takeDrop 28 kb - kb' = rotateL kl r ++ rotateL kr r - -compression_permutation :: Bits56 -> Bits48 -compression_permutation kb = map ((!!) kb) i - where i = [13, 16, 10, 23, 0, 4, 2, 27, 14, 5, 20, 9, - 22, 18, 11, 3, 25, 7, 15, 6, 26, 19, 12, 1, - 40, 51, 30, 36, 46, 54, 29, 39, 50, 44, 32, 47, - 43, 48, 38, 55, 33, 52, 45, 41, 49, 35, 28, 31] - -expansion_permutation :: Bits32 -> Bits48 -expansion_permutation mb = map ((!!) mb) i - where i = [31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, - 7, 8, 9, 10, 11, 12, 11, 12, 13, 14, 15, 16, - 15, 16, 17, 18, 19, 20, 19, 20, 21, 22, 23, 24, - 23, 24, 25, 26, 27, 28, 27, 28, 29, 30, 31, 0] - -s_box :: [[Word8]] -> Bits6 -> Bits4 -s_box s [a,b,c,d,e,f] = to_bool 4 $ (s !! row) !! col - where row = sum $ zipWith numericise [a,f] [1, 0] - col = sum $ zipWith numericise [b,c,d,e] [3, 2, 1, 0] - numericise = (\x y -> if x then 2^y else 0) - to_bool 0 _ = [] - to_bool n i = ((i .&. 8) == 8):to_bool (n-1) (shiftL i 1) - -s_box_1 :: Bits6 -> Bits4 -s_box_1 = s_box i - where i = [[14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7], - [ 0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8], - [ 4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0], - [15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13]] - -s_box_2 :: Bits6 -> Bits4 -s_box_2 = s_box i - where i = [[15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10], - [3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5], - [0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15], - [13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9]] - -s_box_3 :: Bits6 -> Bits4 -s_box_3 = s_box i - where i = [[10, 0, 9, 14 , 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8], - [13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1], - [13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7], - [1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12]] - -s_box_4 :: Bits6 -> Bits4 -s_box_4 = s_box i - where i = [[7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15], - [13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9], - [10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4], - [3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14]] - -s_box_5 :: Bits6 -> Bits4 -s_box_5 = s_box i - where i = [[2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9], - [14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6], - [4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14], - [11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3]] - -s_box_6 :: Bits6 -> Bits4 -s_box_6 = s_box i - where i = [[12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11], - [10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8], - [9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6], - [4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13]] - -s_box_7 :: Bits6 -> Bits4 -s_box_7 = s_box i - where i = [[4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1], - [13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6], - [1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2], - [6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12]] - -s_box_8 :: Bits6 -> Bits4 -s_box_8 = s_box i - where i = [[13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7], - [1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2], - [7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8], - [2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11]] - -p_box :: Bits32 -> Bits32 -p_box kb = map ((!!) kb) i - where i = [15, 6, 19, 20, 28, 11, 27, 16, 0, 14, 22, 25, 4, 17, 30, 9, - 1, 7, 23, 13, 31, 26, 2, 8, 18, 12, 29, 5, 21, 10, 3, 24] - -final_perm :: Bits64 -> Bits64 -final_perm kb = map ((!!) kb) i - where i = [39, 7, 47, 15, 55, 23, 63, 31, 38, 6, 46, 14, 54, 22, 62, 30, - 37, 5, 45, 13, 53, 21, 61, 29, 36, 4, 44, 12, 52, 20, 60, 28, - 35, 3, 43, 11, 51, 19, 59, 27, 34, 2, 42, 10, 50, 18, 58, 26, - 33, 1, 41, 9, 49, 17, 57, 25, 32, 0, 40 , 8, 48, 16, 56, 24] - -takeDrop :: Int -> [a] -> ([a], [a]) -takeDrop _ [] = ([], []) -takeDrop 0 xs = ([], xs) -takeDrop n (x:xs) = (x:ys, zs) - where (ys, zs) = takeDrop (n-1) xs - diff --git a/Codec/Encryption/Modes.hs b/Codec/Encryption/Modes.hs deleted file mode 100644 --- a/Codec/Encryption/Modes.hs +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Codec.Encryption.Modes --- Copyright : (c) Dominic Steinitz 2001-2003 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- This module currently supports Cipher Block Chaining (CBC) mode. --- See for further details. --- ------------------------------------------------------------------------------ - -module Codec.Encryption.Modes ( - -- * Function types - cbc, unCbc - ) where - -import Data.Word -import Data.Bits - --- * CBC or Cipher Block Chaining Mode - --- | In CBC or Cipher Block Chaining mode each block is XORed with --- the previous enciphered block before encryption. For the first --- block, start with an initialization vector. --- Take an encryption function, an initialisation vector, a key and --- a list of blocks and return the encrypted blocks using CBC. - -cbc :: Bits block => - (key -> block -> block) -> - block -> - key -> - [block] -> - [block] - -cbc e iv k ps = - ciphers where - ciphers = map (e k) feedIns - feedIns = zipWith xor (iv : ciphers) ps - --- | To decipher in CBC or Cipher Block Chaining mode, decipher --- each block, then XOR the result with the previous block of --- plaintext result. Note that the initialization vector is treated as the --- zeroth block of plaintext. --- Take a decryption function, an initialisation vector, a key and a list --- of encrypted blocks using CBC and return plaintext blocks. - -unCbc :: Bits block => - (key -> block -> block) -> - block -> - key -> - [block] -> - [block] - -unCbc d iv k ms = - outOfCbcs where - beforeXOrs = map (d k) ms - outOfCbcs = zipWith xor (iv : ms) beforeXOrs diff --git a/Codec/Encryption/Padding.hs b/Codec/Encryption/Padding.hs deleted file mode 100644 --- a/Codec/Encryption/Padding.hs +++ /dev/null @@ -1,108 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Codec.Encryption.Padding --- Copyright : (c) Dominic Steinitz 2003 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- Padding algorithms for use with block ciphers. --- --- This module currently supports: --- --- * PKCS5 padding and unpadding. --- --- * Null padding and unpadding. --- ------------------------------------------------------------------------------ - -module Codec.Encryption.Padding ( - -- * Function types - pkcs5, unPkcs5, - padNulls, unPadNulls - ) where - -import Data.Word -import Data.Bits -import Data.List -import Codec.Utils - --- | When the last block of plaintext is shorter than the block size then it --- must be padded. PKCS5 specifies that the padding octets should each --- contain the number of octets which must be stripped off. So, for example, --- with a block size of 8, \"0a0b0c\" will be padded with \"05\" resulting in --- \"0a0b0c0505050505\". If the final block is a full block of 8 octets --- then a whole block of \"0808080808080808\" is appended. - -pkcs5 :: (Integral a, Bits a) => [Octet] -> [a] -pkcs5 s = pad p s where p n = replicate n (fromIntegral n) - --- | When the last block of plaintext is shorter than the block size then it --- must be padded. Nulls padding specifies that the padding octets should each --- contain a null. So, for example, --- with a block size of 8, \"0a0b0c\" will be padded to --- \"0a0b0c0000000000\". If the final block is a full block of 8 octets --- then a whole block of \"0000000000000000\" is appended. --- NB this is only suitable for data which does not contain nulls, --- for example, ASCII. - -padNulls :: (Integral a, Bits a) => [Octet] -> [a] -padNulls s = pad p s where p n = replicate n 0 - -testPad s = pad p s where p n = replicate (n-1) 0xff ++ [fromIntegral n] - -pad p s = - blocks where - octetSize = (bitSize $ head blocks) `div` 8 - blocks = map (fromOctets 256) (unfoldr h $ concat $ unfoldr g s) - g :: [Octet] -> Maybe ([Octet],[Octet]) - g x - | l == 0 = Nothing - | l < octetSize = Just (t ++ (p (octetSize-l)), []) - | d == [] = Just (t ++ (p octetSize), []) - | otherwise = Just (t, d) - where l = length t - t = take octetSize x - d = drop octetSize x - h :: [Octet] -> Maybe ([Octet],[Octet]) - h x - | x == [] = Nothing - | otherwise = Just (take octetSize x, drop octetSize x) - --- | Take a list of blocks padded using the method described in PKCS5 --- (see ) --- and return the list of unpadded octets. NB this function does not --- currently check that the padded block is correctly formed and should --- only be used for blocks that have been padded correctly. - -unPkcs5 :: (Bits a, Integral a) => [a] -> [Octet] -unPkcs5 s = - unPad h s - where - h octetSize x = take (octetSize - (fromIntegral (last x))) x - --- | Take a list of blocks padded with nulls --- and return the list of unpadded octets. NB if the blocks contain --- a null then the result is unpredictable. - -unPadNulls :: (Bits a, Integral a) => [a] -> [Octet] -unPadNulls s = - unPad h s - where - h _ x = takeWhile (/=0) x - -unPad p s = - concat $ unfoldr g s where - g :: (Integral a, Bits a) => [a] -> Maybe ([Octet],[a]) - g x - | t == [] = Nothing - | d == [] = Just (s, []) - | otherwise = Just (v, d) - where t = take 1 x - d = drop 1 x - u = head t - octetSize = (bitSize u) `div` 8 - v = i2osp octetSize u - s = p octetSize v diff --git a/Codec/Encryption/RSA.hs b/Codec/Encryption/RSA.hs deleted file mode 100644 --- a/Codec/Encryption/RSA.hs +++ /dev/null @@ -1,79 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Coded.Encryption.RSA --- Copyright : (c) David J. Sankel 2003, Dominic Steinitz 2003 --- License : GPL (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : non-portable --- --- A modified version of the RSA module supplied by David J. Sankel --- (). --- --- As the original code is GPL, this has to be. --- This code is free software; you can redistribute it and\/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- This code is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this code; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111\-1307 USA ------------------------------------------------------------------------------ - -module Codec.Encryption.RSA( - -- * Function Types - encrypt, - decrypt - )where - -import Codec.Utils -import Codec.Encryption.RSA.NumberTheory - -rsaep :: (Integer , Integer) -> Integer -> Integer -rsaep (n,e) m - | m < 0 || m > n-1 = - error "Codec.Encryption.RSA.rsaep: message too long" - | otherwise = - expmod m e n - --- | Take the modulus of the RSA key and the public exponent expressed --- as lists of octets and the plaintext also expressed as a list of --- octets and return the ciphertext as a list of octets. Of course, --- these are all large integers but using lists of octets makes --- everything easier. See --- for more --- details. - -encrypt :: ([Octet],[Octet]) -> [Octet] -> [Octet] -encrypt (n,e) m = - i2osp (length n) $ - rsaep (fromOctets 256 n, fromOctets 256 e) (fromOctets 256 m) - -rsadp :: (Integer , Integer) -> Integer -> Integer -rsadp (n,d) c - | c < 0 || c > n-1 = - error "Codec.Encryption.RSA.rsadp: decryption error" - | otherwise = - expmod c d n - --- | Take the modulus of the RSA key and the private exponent expressed --- as lists of octets and the ciphertext also expressed as a list of --- octets and return the plaintext as a list of octets. - -decrypt :: ([Octet],[Octet]) -> [Octet] -> [Octet] -decrypt (n,e) m - | lc > lm = - error "Codec.Encryption.RSA.rsadp: decryption error" - | otherwise = - i2osp (length n) $ - rsadp (fromOctets 256 n, fromOctets 256 e) (fromOctets 256 m) - where - lc = length $ dropWhile (==0x00) m - lm = length $ dropWhile (==0x00) n diff --git a/Codec/Encryption/RSA/EMEOAEP.hs b/Codec/Encryption/RSA/EMEOAEP.hs deleted file mode 100644 --- a/Codec/Encryption/RSA/EMEOAEP.hs +++ /dev/null @@ -1,95 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Coded.Encryption.RSA.EMEOAEP --- Copyright : (c) David J. Sankel 2003, Dominic Steinitz 2003 --- License : GPL (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : non-portable --- --- A modified version of the EMEOAEP module supplied by David J. Sankel --- (). --- --- As the original code is GPL, this has to be. --- This code is free software; you can redistribute it and\/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- This code is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this code; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111\-1307 USA ------------------------------------------------------------------------------ - -module Codec.Encryption.RSA.EMEOAEP( - -- * Function Types - encode, - decode - )where - -import Codec.Utils (Octet) -import Data.Bits - -xorOctets :: Bits a => [a] -> [a] -> [a] -xorOctets = zipWith xor - --- | Take a mask generating function, a hash function, a label (which may be --- null), a random seed, the modulus of the key and the message and returns --- an encoded message. NB you could pass in the length of the modulus --- but it seems safer to pass in the modulus itself and calculate the --- length when required. See --- for more --- details. - -encode :: (([Octet] -> [Octet]) -> [Octet] -> Int -> [Octet]) -> - ([Octet] -> [Octet]) -> [Octet] -> [Octet] -> [Octet] -> [Octet] -> - [Octet] - -encode mgf hash p seed n m = - if length m > emLen - 2*hLen - 2 - then error "Codec.Encryption.EMEOAEP.encode: message too long" - else em - where - emLen = length n - mLen = length m - ps = take (emLen-mLen-2*hLen-2) $ repeat $ 0x00 - pHash = hash p - hLen = length pHash - db = pHash ++ ps ++ [0x01] ++ m - dbMask = mgf hash seed (length db) - maskedDB = db `xorOctets` dbMask - seedMask = mgf hash maskedDB hLen - maskedSeed = seed `xorOctets` seedMask - em = [0x00] ++ maskedSeed ++ maskedDB - --- | Take a mask generating function, a hash function, a label (which may be --- null) and the message and returns the decoded. - -decode :: (([Octet] -> [Octet]) -> [Octet] -> Int -> [Octet]) -> - ([Octet] -> [Octet]) -> [Octet] -> [Octet] -> [Octet] - -decode mgf hash p em = - if length em < 2*hLen + 1 || - one /= 0x01 || - pHash' /= pHash || - y /= [0x00] - then error "Codec.Encryption.EMEOAEP.decode: decryption error" - else m - where - (y,rest) = splitAt 1 em - pHash = hash p - hLen = length pHash - (maskedSeed,maskedDB) = splitAt hLen rest - seedMask = mgf hash maskedDB hLen - seed = maskedSeed `xorOctets` seedMask - emLen = length em - dbMask = mgf hash seed (emLen - hLen - 1) - db = maskedDB `xorOctets` dbMask - (pHash',rest') = splitAt hLen db - (one:m) = dropWhile (== 0x00) rest' diff --git a/Codec/Encryption/RSA/MGF.hs b/Codec/Encryption/RSA/MGF.hs deleted file mode 100644 --- a/Codec/Encryption/RSA/MGF.hs +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Codec.Encryption.RSA.MGF --- Copyright : (c) Dominic Steinitz 2003 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- Implements the mask generation function as specified in: --- --- ------------------------------------------------------------------------------ - -module Codec.Encryption.RSA.MGF ( - -- * Function Types - mgf) where - -import Codec.Utils (Octet, i2osp) - --- | Take a hash function, a seed and the intended length of the --- the mask and deliver a mask of the requested length. - -mgf :: ([Octet] -> [Octet]) -> [Octet] -> Int -> [Octet] - -mgf hash z l = - take l $ concat $ hashes - where - hashes = map f [0..(l `div` hLen)] - hLen = length $ f 0 - f = hash . (z++) . (i2osp 4) diff --git a/Codec/Encryption/RSA/NumberTheory.hs b/Codec/Encryption/RSA/NumberTheory.hs deleted file mode 100644 --- a/Codec/Encryption/RSA/NumberTheory.hs +++ /dev/null @@ -1,203 +0,0 @@ ---Copyright 2001, 2002, 2003 David J. Sankel --- ---This file is part of rsa-haskell. ---rsa-haskell is free software; you can redistribute it and/or modify ---it under the terms of the GNU General Public License as published by ---the Free Software Foundation; either version 2 of the License, or ---(at your option) any later version. --- ---rsa-haskell is distributed in the hope that it will be useful, ---but WITHOUT ANY WARRANTY; without even the implied warranty of ---MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ---GNU General Public License for more details. --- ---You should have received a copy of the GNU General Public License ---along with rsa-haskell; if not, write to the Free Software ---Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -module Codec.Encryption.RSA.NumberTheory( -inverse, extEuclGcd, simplePrimalityTest, getPrime, pg, isPrime, -rabinMillerPrimalityTest, expmod, factor, testInverse, primes, (/|), -randomOctet -) where - - -import System.Random(getStdRandom,randomR) ---The following line is required for ghc optomized implementation --- (see comments beginning with GHC): --- import Bits(setBit) -import Data.List(elemIndex) -import Data.Maybe(fromJust) -import Data.Char(chr,ord) -import Data.Bits(xor) - ---Precondition: the integer is >= 0 -randomOctet :: Int -> IO( String ) -randomOctet n - | n < 0 = error "randomOctet argument doesn't meet preconditions" - | otherwise = (sequence $ take n $ repeat $ getStdRandom (randomR( 0,255) )) - >>= (return . (map chr) ) - ---Returns a list [r_1,r_2,r_3,r_4, . . ., r_n ] where --- a = p_1^r_1 * p_2^r_2 * p_3^r_3 * . . . * p_n^r_n -factor :: Integer -> [Int] -factor = factor_1 - ---An implimentation of factor -factor_1 :: Integer -> [Int] -factor_1 a = reverse . dropWhile (== 0) . reverse - . map (\x -> largestPower x a) . takeWhile (<= a ) $ primes - ---Another implimentation of factor -factor_2 :: Integer -> [Integer] -factor_2 a = - let - p = map (fromIntegral) . reverse . dropWhile (== 0) - . reverse . map (\x -> largestPower x a) - . takeWhile (<= a `div` 2) $ primes - in - if (length p == 0) - then (take ((fromIntegral . fromJust $ elemIndex a primes)-1) (repeat 0)) - ++ [1] - else p - ---Find the inverse of x (mod n) -inverse :: Integer -> Integer -> Integer -inverse x n = (fst (extEuclGcd x n)) `mod` n - -testInverse :: Integer ->Integer -> Bool -testInverse a b = ((inverse a b)*a) `mod` b == 1 - ---Extended Eucildean algorithm ---Returns (x,y) where gcd(a,b) = xa + yb -extEuclGcd :: Integer -> Integer -> (Integer,Integer) -extEuclGcd a b = extEuclGcd_iter a b (1,0) (0,1) - -extEuclGcd_iter :: Integer -> Integer - -> (Integer,Integer) -> (Integer,Integer) -> (Integer,Integer) -extEuclGcd_iter a b (c1,c2) (d1,d2) - | (a > b) && (r1 == 0) = (d1,d2) - | (a > b) && (r1 /= 0) = extEuclGcd_iter - (a - (q1*b)) b (c1 - (q1*d1), c2 - (q1*d2)) (d1,d2) - | (a <= b) && (r2 == 0) = (c1,c2) - | (a <= b) && (r2 /= 0) = extEuclGcd_iter - a (b - (q2*a)) (c1,c2) ( d1 - (q2*c1), d2- (q2*c2)) - where - q1 = a `div` b - q2 = b `div` a - r1 = a `mod` b - r2 = b `mod` a - --- This will return a random Integer of n bits. The highest order bit --- will always be 1. - --- GHC optomized implementation --- getNumber :: Int -> IO Integer --- getNumber n = do --- i <- getStdRandom ( randomR (0, a-1 ) ) --- return (setBit i (n-1)) --- where --- a = (2^n) ::Integer - ---This is the portable version -getNumber :: Int -> IO Integer -getNumber n = do - i <- getStdRandom ( randomR (0, a-1 ) ) - return (i+(2^(n-1))) - where - a = (2^(n-1)) ::Integer - ---Returns a probable prime number of nBits bits - --- GHC optomized implementation --- getPrime :: Int -> IO Integer --- getPrime nBits = do --- r <- getNumber nBits --- let p = (setBit r 0) --Make it odd for speed --- pIsPrime <- isPrime p --- if( pIsPrime ) --- then return p --- else getPrime nBits - ---This is the portable version -getPrime :: Int -> IO Integer -getPrime nBits = do - r <- getNumber nBits - let p = if( 2 /| r ) then r else r+1 - pIsPrime <- isPrime p - if( pIsPrime ) - then return p - else getPrime nBits - ---Prime Generate: ---Generates a prime p | minimum <= p <= maximum and gcd p e == 1 -pg :: Integer -> Integer -> Integer -> IO(Integer) -pg minimum maximum e = do - p <- getStdRandom( randomR( minimum, maximum ) ) - pIsPrime <- isPrime p - if( pIsPrime && (gcd p e) == 1 ) - then return p - else pg minimum maximum e - -isPrime :: Integer -> IO Bool -isPrime a - | (a <= 1) = return False - | (a <= 2000) = return (simplePrimalityTest a) - | otherwise = if (simplePrimalityTest a) - then do --Do this 5 times for saftey - test <- mapM rabinMillerPrimalityTest $ take 5 $ repeat a - return (and test) - else return False - -simplePrimalityTest :: Integer -> Bool -simplePrimalityTest a = foldr (&&) True (map (/| a)(takeWhile ( Integer -> Int -largestPower x y = fromJust . elemIndex False - . map (\b -> (y `mod` x^b) == 0) $ [1..] - -rabinMillerPrimalityTest :: Integer -> IO Bool -rabinMillerPrimalityTest p = rabinMillerPrimalityTest_iter_1 p b m - where - b = fromIntegral $ largestPower 2 (p-1) - m = (p-1) `div` (2^b) - ---The ?prime? Number -> The amount of iterations -> b -> m -rabinMillerPrimalityTest_iter_1 :: Integer -> Integer -> Integer -> IO Bool -rabinMillerPrimalityTest_iter_1 p b m = - do - a <- getStdRandom ( randomR (0, 2000 ) ) - return (rabinMillerPrimalityTest_iter_2 p b 0 (expmod a m p)) - -rabinMillerPrimalityTest_iter_2 :: Integer -> Integer -> Integer -> Integer - -> Bool -rabinMillerPrimalityTest_iter_2 p b j z - | (z == 1) || (z == p-1) = True - | (j > 0) && (z == 1) = False - | (j+1 < b) && (z /= p-1) = - (rabinMillerPrimalityTest_iter_2 p b (j+1) ((z^2) `mod` p )) - | z == p - 1 = True - | (j+1 == b) && (z /= p-1) = False - ---a^x (mod m) -expmod :: Integer -> Integer -> Integer -> Integer -expmod a x m | x == 0 = 1 - | x == 1 = a `mod` m - | even x = let p = (expmod a (x `div` 2) m) `mod` m - in (p^2) `mod` m - | otherwise = (a * expmod a (x-1) m) `mod` m - ---Largest x where x^2 < i -intSqrt :: Integer -> Integer -intSqrt i = floor (sqrt (fromIntegral i ) ) - ---The doesn't divide function -(/|) :: Integer -> Integer -> Bool -a /| b = b `mod` a /= 0 - ---List of primes -primes :: [Integer] -primes = 2:[x | x <- [3,5..], foldr (&&) True - ( map ( /| x ) (takeWhile (<=(intSqrt x)) primes ) ) ] diff --git a/Codec/Encryption/TEA.hs b/Codec/Encryption/TEA.hs deleted file mode 100644 --- a/Codec/Encryption/TEA.hs +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Codec.Encryption.TEA --- Copyright : (c) John Meacham 2008 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : john@repetae.net (http://repetae.net/) --- Stability : experimental --- Portability : portable --- --- Implementation of the TEA tiny encryption algorithm --- ------------------------------------------------------------------------------ - -module Codec.Encryption.TEA( - TEAKey(TEAKey), - encrypt, - decrypt - ) where - -import Data.Bits -import Data.Word - --- We don't use LargeKey for both efficiency and practical reasons. - -data TEAKey = TEAKey {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 - - -delta :: Word32 -delta = 0x9e3779b9 - -rounds = 32 - -encrypt :: TEAKey -> Word64 -> Word64 -encrypt (TEAKey k0 k1 k2 k3) v = f rounds 0 v0 v1 where - v0,v1 :: Word32 - v0 = fromIntegral v - v1 = fromIntegral $ v `shiftR` 32 - f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined - f 0 _ v0 v1 = (fromIntegral v1 `shiftL` 32) .|. (fromIntegral v0 .&. 0xffffffff) - f n sum v0 v1 = f (n - 1) sum' v0' v1' where - sum' = sum + delta - v0' = (v0 + (((v1 `shiftL` 4) + k0) `xor` (v1 + sum') `xor` ((v1 `shiftR` 5) + k1))) - v1' = (v1 + (((v0' `shiftL` 4) + k2) `xor` (v0' + sum') `xor` ((v0' `shiftR` 5) + k3))) - - -decrypt :: TEAKey -> Word64 -> Word64 -decrypt (TEAKey k0 k1 k2 k3) v = f rounds 0xC6EF3720 v0 v1 where - v0,v1 :: Word32 - v0 = fromIntegral v - v1 = fromIntegral $ v `shiftR` 32 - f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined - f 0 _ v0 v1 = (fromIntegral v1 `shiftL` 32) .|. (fromIntegral v0 .&. 0xFFFFFFFF) - f n sum v0 v1 = f (n - 1) (sum - delta) v0' v1' where - v1' = (v1 - (((v0 `shiftL` 4) + k2) `xor` (v0 + sum) `xor` ((v0 `shiftR` 5) + k3))) - v0' = (v0 - (((v1' `shiftL` 4) + k0) `xor` (v1' + sum) `xor` ((v1' `shiftR` 5) + k1))) - - - -{- - void encrypt (unsigned long* v, unsigned long* k) { - unsigned long v0=v[0], v1=v[1], sum=0, i; /* set up */ - unsigned long delta=0x9e3779b9; /* a key schedule constant */ - unsigned long k0=k[0], k1=k[1], k2=k[2], k3=k[3]; /* cache key */ - for (i=0; i < 32; i++) { /* basic cycle start */ - sum += delta; - v0 += ((v1<<4) + k0) ^ (v1 + sum) ^ ((v1>>5) + k1); - v1 += ((v0<<4) + k2) ^ (v0 + sum) ^ ((v0>>5) + k3); /* end cycle */ - } - v[0]=v0; v[1]=v1; -} - -void decrypt (unsigned long* v, unsigned long* k) { - unsigned long v0=v[0], v1=v[1], sum=0xC6EF3720, i; /* set up */ - unsigned long delta=0x9e3779b9; /* a key schedule constant */ - unsigned long k0=k[0], k1=k[1], k2=k[2], k3=k[3]; /* cache key */ - for (i=0; i<32; i++) { /* basic cycle start */ - v1 -= ((v0<<4) + k2) ^ (v0 + sum) ^ ((v0>>5) + k3); - v0 -= ((v1<<4) + k0) ^ (v1 + sum) ^ ((v1>>5) + k1); - sum -= delta; /* end cycle */ - } - v[0]=v0; v[1]=v1; -} - --} diff --git a/Codec/Text/Raw.hs b/Codec/Text/Raw.hs deleted file mode 100644 --- a/Codec/Text/Raw.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Coded.Text.Raw --- Copyright : (c) Dominic Steinitz 2006 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- ------------------------------------------------------------------------------ - -module Codec.Text.Raw( - hexdump, - hexdumpBy, - ) where - -import Data.List -import Codec.Utils -import Numeric -import Text.PrettyPrint - -split :: Int -> [a] -> [[a]] -split n xs = unfoldr (g n) xs - -g :: Int -> [a] -> Maybe ([a],[a]) -g n [] = Nothing -g n y = Just (splitAt n y) - -sh x | x < 16 = '0':(showHex x "") - | otherwise = showHex x "" - -type OctetsPerLine = Int - -hexdump :: OctetsPerLine -> [Octet] -> Doc -hexdump n = - vcat . - map hcat . - map (intersperse colon) . - map (map (text . sh)) . - split n - -hexdumpBy :: String -> OctetsPerLine -> [Octet] -> Doc -hexdumpBy s n = - vcat . - map hcat . - map (intersperse (text s)) . - map (map (text . sh)) . - split n diff --git a/Codec/Utils.hs b/Codec/Utils.hs deleted file mode 100644 --- a/Codec/Utils.hs +++ /dev/null @@ -1,138 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Codec.Utils --- Copyright : (c) Dominic Steinitz 2003 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- Utilities for coding and decoding. --- ------------------------------------------------------------------------------ - -module Codec.Utils ( - -- * Types and Constants - Octet, - msb, - -- * Octet Conversion Functions - fromTwosComp, toTwosComp, - toOctets, fromOctets, - listFromOctets, listToOctets, - i2osp - ) where - -import Data.Word -import Data.Bits - -powersOf n = 1 : (map (*n) (powersOf n)) - -toBase x = - map fromIntegral . - reverse . - map (flip mod x) . - takeWhile (/=0) . - iterate (flip div x) - --- | Take a number a convert it to base n as a list of octets. - -toOctets :: (Integral a, Integral b) => a -> b -> [Octet] -toOctets n x = (toBase n . fromIntegral) x - --- | This is used to (approximately) get back to a starting word list. --- For example, if you have a list of 3 Word8 and try to convert them to --- a Word32, the Word32 will get null-padded, and without correction, you --- will get 4 Word8s when converting back. This corrects it. --- Unfortunately, it also means you will have errors if trying to convert --- Word8 lists with nulls on the end. -trimNulls :: [Word8] -> [Word8] -trimNulls = reverse . (dropWhile (== 0)) . reverse - --- | Converts a list of numbers into a list of octets. --- The resultant list has nulls trimmed from the end to make this the dual --- of listFromOctets (except when the original octet list ended with nulls; --- see 'trimNulls'). -listToOctets :: (Bits a, Integral a) => [a] -> [Octet] -listToOctets x = trimNulls $ concat paddedOctets where - paddedOctets :: [[Octet]] - paddedOctets = map (padTo bytes) rawOctets - rawOctets :: [[Octet]] - rawOctets = map (reverse . toOctets 256) x - padTo :: Int -> [Octet] -> [Octet] - padTo x y = take x $ y ++ repeat 0 - bytes :: Int - bytes = bitSize (head x) `div` 8 - --- | The basic type for encoding and decoding. - -type Octet = Word8 - --- | The most significant bit of an 'Octet'. - -msb :: Int -msb = bitSize (undefined::Octet) - 1 - --- | Take a list of octets (a number expressed in base n) and convert it --- to a number. - -fromOctets :: (Integral a, Integral b) => a -> [Octet] -> b -fromOctets n x = - fromIntegral $ - sum $ - zipWith (*) (powersOf n) (reverse (map fromIntegral x)) - --- | See 'listToOctets'. -listFromOctets :: (Integral a, Bits a) => [Octet] -> [a] -listFromOctets [] = [] -listFromOctets x = result where - result = first : rest - first = fromOctets 256 first' - first' = reverse $ take bytes x - rest = listFromOctets $ drop bytes x - bytes = bitSize first `div` 8 - --- | Take the length of the required number of octets and convert the --- number to base 256 padding it out to the required length. If the --- required length is less than the number of octets of the converted --- number then return the converted number. NB this is different from --- the standard --- but mimics how replicate behaves. - -i2osp :: Integral a => Int -> a -> [Octet] -i2osp l y = - pad ++ z - where - pad = replicate (l - unPaddedLen) (0x00::Octet) - z = toOctets 256 y - unPaddedLen = length z - --- | Convert from twos complement. - -fromTwosComp :: Integral a => [Octet] -> a -fromTwosComp x = conv x - where conv [] = 0 - conv w@(x:xs) = if (testBit x msb) - then neg w - else pos w - neg w@(x:xs) = let z=(clearBit x msb):xs in - fromIntegral((fromOctets 256 z)- - (128*(256^((length w)-1)))) - pos w = fromIntegral(fromOctets 256 w) - -toTwosComp :: Integral a => a -> [Octet] -toTwosComp x - | x < 0 = reverse . plusOne . reverse . (map complement) $ u - | x == 0 = [0x00] - | otherwise = u - where z@(y:ys) = toBase 256 (abs x) - u = if testBit y msb - then 0x00:z - else z - -plusOne :: [Octet] -> [Octet] -plusOne [] = [1] -plusOne (x:xs) = - if x == 0xff - then 0x00:(plusOne xs) - else (x+1):xs diff --git a/Crypto.cabal b/Crypto.cabal --- a/Crypto.cabal +++ b/Crypto.cabal @@ -1,106 +1,154 @@ -Name: Crypto -Version: 4.2.5.1 -License: OtherLicense -License-File: ReadMe.tex -Author: Dominic Steinitz -Maintainer: Caylee Hogg -Copyright: Dominic Steinitz 2003 - 2007 +cabal-version: 2.2 +name: Crypto +version: 4.2.5.2 +build-type: Simple -Stability: Alpha -Category: Cryptography, Codec -Synopsis: Collects together existing Haskell cryptographic functions into a package -Description: DES, Blowfish, AES, TEA, SHA1, MD5, RSA, BubbleBabble, - Hexdump, Support for Word128, Word192 and Word256 and Beyond, PKCS5 - Padding, Various Encryption Modes e.g. Cipher Block Chaining all in one package, - with HUnit and QuickCheck tests, and examples. -Data-Files: CryptoHomePage.html +Copyright: © 2003-2007 Dominic Steinitz et al. +license: BSD-3-Clause AND GPL-2.0-or-later +license-file: ReadMe.tex -Build-Type: Simple -Cabal-Version: >= 1.2 -Tested-With: GHC==6.8.2 GHC==6.10.1 +author: Dominic Steinitz +maintainer: hvr@gnu.org -flag small_base - description: choose the new smaller, split-up base package. +category: Cryptography, Codec +synopsis: Common Cryptographic Algorithms in Pure Haskell +description: + This packages provides many of the commonly used cryptographic algorithms, such as + . + * DES + * Blowfish + * AES + * TEA + * SHA-1 + * SHA-2 (SHA-224, SHA-256, SHA-384, SHA-512) + * MD5 + * RSA + * PKCS#5 Padding + * HMAC + * Ciper Block Chaining (CBC) mode + . + Moreover, this package also provides an implementation of the /Bubble Babble Binary Data Encoding/ and miscellaneous utilties. + . + The library in this package is implemented in pure (plus currently the @FlexibleInstances@ and @TypeSynonymInstances@ extensions) and thus should be fairly portable. However, it shouldn't be expected to be the most performant possible Haskell cryptographic library; for instance, for optimized implementations of Hash algorithms, see the . -Library - Exposed-Modules: - Codec.Binary.BubbleBabble, - Codec.Encryption.RSA, - Codec.Encryption.RSA.EMEOAEP, - Codec.Encryption.RSA.MGF, - Codec.Encryption.RSA.NumberTheory, - Codec.Encryption.DES, - Codec.Encryption.AES, - Codec.Encryption.TEA, - Codec.Encryption.Blowfish, - Codec.Encryption.Modes, - Codec.Encryption.Padding, - Codec.Text.Raw, - Codec.Utils, - Data.Digest.MD5, - Data.Digest.SHA1, - Data.Digest.SHA2, - Data.Digest.SHA224, - Data.Digest.SHA256, - Data.Digest.SHA384, - Data.Digest.SHA512, - Data.LargeWord, - Data.HMAC - Build-Depends: QuickCheck >= 2.4.0.1, HUnit - if flag(small_base) - Build-Depends: base >= 3, base < 5, array, random, pretty - else - Build-Depends: base < 3 - Ghc-options: -fregs-graph - Extensions: FlexibleInstances, TypeSynonymInstances - Other-modules: - Codec.Encryption.BlowfishAux, - Codec.Encryption.DESAux, - Codec.Encryption.AESAux, - Data.Digest.MD5Aux +extra-source-files: ChangeLog.md -Executable SymmetricTest - Main-Is: SymmetricTest.hs - Ghc-options: -fregs-graph - Other-modules: Codec.Utils - Codec.Encryption.Blowfish - Codec.Encryption.Modes - Codec.Encryption.Padding - Codec.Encryption.DES - Codec.Encryption.AES - Data.LargeWord +tested-with: GHC ==7.0.1, GHC ==7.0.4, GHC ==7.2.2, GHC ==7.4.2, GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.3, GHC ==8.0.2, GHC ==8.2.2, GHC ==8.4.4, GHC ==8.6.5, GHC ==8.8.4, GHC ==8.10.4, GHC ==9.0.2, GHC ==9.2.2, GHC ==9.4.4 -Executable SHA1Test - Main-Is: SHA1Test.hs - Ghc-options: -fregs-graph - Other-modules: Codec.Text.Raw - Data.Digest.SHA1 +------------------ +-- main library -- +------------------ -Executable RSATest - Main-Is: RSATest.hs - Ghc-options: -fregs-graph - Other-modules: Codec.Utils - Data.Digest.SHA1 - Codec.Encryption.RSA.MGF - Codec.Encryption.RSA.EMEOAEP - Codec.Encryption.RSA +common defaults + default-language: Haskell2010 + other-extensions: FlexibleInstances, TypeSynonymInstances -Executable QuickTest - Main-Is: QuickTest.hs - Ghc-options: -fregs-graph - Extensions: TypeSynonymInstances - Other-modules: Codec.Utils - Codec.Encryption.Blowfish - Codec.Encryption.AES - Codec.Encryption.Modes - Codec.Encryption.Padding - Data.LargeWord + -- NB: 'pretty' is needed by the "Codec.Text.Raw" API + build-depends: + , base >= 4.3 && < 4.18 + , pretty ^>= 1.0.1 || ^>= 1.1.0 -Executable HMACTest - Main-Is: HMACTest.hs - Other-modules: Codec.Utils - Data.HMAC + ghc-options: -fregs-graph -Executable WordListTest - Main-Is: WordListTest.hs - Other-modules: Data.LargeWord + -- silence deprecation warnings for Haskell2010 compliant 'bitSize' method + -- as well as all the missing typeclass methods warnings + ghc-options: -fno-warn-deprecations -fno-warn-missing-methods + +library + import: defaults + + hs-source-dirs: src + + exposed-modules: + Codec.Binary.BubbleBabble + Codec.Encryption.RSA + Codec.Encryption.RSA.EMEOAEP + Codec.Encryption.RSA.MGF + Codec.Encryption.RSA.NumberTheory + Codec.Encryption.DES + Codec.Encryption.AES + Codec.Encryption.TEA + Codec.Encryption.Blowfish + Codec.Encryption.Modes + Codec.Encryption.Padding + Codec.Text.Raw + Codec.Utils + Data.Digest.MD5 + Data.Digest.SHA1 + Data.Digest.SHA2 + Data.Digest.SHA224 + Data.Digest.SHA256 + Data.Digest.SHA384 + Data.Digest.SHA512 + Data.LargeWord, + Data.HMAC + + other-modules: + Codec.Encryption.BlowfishAux + Codec.Encryption.DESAux + Codec.Encryption.AESAux + Data.Digest.MD5Aux + + -- NB: 'random' is currently /only/ used by the 'getPrime' operation + build-depends: + , array ^>= 0.3.0 || ^>= 0.4.0 || ^>= 0.5.0 + , random ^>= 1.0 || ^>= 1.1 || ^>= 1.2 + +----------------- +-- test suites -- +----------------- + +common test-defaults + import: defaults + + hs-source-dirs: src-test + + -- depend on main library + build-depends: Crypto + + build-depends: + , QuickCheck ^>= 2.14.2 + , HUnit ^>= 1.6.2 + + +test-suite SymmetricTest + import: test-defaults + type: exitcode-stdio-1.0 + + Main-Is: SymmetricTest.hs + +test-suite SHA1Test + import: test-defaults + type: exitcode-stdio-1.0 + + Main-Is: SHA1Test.hs + +test-suite SHA2Test + import: test-defaults + type: exitcode-stdio-1.0 + + Main-Is: SHA2Test.hs + +test-suite RSATest + import: test-defaults + type: exitcode-stdio-1.0 + + Main-Is: RSATest.hs + +test-suite QuickTest + import: test-defaults + type: exitcode-stdio-1.0 + + main-is: QuickTest.hs + +test-suite HMACTest + import: test-defaults + type: exitcode-stdio-1.0 + + Main-Is: HMACTest.hs + +test-suite WordListTest + import: test-defaults + type: exitcode-stdio-1.0 + + Main-Is: WordListTest.hs diff --git a/CryptoHomePage.html b/CryptoHomePage.html deleted file mode 100644 --- a/CryptoHomePage.html +++ /dev/null @@ -1,51 +0,0 @@ - - - - -The Haskell Cryptographic Library - - -

The Haskell Cryptographic Library

- -

The Haskell Cryptographic Library collects together existing Haskell - cryptographic functions into one cabalized package, with - HUnit tests, - QuickCheck - properties, examples showing how to interwork with - other cryptographic implementations and examples showing how to - handle other - ASN.1 - definitions.

- -

Downloading

-

Stable releases of Crypto can be found in the Hackage package database:

- - - -

For the latest version, you can use the development repository. You can download it:

- - - -

Resources

- - -

Contact

- -

All questions, comments, bug reports, flames, - requests for updates / changes - and suggestions should be directed to - .

- diff --git a/Data/Digest/MD5.hs b/Data/Digest/MD5.hs deleted file mode 100644 --- a/Data/Digest/MD5.hs +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Digest.MD5 --- Copyright : (c) Dominic Steinitz 2004 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- Takes the MD5 module supplied by Ian Lynagh and wraps it so it --- takes [Octet] and returns [Octet] where the length of the result --- is always 16. --- See --- and . --- ------------------------------------------------------------------------------ - -module Data.Digest.MD5 ( - -- * Function Types - hash) where - -import Data.Digest.MD5Aux -import Codec.Utils -import Data.Char(chr) -import Data.List(unfoldr) -import Numeric(readHex) - --- | Take [Octet] and return [Octet] according to the standard. --- The length of the result is always 16 octets or 128 bits as required --- by the standard. - -hash :: [Octet] -> [Octet] -hash xs = - unfoldr f $ md5s $ Str $ map (chr . fromIntegral) xs - where f :: String -> Maybe (Octet,String) - f [] = - Nothing - f (x:y:zs) = - Just (fromIntegral a,zs) - where [(a,_)] = readHex (x:y:[]) diff --git a/Data/Digest/MD5Aux.hs b/Data/Digest/MD5Aux.hs deleted file mode 100644 --- a/Data/Digest/MD5Aux.hs +++ /dev/null @@ -1,355 +0,0 @@ -module Data.Digest.MD5Aux - (md5, md5s, md5i, - MD5(..), ABCD(..), - Zord64, Str(..), BoolList(..), WordList(..)) where - -import Data.Char -import Data.Bits -import Data.Word - -{- -Nasty kludge to create a type Zord64 which is really a Word64 but works -how we want in hugs ands nhc98 too... -Also need a rotate left function that actually works. - -#ifdef __GLASGOW_HASKELL__ -#define rotL rotateL -#include "Zord64_EASY.hs" -#else - -> import Zord64_HARD - -> rotL :: Word32 -> Rotation -> Word32 -> rotL a s = shiftL a s .|. shiftL a (s-32) - -#endif --} - -rotL x = rotateL x -type Zord64 = Word64 - --- ===================== TYPES AND CLASS DEFINTIONS ======================== - - -type XYZ = (Word32, Word32, Word32) -type Rotation = Int -newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) -newtype Str = Str String -newtype BoolList = BoolList [Bool] -newtype WordList = WordList ([Word32], Zord64) - --- Anything we want to work out the MD5 of must be an instance of class MD5 - -class MD5 a where - get_next :: a -> ([Word32], Int, a) -- get the next blocks worth - -- \ \ \------ the rest of the input - -- \ \--------- the number of bits returned - -- \--------------- the bits returned in 32bit words - len_pad :: Zord64 -> a -> a -- append the padding and length - finished :: a -> Bool -- Have we run out of input yet? - - --- Mainly exists because it's fairly easy to do MD5s on input where the --- length is not a multiple of 8 - -instance MD5 BoolList where - get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) - where (ys, zs) = splitAt 512 s - len_pad l (BoolList bs) - = BoolList (bs ++ [True] - ++ replicate (fromIntegral $ (447 - l) .&. 511) False - ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] - ) - where mangle [] = [] - mangle xs = reverse ys ++ mangle zs - where (ys, zs) = splitAt 8 xs - finished (BoolList s) = s == [] - - --- The string instance is fairly straightforward - -instance MD5 Str where - get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) - where (ys, zs) = splitAt 64 s - len_pad c64 (Str s) = Str (s ++ padding ++ l) - where padding = '\128':replicate (fromIntegral zeros) '\000' - zeros = shiftR ((440 - c64) .&. 511) 3 - l = length_to_chars 8 c64 - finished (Str s) = s == "" - - --- YA instance that is believed will be useful - -instance MD5 WordList where - get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) - where (xs, ys) = splitAt 16 ws - taken = if l > 511 then 512 else l .&. 511 - len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) - where beginning = if length ws > 0 then start ++ lastone' else [] - start = init ws - lastone = last ws - offset = c64 .&. 31 - lastone' = [if offset > 0 then lastone + theone else lastone] - theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) - (fromIntegral $ offset .&. (31 - 7)) - nextish = if offset == 0 then [128] else [] - c64' = c64 + (32 - offset) - num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) - blanks = replicate num_blanks 0 - lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) - topsize = fromIntegral $ shiftR c64 32 - size = [lowsize, topsize] - newlen = l .&. (complement 511) - + if c64 .&. 511 >= 448 then 1024 else 512 - finished (WordList (_, z)) = z == 0 - - -instance Num ABCD where - ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) - - --- ===================== EXPORTED FUNCTIONS ======================== - - --- The simplest function, gives you the MD5 of a string as 4-tuple of --- 32bit words. - -md5 :: (MD5 a) => a -> ABCD -md5 m = md5_main False 0 magic_numbers m - - --- Returns a hex number ala the md5sum program - -md5s :: (MD5 a) => a -> String -md5s = abcd_to_string . md5 - - --- Returns an integer equivalent to the above hex number - -md5i :: (MD5 a) => a -> Integer -md5i = abcd_to_integer . md5 - - --- ===================== THE CORE ALGORITHM ======================== - - --- Decides what to do. The first argument indicates if padding has been --- added. The second is the length mod 2^64 so far. Then we have the --- starting state, the rest of the string and the final state. - -md5_main :: (MD5 a) => - Bool -- Have we added padding yet? - -> Zord64 -- The length so far mod 2^64 - -> ABCD -- The initial state - -> a -- The non-processed portion of the message - -> ABCD -- The resulting state -md5_main padded ilen abcd m - = if finished m && padded - then abcd - else md5_main padded' (ilen + 512) (abcd + abcd') m'' - where (m16, l, m') = get_next m - len' = ilen + fromIntegral l - ((m16', _, m''), padded') = if not padded && l < 512 - then (get_next $ len_pad len' m, True) - else ((m16, l, m'), padded) - abcd' = md5_do_block abcd m16' - - --- md5_do_block processes a 512 bit block by calling md5_round 4 times to --- apply each round with the correct constants and permutations of the --- block - -md5_do_block :: ABCD -- Initial state - -> [Word32] -- The block to be processed - 16 32bit words - -> ABCD -- Resulting state -md5_do_block abcd0 w = abcd4 - where (r1, r2, r3, r4) = rounds - {- - map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] - -- [(5 * x + 1) `mod` 16 | x <- [0..15]] - map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] - -- [(3 * x + 5) `mod` 16 | x <- [0..15]] - map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] - -- [(7 * x) `mod` 16 | x <- [0..15]] - -} - perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] - = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] - perm5 _ = error "broke at perm5" - perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] - = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] - perm3 _ = error "broke at perm3" - perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] - = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] - perm7 _ = error "broke at perm7" - abcd1 = md5_round md5_f abcd0 w r1 - abcd2 = md5_round md5_g abcd1 (perm5 w) r2 - abcd3 = md5_round md5_h abcd2 (perm3 w) r3 - abcd4 = md5_round md5_i abcd3 (perm7 w) r4 - - --- md5_round does one of the rounds. It takes an auxiliary function and foldls --- (md5_inner_function f) to repeatedly apply it to the initial state with the --- correct constants - -md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I - -- for those of you with a copy of - -- the prayer book^W^WRFC) - -> ABCD -- Initial state - -> [Word32] -- The 16 32bit words of input - -> [(Rotation, Word32)] -- The list of 16 rotations and - -- additive constants - -> ABCD -- Resulting state -md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' - where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns - - --- Apply one of the functions md5_[fghi] and put the new ABCD together - -md5_inner_function :: (XYZ -> Word32) -- Auxiliary function - -> ABCD -- Initial state - -> (Rotation, Word32) -- The rotation and additive - -- constant (X[i] + T[j]) - -> ABCD -- Resulting state -md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) - where mid_a = a + f(b,c,d) + ki - rot_a = rotL mid_a s - a' = b + rot_a - - --- The 4 auxiliary functions - -md5_f :: XYZ -> Word32 -md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) -{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} - -md5_g :: XYZ -> Word32 -md5_g (x, y, z) = md5_f (z, x, y) -{- was: (x .&. z) .|. (y .&. (complement z)) -} - -md5_h :: XYZ -> Word32 -md5_h (x, y, z) = x `xor` y `xor` z - -md5_i :: XYZ -> Word32 -md5_i (x, y, z) = y `xor` (x .|. (complement z)) - - --- The magic numbers from the RFC. - -magic_numbers :: ABCD -magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) - - --- The 4 lists of (rotation, additive constant) tuples, one for each round - -rounds :: ([(Rotation, Word32)], - [(Rotation, Word32)], - [(Rotation, Word32)], - [(Rotation, Word32)]) -rounds = (r1, r2, r3, r4) - where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), - (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), - (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), - (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), - (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), - (s14, 0x49b40821)] - r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), - (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), - (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), - (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), - (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), - (s24, 0x8d2a4c8a)] - r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), - (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), - (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), - (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), - (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), - (s34, 0xc4ac5665)] - r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), - (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), - (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), - (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), - (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), - (s44, 0xeb86d391)] - s11 = 7 - s12 = 12 - s13 = 17 - s14 = 22 - s21 = 5 - s22 = 9 - s23 = 14 - s24 = 20 - s31 = 4 - s32 = 11 - s33 = 16 - s34 = 23 - s41 = 6 - s42 = 10 - s43 = 15 - s44 = 21 - - --- ===================== CONVERSION FUNCTIONS ======================== - - --- Turn the 4 32 bit words into a string representing the hex number they --- represent. - -abcd_to_string :: ABCD -> String -abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] - - --- Split the 32 bit word up, swap the chunks over and convert the numbers --- to their hex equivalents. - -display_32bits_as_hex :: Word32 -> String -display_32bits_as_hex w = swap_pairs cs - where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] - getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) - swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs - swap_pairs _ = [] - --- Convert to an integer, performing endianness magic as we go - -abcd_to_integer :: ABCD -> Integer -abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) - + rev_num b * 2^(64 :: Int) - + rev_num c * 2^(32 :: Int) - + rev_num d - -rev_num :: Word32 -> Integer -rev_num i = toInteger j `mod` (2^(32 :: Int)) - -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ - where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) - 0 [0,8,16,24] - --- Used to convert a 64 byte string to 16 32bit words - -string_to_word32s :: String -> [Word32] -string_to_word32s "" = [] -string_to_word32s ss = this:string_to_word32s ss' - where (s, ss') = splitAt 4 ss - this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s - - --- Used to convert a list of 512 bools to 16 32bit words - -bools_to_word32s :: [Bool] -> [Word32] -bools_to_word32s [] = [] -bools_to_word32s bs = this:bools_to_word32s rest - where (bs1, bs1') = splitAt 8 bs - (bs2, bs2') = splitAt 8 bs1' - (bs3, bs3') = splitAt 8 bs2' - (bs4, rest) = splitAt 8 bs3' - this = boolss_to_word32 [bs1, bs2, bs3, bs4] - bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 - boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 - - --- Convert the size into a list of characters used by the len_pad function --- for strings - -length_to_chars :: Int -> Zord64 -> String -length_to_chars 0 _ = [] -length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) - where this = chr $ fromIntegral $ n .&. 255 - diff --git a/Data/Digest/SHA1.hs b/Data/Digest/SHA1.hs deleted file mode 100644 --- a/Data/Digest/SHA1.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# OPTIONS_GHC -funbox-strict-fields #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Digest.SHA1 --- Copyright : (c) Dominic Steinitz 2007 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- Take [Word8] and return Word160. --- See for the specification. --- ------------------------------------------------------------------------------ - -module Data.Digest.SHA1( - Word160(Word160), - hash, - lift2, - toInteger - ) where - -import Data.Bits -import Data.List -import Data.Word -import Data.Array.IArray -import Codec.Utils -import Prelude hiding (toInteger) - -rotL :: Bits b => Int -> b -> b -rotL = flip rotateL - -data Word160 = Word160 {-# UNPACK #-} !Word32 - {-# UNPACK #-} !Word32 - {-# UNPACK #-} !Word32 - {-# UNPACK #-} !Word32 - {-# UNPACK #-} !Word32 - deriving (Eq, Show) - -toInteger :: Word160 -> Integer -toInteger (Word160 a b c d e) = let n = fromIntegral e + - (fromIntegral d `shiftL` 32) + - (fromIntegral c `shiftL` 64) + - (fromIntegral b `shiftL` 96) + - (fromIntegral a `shiftL` 128) - in n `seq` n - -lift2 :: (Word32 -> Word32 -> Word32) -> Word160 -> Word160 -> Word160 -lift2 f a@(Word160 x1 x2 x3 x4 x5) b@(Word160 y1 y2 y3 y4 y5) = - Word160 (f x1 y1) (f x2 y2) (f x3 y3) (f x4 y4) (f x5 y5) - -f n x y z - | n <= 19 = (x .&. y) .|. ((complement x) .&. z) - | n <= 39 = x `xor` y `xor` z - | n <= 59 = (x .&. y) .|. (x .&. z) .|. (y .&. z) - | n <= 79 = x `xor` y `xor` z - -k n - | n <= 19 = 0x5a827999 - | n <= 39 = 0x6ed9eba1 - | n <= 59 = 0x8f1bbcdc - | n <= 79 = 0xca62c1d6 - -data AccAndWord160 = AccAndWord160 !Int !Word160 - --- Word160 -> Word512 -> Word160 -oneBlock ss xs = tt - where - us :: Array Int Word32 - us = - accumArray (curry snd) 0 (0,79) (zip [0..15] xs ++ map (\(x,y) -> (x, rotL 1 y))[(i, xxor i) | i<-[16..79]]) - where - xxor i = us ! (i-16) `xor` us ! (i-3) `xor` us ! (i-8) `xor` us ! (i-14) - g (AccAndWord160 n (Word160 a b c d e)) w = - AccAndWord160 (n+1) (Word160 ((rotL 5 a) + (f n b c d) + e + w + (k n)) a (rotL 30 b) c d) - (AccAndWord160 _ tt) = foldl' g (AccAndWord160 0 ss) (elems us) - -ss :: Word160 -ss = Word160 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 - -pad = pad' 0 - where pad' l [] = [0x80] ++ ps ++ lb - where pl = (64-(l+9)) `mod` 64 - ps = replicate pl 0x00 - lb = i2osp 8 (8*l) - pad' l (x:xs) = x : (pad' $! l+1) xs -- otherwise (l+1) it will be deferred until replicate - -blockWord8sIn512 :: [Word8] -> [[Word8]] -blockWord8sIn512 = - unfoldr g - where - g [] = Nothing - g xs = Just (splitAt 64 xs) - -fromBytes :: (Num a, Bits a) => [a] -> a -fromBytes input = - let dofb accum [] = accum - dofb accum (x:xs) = dofb ((shiftL accum 8) .|. x) xs - in - dofb 0 input - -blockWord8sIn32 :: [Word8] -> [[Word8]] -blockWord8sIn32 = - unfoldr g - where - g [] = Nothing - g xs = Just (splitAt 4 xs) - -getWord32s :: [Word8] -> [Word32] -getWord32s = - map fromBytes . map (map fromIntegral) . blockWord8sIn32 - -blockWord32sIn512 :: [Word8] -> [[Word32]] -blockWord32sIn512 = (map getWord32s) . blockWord8sIn512 . pad - -hashOnce ss a = lift2 (+) ss (oneBlock ss a) - -hash :: [Word8] -> Word160 -hash = foldl' hashOnce ss . blockWord32sIn512 diff --git a/Data/Digest/SHA2.hs b/Data/Digest/SHA2.hs deleted file mode 100644 --- a/Data/Digest/SHA2.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# OPTIONS_GHC -funbox-strict-fields #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Digest.SHA2 --- Copyright : (c) Russell O'Connor 2006 --- License : BSD-style (see the file ReadMe.tex) --- --- Implements SHA-256, SHA-384, SHA-512, and SHA-224 as defined in FIPS 180-2 --- . --- ------------------------------------------------------------------------------ - -module Data.Digest.SHA2 (sha256, sha256Ascii, Hash256 - ,sha512, sha512Ascii, Hash512 - ,sha384, sha384Ascii, Hash384 - ,sha224, sha224Ascii, Hash224 - ,toOctets) where - -import Data.Word -import Data.Bits -import Data.List -import Numeric -import Test.HUnit - -ch x y z = (x .&. y) `xor` (complement x .&. z) -maj x y z = (x .&. y) `xor` (x .&. z) `xor` (y .&. z) - -class (Num w, Bits w) => ShaData w where - bigSigma0 :: w -> w - bigSigma1 :: w -> w - smallSigma0 :: w -> w - smallSigma1 :: w -> w - ks :: [w] - -instance ShaData Word32 where - bigSigma0 x = rotateR x 2 `xor` rotateR x 13 `xor` rotateR x 22 - bigSigma1 x = rotateR x 6 `xor` rotateR x 11 `xor` rotateR x 25 - smallSigma0 x = rotateR x 7 `xor` rotateR x 18 `xor` shiftR x 3 - smallSigma1 x = rotateR x 17 `xor` rotateR x 19 `xor` shiftR x 10 - ks = - [0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5 - ,0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174 - ,0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da - ,0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967 - ,0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85 - ,0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070 - ,0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3 - ,0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2] - -instance ShaData Word64 where - bigSigma0 x = rotateR x 28 `xor` rotateR x 34 `xor` rotateR x 39 - bigSigma1 x = rotateR x 14 `xor` rotateR x 18 `xor` rotateR x 41 - smallSigma0 x = rotateR x 1 `xor` rotateR x 8 `xor` shiftR x 7 - smallSigma1 x = rotateR x 19 `xor` rotateR x 61 `xor` shiftR x 6 - ks = - [0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f, 0xe9b5dba58189dbbc - ,0x3956c25bf348b538, 0x59f111f1b605d019, 0x923f82a4af194f9b, 0xab1c5ed5da6d8118 - ,0xd807aa98a3030242, 0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2 - ,0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235, 0xc19bf174cf692694 - ,0xe49b69c19ef14ad2, 0xefbe4786384f25e3, 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65 - ,0x2de92c6f592b0275, 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5 - ,0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f, 0xbf597fc7beef0ee4 - ,0xc6e00bf33da88fc2, 0xd5a79147930aa725, 0x06ca6351e003826f, 0x142929670a0e6e70 - ,0x27b70a8546d22ffc, 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df - ,0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6, 0x92722c851482353b - ,0xa2bfe8a14cf10364, 0xa81a664bbc423001, 0xc24b8b70d0f89791, 0xc76c51a30654be30 - ,0xd192e819d6ef5218, 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8 - ,0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99, 0x34b0bcb5e19b48a8 - ,0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb, 0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3 - ,0x748f82ee5defb2fc, 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec - ,0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915, 0xc67178f2e372532b - ,0xca273eceea26619c, 0xd186b8c721c0c207, 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178 - ,0x06f067aa72176fba, 0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b - ,0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc, 0x431d67c49c100d4c - ,0x4cc5d4becb3e42b6, 0x597f299cfc657e2a, 0x5fcb6fab3ad6faec, 0x6c44198c4a475817] - -blockSize = 16 - ------------------------------------------------------------------------------ --- | 'padding' currently requires that the bitSize of @a@ divide the bitSize --- of @w@ ------------------------------------------------------------------------------ -padding :: (ShaData w, Bits a, Integral a) => [a] -> [[w]] -padding x = unfoldr block $ paddingHelper x 0 (0::Int) (0::Integer) - where - block [] = Nothing - block x = Just $ splitAt blockSize x - paddingHelper x o on n | on == (bitSize o) = o:paddingHelper x 0 0 n - paddingHelper (x:xs) o on n | on < (bitSize o) = - paddingHelper xs ((shiftL o bs) .|. (fromIntegral x)) (on+bs) $! (n+fromIntegral bs) - where - bs = bitSize x - paddingHelper [] o on n = (shiftL (shiftL o 1 .|. 1) (bso-on-1)): - (zeros ((-(fromIntegral n-on+3*bso)) `mod` (blockSize*bso))) - [fromIntegral (shiftR n bso), fromIntegral n] - where - bso = bitSize o - zeros 0 = id - zeros n | 0 < n = let z=0 in (z:) . (zeros (n-bitSize z)) - -data Hash8 w = Hash8 !w !w !w !w !w !w !w !w deriving (Eq, Ord) - -type Hash256 = Hash8 Word32 -type Hash512 = Hash8 Word64 - -data Hash384 = Hash384 !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 deriving (Eq, Ord) -data Hash224 = Hash224 !Word32 !Word32 !Word32 !Word32 !Word32 !Word32 !Word32 deriving (Eq, Ord) - -instance (Integral a, Show a) => Show (Hash8 a) where - showsPrec _ (Hash8 a b c d e f g h) = - (showHex a) . (' ':) . - (showHex b) . (' ':) . - (showHex c) . (' ':) . - (showHex d) . (' ':) . - (showHex e) . (' ':) . - (showHex f) . (' ':) . - (showHex g) . (' ':) . - (showHex h) - -instance Show Hash384 where - showsPrec _ (Hash384 a b c d e f) = - (showHex a) . (' ':) . - (showHex b) . (' ':) . - (showHex c) . (' ':) . - (showHex d) . (' ':) . - (showHex e) . (' ':) . - (showHex f) - -instance Show Hash224 where - showsPrec _ (Hash224 a b c d e f g) = - (showHex a) . (' ':) . - (showHex b) . (' ':) . - (showHex c) . (' ':) . - (showHex d) . (' ':) . - (showHex e) . (' ':) . - (showHex f) . (' ':) . - (showHex g) - -class (Eq h, Ord h, Show h) => Hash h where - toOctets :: h -> [Word8] - -bitsToOctets x = helper (bitSize x) x [] - where - helper s x r | s <= 0 = r - | otherwise = helper (s-bs) (shiftR x bs) ((fromIntegral x):r) - where - bs = bitSize (head r) - -instance (Integral h, Bits h, Show h) => Hash (Hash8 h) where - toOctets (Hash8 x0 x1 x2 x3 x4 x5 x6 x7) = bitsToOctets =<< [x0, x1, x2, x3, x4, x5, x6, x7] - -instance Hash Hash384 where - toOctets (Hash384 x0 x1 x2 x3 x4 x5) = bitsToOctets =<< [x0, x1, x2, x3, x4, x5] - -instance Hash Hash224 where - toOctets (Hash224 x0 x1 x2 x3 x4 x5 x6) = bitsToOctets =<< [x0, x1, x2, x3, x4, x5, x6] - -shaStep :: (ShaData w) => Hash8 w -> [w] -> Hash8 w -shaStep h m = (foldl' (flip id) h (zipWith mkStep3 ks ws)) `plus` h - where - ws = m++zipWith4 smallSigma (drop (blockSize-2) ws) (drop (blockSize-7) ws) - (drop (blockSize-15) ws) (drop (blockSize-16) ws) - where - smallSigma a b c d = smallSigma1 a + b + smallSigma0 c + d - mkStep3 k w (Hash8 a b c d e f g h) = Hash8 (t1+t2) a b c (d+t1) e f g - where - t1 = h + bigSigma1 e + ch e f g + k + w - t2 = bigSigma0 a + maj a b c - (Hash8 x0 x1 x2 x3 x4 x5 x6 x7) `plus` (Hash8 y0 y1 y2 y3 y4 y5 y6 y7) = - Hash8 (x0+y0) (x1+y1) (x2+y2) (x3+y3) (x4+y4) (x5+y5) (x6+y6) (x7+y7) - ------------------------------------------------------------------------------ --- | Due to the limitations of 'padding', 'sha' currently requires that the --- bitSize of @a@ divide the bitSize of @w@ ------------------------------------------------------------------------------ -sha :: (ShaData w, Bits a, Integral a) => Hash8 w -> [a] -> Hash8 w -sha h0 x = foldl' shaStep h0 $ padding x - -stringToOctets :: String -> [Word8] -stringToOctets = map (fromIntegral . fromEnum) - ------------------------------------------------------------------------------ --- | 'sha256' currently requires that the bitSize of @a@ divide 32 ------------------------------------------------------------------------------ -sha256 :: (Bits a, Integral a) => [a] -> Hash256 -sha256 = sha $ - Hash8 0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a 0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19 - ------------------------------------------------------------------------------ --- | 'sha384' currently requires that the bitSize of @a@ divide 64 ------------------------------------------------------------------------------ -sha384 :: (Bits a, Integral a) => [a] -> Hash384 -sha384 x = Hash384 x0 x1 x2 x3 x4 x5 - where - Hash8 x0 x1 x2 x3 x4 x5 x6 x7 = flip sha x $ - Hash8 0xcbbb9d5dc1059ed8 0x629a292a367cd507 0x9159015a3070dd17 0x152fecd8f70e5939 - 0x67332667ffc00b31 0x8eb44a8768581511 0xdb0c2e0d64f98fa7 0x47b5481dbefa4fa4 - ------------------------------------------------------------------------------ --- | 'sha384' currently requires that the bitSize of @a@ divide 64 ------------------------------------------------------------------------------ -sha512 :: (Bits a, Integral a) => [a] -> Hash512 -sha512 = sha $ - Hash8 0x6a09e667f3bcc908 0xbb67ae8584caa73b 0x3c6ef372fe94f82b 0xa54ff53a5f1d36f1 - 0x510e527fade682d1 0x9b05688c2b3e6c1f 0x1f83d9abfb41bd6b 0x5be0cd19137e2179 - ------------------------------------------------------------------------------ --- | 'sha224' currently requires that the bitSize of @a@ divide 32 ------------------------------------------------------------------------------ -sha224 :: (Bits a, Integral a) => [a] -> Hash224 -sha224 x = Hash224 x0 x1 x2 x3 x4 x5 x6 - where - Hash8 x0 x1 x2 x3 x4 x5 x6 x7 = flip sha x $ - Hash8 0xc1059ed8 0x367cd507 0x3070dd17 0xf70e5939 0xffc00b31 0x68581511 0x64f98fa7 0xbefa4fa4 - ------------------------------------------------------------------------------ --- ** Hashing Strings --- | @shaXXXAscii@ assumes that all characters of the strings are --- ISO-latin-1 characters. ie. each characters fits in one octet. ------------------------------------------------------------------------------ -sha256Ascii :: String -> Hash256 -sha256Ascii = sha256 . stringToOctets - -sha384Ascii :: String -> Hash384 -sha384Ascii = sha384 . stringToOctets - -sha512Ascii :: String -> Hash512 -sha512Ascii = sha512 . stringToOctets - -sha224Ascii :: String -> Hash224 -sha224Ascii = sha224 . stringToOctets - ------------------------------------------------------------------------------ --- ** Test cases --- | Below are test cases from the FIPS 180-2 document ------------------------------------------------------------------------------ - --- Should this go into it's own module? - -test_sha256 = "SHA-256" ~: test - [sha256Ascii "abc" ~?= - Hash8 0xba7816bf 0x8f01cfea 0x414140de 0x5dae2223 0xb00361a3 0x96177a9c 0xb410ff61 0xf20015ad - ,sha256Ascii "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" ~?= - Hash8 0x248d6a61 0xd20638b8 0xe5c02693 0x0c3e6039 0xa33ce459 0x64ff2167 0xf6ecedd4 0x19db06c1 - ,sha256Ascii (replicate 1000000 'a') ~?= - Hash8 0xcdc76e5c 0x9914fb92 0x81a1c7e2 0x84d73e67 0xf1809a48 0xa497200e 0x046d39cc 0xc7112cd0] - -test_sha512 = "SHA-512" ~: test - [sha512Ascii "abc" ~?= - Hash8 0xddaf35a193617aba 0xcc417349ae204131 0x12e6fa4e89a97ea2 0x0a9eeee64b55d39a - 0x2192992a274fc1a8 0x36ba3c23a3feebbd 0x454d4423643ce80e 0x2a9ac94fa54ca49f - ,sha512Ascii ("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmn"++ - "hijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu") ~?= - Hash8 0x8e959b75dae313da 0x8cf4f72814fc143f 0x8f7779c6eb9f7fa1 0x7299aeadb6889018 - 0x501d289e4900f7e4 0x331b99dec4b5433a 0xc7d329eeb6dd2654 0x5e96e55b874be909 - ,sha512Ascii (replicate 1000000 'a') ~?= - Hash8 0xe718483d0ce76964 0x4e2e42c7bc15b463 0x8e1f98b13b204428 0x5632a803afa973eb - 0xde0ff244877ea60a 0x4cb0432ce577c31b 0xeb009c5c2c49aa2e 0x4eadb217ad8cc09b] - -test_sha384 = "SHA-384" ~: test - [sha384Ascii "abc" ~?= - Hash384 0xcb00753f45a35e8b 0xb5a03d699ac65007 0x272c32ab0eded163 0x1a8b605a43ff5bed - 0x8086072ba1e7cc23 0x58baeca134c825a7 - ,sha384Ascii ("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmn"++ - "hijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu") ~?= - Hash384 0x09330c33f71147e8 0x3d192fc782cd1b47 0x53111b173b3b05d2 0x2fa08086e3b0f712 - 0xfcc7c71a557e2db9 0x66c3e9fa91746039 - ,sha384Ascii (replicate 1000000 'a') ~?= - Hash384 0x9d0e1809716474cb 0x086e834e310a4a1c 0xed149e9c00f24852 0x7972cec5704c2a5b - 0x07b8b3dc38ecc4eb 0xae97ddd87f3d8985] - -test_sha224 = "SHA-224" ~: test - [sha224Ascii "abc" ~?= - Hash224 0x23097d22 0x3405d822 0x8642a477 0xbda255b3 0x2aadbce4 0xbda0b3f7 0xe36c9da7 - ,sha224Ascii "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" ~?= - Hash224 0x75388b16 0x512776cc 0x5dba5da1 0xfd890150 0xb0c6455c 0xb4f58b19 0x52522525 - ,sha224Ascii (replicate 1000000 'a') ~?= - Hash224 0x20794655 0x980c91d8 0xbbb4c1ea 0x97618a4b 0xf03f4258 0x1948b2ee 0x4ee7ad67] - -test_sha2 = "SHA-2" ~: test - [test_sha256, test_sha512, test_sha384, test_sha224] - --- Test with: --- ghc -no-recomp -O --make Data/Digest/SHA2.hs -main-is Data.Digest.SHA2.moduleTest -o moduleTest && ./moduleTest && rm moduleTest -moduleTest = runTestTT test_sha2 diff --git a/Data/Digest/SHA224.hs b/Data/Digest/SHA224.hs deleted file mode 100644 --- a/Data/Digest/SHA224.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Digest.SHA224 --- Copyright : (c) Russell O'Connor 2006 --- License : BSD-style (see the file ReadMe.tex) --- --- Takes the SHA2 module supplied and wraps it so it --- takes [Octet] and returns [Octet] where the length of the result --- is always 28. --- and . --- ------------------------------------------------------------------------------ - -module Data.Digest.SHA224 ( - -- * Function Types - hash) where - -import Data.Digest.SHA2 as SHA2 -import Codec.Utils - --- | Take [Octet] and return [Octet] according to the standard. --- The length of the result is always 28 octets or 224 bits as required --- by the standard. - -hash :: [Octet] -> [Octet] -hash = SHA2.toOctets . SHA2.sha224 diff --git a/Data/Digest/SHA256.hs b/Data/Digest/SHA256.hs deleted file mode 100644 --- a/Data/Digest/SHA256.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Digest.SHA256 --- Copyright : (c) Russell O'Connor 2006 --- License : BSD-style (see the file ReadMe.tex) --- --- Takes the SHA2 module supplied and wraps it so it --- takes [Octet] and returns [Octet] where the length of the result --- is always 32. --- and . --- ------------------------------------------------------------------------------ - -module Data.Digest.SHA256 ( - -- * Function Types - hash) where - -import Data.Digest.SHA2 as SHA2 -import Codec.Utils - --- | Take [Octet] and return [Octet] according to the standard. --- The length of the result is always 32 octets or 256 bits as required --- by the standard. - -hash :: [Octet] -> [Octet] -hash = SHA2.toOctets . SHA2.sha256 diff --git a/Data/Digest/SHA384.hs b/Data/Digest/SHA384.hs deleted file mode 100644 --- a/Data/Digest/SHA384.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Digest.SHA384 --- Copyright : (c) Russell O'Connor 2006 --- License : BSD-style (see the file ReadMe.tex) --- --- Takes the SHA2 module supplied and wraps it so it --- takes [Octet] and returns [Octet] where the length of the result --- is always 48. --- and . --- ------------------------------------------------------------------------------ - -module Data.Digest.SHA384 ( - -- * Function Types - hash) where - -import Data.Digest.SHA2 as SHA2 -import Codec.Utils - --- | Take [Octet] and return [Octet] according to the standard. --- The length of the result is always 48 octets or 384 bits as required --- by the standard. - -hash :: [Octet] -> [Octet] -hash = SHA2.toOctets . SHA2.sha384 diff --git a/Data/Digest/SHA512.hs b/Data/Digest/SHA512.hs deleted file mode 100644 --- a/Data/Digest/SHA512.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Digest.SHA512 --- Copyright : (c) Russell O'Connor 2006 --- License : BSD-style (see the file ReadMe.tex) --- --- Takes the SHA2 module supplied and wraps it so it --- takes [Octet] and returns [Octet] where the length of the result --- is always 64. --- and . --- ------------------------------------------------------------------------------ - -module Data.Digest.SHA512 ( - -- * Function Types - hash) where - -import Data.Digest.SHA2 as SHA2 -import Codec.Utils - --- | Take [Octet] and return [Octet] according to the standard. --- The length of the result is always 64 octets or 512 bits as required --- by the standard. - -hash :: [Octet] -> [Octet] -hash = SHA2.toOctets . SHA2.sha512 diff --git a/Data/HMAC.hs b/Data/HMAC.hs deleted file mode 100644 --- a/Data/HMAC.hs +++ /dev/null @@ -1,118 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.HMAC --- Copyright : (c) Greg Heartsfield 2007 --- License : BSD-style (see the file ReadMe.tex) --- --- Implements HMAC (hashed message authentication code) as defined in FIPS 198 --- . --- ------------------------------------------------------------------------------ - -module Data.HMAC( - -- * Function Types - hmac, hmac_sha1, hmac_md5, - -- * Data Types - HashMethod(HashMethod, digest, input_blocksize), - ) where - -import Data.Digest.SHA1 as SHA1 -import Data.Digest.MD5 as MD5 -import Data.Word (Word32) -import Data.Bits (shiftR, xor, bitSize, Bits) -import Codec.Utils (Octet) - --- | HMAC works over any hash function, which is represented by --- HashMethod. A hash function and input block size must --- be specified. - -data HashMethod = - HashMethod { -- | An arbitrary hash function - digest :: [Octet] -> [Octet], - -- | Bit size of an input block to the hash function - input_blocksize :: Int} - --- Some useful digest functions for use with HMAC. - -sha1_hm = HashMethod (w160_to_w8s . SHA1.hash) 512 -md5_hm = HashMethod MD5.hash 512 - --- | Compute an HMAC using SHA-1 as the underlying hash function. - -hmac_sha1 :: [Octet] -- ^ Secret key - -> [Octet] -- ^ Message text - -> [Octet] -- ^ Resulting HMAC-SHA1 value -hmac_sha1 = hmac sha1_hm - --- | Compute an HMAC using MD5 as the underlying hash function. - -hmac_md5 :: [Octet] -- ^ Secret key - -> [Octet] -- ^ Message text - -> [Octet] -- ^ Resulting HMAC-MD5 value -hmac_md5 = hmac md5_hm - -w160_to_w8s :: Word160 -> [Octet] -w160_to_w8s w = concat $ map w32_to_w8s (w160_to_w32s w) - -w160_to_w32s :: Word160 -> [Word32] -w160_to_w32s (Word160 a b c d e) = a : b : c : d : e : [] - -w32_to_w8s :: Word32 -> [Octet] -w32_to_w8s a = (fromIntegral (shiftR a 24)) : - (fromIntegral (shiftR a 16)) : - (fromIntegral (shiftR a 8)) : - (fromIntegral a) : [] - --- | Generalized function for creating HMACs on a specified --- hash function. - -hmac :: HashMethod -- ^ Hash function and associated block size - -> [Octet] -- ^ Secret key - -> [Octet] -- ^ Message text - -> [Octet] -- ^ Resulting HMAC value -hmac h uk m = hash (opad ++ (hash (ipad ++ m))) - where hash = digest h - (opad, ipad) = process_pads key - (make_start_pad bs opad_pattern) - (make_start_pad bs ipad_pattern) - bs = input_blocksize h - key = key_from_user h uk - --- Create a key of the proper size from the user-supplied key. --- Keys greater than blocksize get hashed and padded with zeroes. --- Keys same as blocksize are used as is. --- Keys shorter than blocksize are padding with zeroes. - -key_from_user :: HashMethod -> [Octet] -> [Octet] -key_from_user h uk = - case (compare (bitcount uk) (input_blocksize h)) of - GT -> fill_key ((digest h) uk) - LT -> fill_key uk - EQ -> uk - where fill_key kd = - kd ++ (take (((input_blocksize h) - (bitcount kd)) `div` 8) - (repeat 0x0)) - --- Create the inner/outer pad values by XOR'ing with the key. - -process_pads :: [Octet] -- Key - -> [Octet] -- opad - -> [Octet] -- ipad - -> ([Octet], [Octet]) -- new opad, new ipad -process_pads ks os is = - unzip $ zipWith3 (\k o i -> (k `xor` o, k `xor` i)) ks os is - --- Create padding values for a hash of a given bit size. - -make_start_pad :: Int -> Octet -> [Octet] -make_start_pad size pad = take (size `div` (bitSize pad)) $ repeat pad - --- Padding constants, per the spec. - -opad_pattern = 0x5c :: Octet -ipad_pattern = 0x36 :: Octet - --- Bit count of byte array. - -bitcount :: [Octet] -> Int -bitcount k = (length k) * (bitSize (head k)) diff --git a/Data/LargeWord.hs b/Data/LargeWord.hs deleted file mode 100644 --- a/Data/LargeWord.hs +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.LargeWord --- Copyright : (c) Dominic Steinitz 2004 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- Provides Word128, Word192 and Word256 and a way of producing other --- large words if required. --- ------------------------------------------------------------------------------ - -module Data.LargeWord - (LargeKey,Word96,Word128,Word160,Word192,Word224,Word256) where - -import Data.Word -import Data.Bits -import Numeric -import Data.Char - --- Keys have certain capabilities. - -class (Num a) => LargeWord a where - largeWordToInteger :: a -> Integer - integerToLargeWord :: Integer -> a - largeWordPlus :: a -> a -> a - largeWordAnd :: a -> a -> a - largeWordOr :: a -> a -> a - largeWordShift :: a -> Int -> a - largeWordXor :: a -> a -> a - largeBitSize :: a -> Int - --- Word32 is a key in the obvious way. - -instance LargeWord Word32 where - largeWordToInteger = toInteger - integerToLargeWord = fromInteger - largeWordPlus = (+) - largeWordAnd = (.&.) - largeWordOr = (.|.) - largeWordShift = shift - largeWordXor = xor - largeBitSize = bitSize - --- Word64 is a key in the obvious way. - -instance LargeWord Word64 where - largeWordToInteger = toInteger - integerToLargeWord = fromInteger - largeWordPlus = (+) - largeWordAnd = (.&.) - largeWordOr = (.|.) - largeWordShift = shift - largeWordXor = xor - largeBitSize = bitSize - --- Define larger keys from smaller ones. - -data LargeKey a b = LargeKey a b - deriving (Eq, Ord) - -instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => - LargeWord (LargeKey a b) where - largeWordToInteger (LargeKey lo hi) = - largeWordToInteger lo + (2^(bitSize lo)) * largeWordToInteger hi - integerToLargeWord x = - let (h,l) = x `quotRem` (2^(bitSize lo)) - (lo,hi) = (integerToLargeWord l, integerToLargeWord h) in - LargeKey lo hi - largeWordPlus (LargeKey alo ahi) (LargeKey blo bhi) = - LargeKey lo' hi' where - lo' = alo + blo - hi' = ahi + bhi + if lo' < alo then 1 else 0 - largeWordAnd (LargeKey alo ahi) (LargeKey blo bhi) = - LargeKey lo' hi' where - lo' = alo .&. blo - hi' = ahi .&. bhi - largeWordOr (LargeKey alo ahi) (LargeKey blo bhi) = - LargeKey lo' hi' where - lo' = alo .|. blo - hi' = ahi .|. bhi - largeWordXor (LargeKey alo ahi) (LargeKey blo bhi) = - LargeKey lo' hi' where - lo' = alo `xor` blo - hi' = ahi `xor` bhi - largeWordShift w 0 = w - largeWordShift (LargeKey lo hi) x = - if bitSize lo < bitSize hi - then LargeKey (shift lo x) - (shift hi x .|. (shift (conv lo) (x - (bitSize lo)))) - else LargeKey (shift lo x) - (shift hi x .|. (conv $ shift lo (x - (bitSize lo)))) - where conv = integerToLargeWord . largeWordToInteger - largeBitSize ~(LargeKey lo hi) = largeBitSize lo + largeBitSize hi - -instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => Show (LargeKey a b) where - showsPrec p = showInt . largeWordToInteger - -instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => - Num (LargeKey a b) where - (+) = largeWordPlus - fromInteger = integerToLargeWord - --- Larger keys are instances of Bits provided their constituents are keys. - -instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => - Bits (LargeKey a b) where - (.&.) = largeWordAnd - (.|.) = largeWordOr - xor = largeWordXor - shift = largeWordShift - bitSize = largeBitSize - -instance (Ord a, Bits a, Bounded a, Integral a, LargeWord a, - Bits b, Bounded b, Integral b, LargeWord b) => - Bounded (LargeKey a b) where - minBound = 0 - maxBound = - result where - result = - fromIntegral $ - (1 + fromIntegral (maxBound `asTypeOf` (boflk result)))* - (1 + fromIntegral (maxBound `asTypeOf` (aoflk result))) - 1 - -aoflk :: (LargeKey a b) -> a -aoflk = undefined -boflk :: (LargeKey a b) -> b -boflk = undefined - -instance (Ord a, Bits a, LargeWord a, Ord b, Bits b, LargeWord b) => - Integral (LargeKey a b) where - toInteger = largeWordToInteger - -instance (Ord a, Bits a, LargeWord a, Ord b, Bits b, LargeWord b) => - Real (LargeKey a b) - -instance Enum (LargeKey a b) - -type Word96 = LargeKey Word32 Word64 -type Word128 = LargeKey Word64 Word64 -type Word160 = LargeKey Word32 Word128 -type Word192 = LargeKey Word64 Word128 -type Word224 = LargeKey Word32 Word192 -type Word256 = LargeKey Word64 Word192 diff --git a/HMACTest.hs b/HMACTest.hs deleted file mode 100644 --- a/HMACTest.hs +++ /dev/null @@ -1,183 +0,0 @@ -module Main(main) where - -import Data.HMAC -import Test.HUnit -import Codec.Utils (Octet) -import Data.Char(ord) - --- HMAC-SHA1 tests from --- - --- HMAC-MD5 tests from --- - --- Test #1: SHA-1 64-byte key (single block) - -hmacTest1 = - TestCase ( - assertEqual "Test HMAC-SHA1 #1 with 64-byte key" - hmac_1 (hmac_sha1 key_1 message_1) - ) - -message_1 = string2words "Sample #1" - -key_1 :: [Octet] -key_1 = - [0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, - 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, - 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, - 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, - 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, - 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, - 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, - 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f] - -hmac_1 :: [Octet] -hmac_1 = - [0x4f, 0x4c, 0xa3, 0xd5, 0xd6, 0x8b, 0xa7, 0xcc, - 0x0a, 0x12, 0x08, 0xc9, 0xc6, 0x1e, 0x9c, 0x5d, - 0xa0, 0x40, 0x3c, 0x0a] - - --- Test #2: SHA 20-byte key (short block) - -hmacTest2 = - TestCase ( - assertEqual "Test HMAC-SHA1 #2 with 20-byte key" - hmac_2 (hmac_sha1 key_2 message_2) - ) - -message_2 = string2words "Sample #2" - -key_2 :: [Octet] -key_2 = - [0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, - 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, - 0x40, 0x41, 0x42, 0x43] - -hmac_2 :: [Octet] -hmac_2 = - [0x09, 0x22, 0xd3, 0x40, 0x5f, 0xaa, 0x3d, 0x19, - 0x4f, 0x82, 0xa4, 0x58, 0x30, 0x73, 0x7d, 0x5c, - 0xc6, 0xc7, 0x5d, 0x24] - --- Test #3: SHA 100-byte key (multi-block) - -hmacTest3 = - TestCase ( - assertEqual "Test HMAC-SHA1 #3 with 100-byte key" - hmac_3 (hmac_sha1 key_3 message_3) - ) - -message_3 = string2words "Sample #3" - -key_3 :: [Octet] -key_3 = - [0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, - 0x58, 0x59, 0x5a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, - 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, - 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, - 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, - 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f, - 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, - 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f, - 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, - 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, - 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, - 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf, - 0xb0, 0xb1, 0xb2, 0xb3] - -hmac_3 :: [Octet] -hmac_3 = - [0xbc, 0xf4, 0x1e, 0xab, 0x8b, 0xb2, 0xd8, 0x02, - 0xf3, 0xd0, 0x5c, 0xaf, 0x7c, 0xb0, 0x92, 0xec, - 0xf8, 0xd1, 0xa3, 0xaa] - --- Test #4: SHA 49-byte key (truncated to 12-byte HMAC) - -hmacTest4 = - TestCase ( - assertEqual "Test HMAC-SHA1 #4 with 49-byte key, truncated to 12-bytes" - hmac_4 (take 12 (hmac_sha1 key_4 message_4)) - ) - -message_4 = string2words "Sample #4" - -key_4 :: [Octet] -key_4 = - [0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, - 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f, - 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, - 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f, - 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, - 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, - 0xa0] - -hmac_4 :: [Octet] -hmac_4 = - [0x9e, 0xa8, 0x86, 0xef, 0xe2, 0x68, 0xdb, 0xec, - 0xce, 0x42, 0x0c, 0x75] - --- Test #5: MD5 Test from rfc 2104 (16-byte key) - -hmacTest5 = - TestCase ( - assertEqual "Test HMAC-MD5 with 16-byte key" - hmac_5 (hmac_md5 key_5 message_5) - ) - -message_5 = string2words "Hi There" - -key_5 :: [Octet] -key_5 = take 16 (repeat 0xb) - -hmac_5 :: [Octet] -hmac_5 = [0x92, 0x94, 0x72, 0x7a, 0x36, 0x38, 0xbb, 0x1c, - 0x13, 0xf4, 0x8e, 0xf8, 0x15, 0x8b, 0xfc, 0x9d] - --- Test #6: MD5 Test from rfc 2104 (28-byte key) - -hmacTest6 = - TestCase ( - assertEqual "Test HMAC-MD5 with 28-byte key" - hmac_6 (hmac_md5 key_6 message_6) - ) - -message_6 = string2words "what do ya want for nothing?" - -key_6 :: [Octet] -key_6 = string2words "Jefe" - -hmac_6 :: [Octet] -hmac_6 = [0x75, 0x0c, 0x78, 0x3e, 0x6a, 0xb0, 0xb5, 0x03, - 0xea, 0xa8, 0x6e, 0x31, 0x0a, 0x5d, 0xb7, 0x38] - --- Test #7: MD5 Test from rfc 2104 (16-byte key) - -hmacTest7 = - TestCase ( - assertEqual "Test HMAC-MD5 with 16-byte key" - hmac_7 (hmac_md5 key_7 message_7) - ) - -message_7 = take 50 (repeat 0xdd) - -key_7 :: [Octet] -key_7 = take 16 (repeat 0xaa) - -hmac_7 :: [Octet] -hmac_7 = [0x56, 0xbe, 0x34, 0x52, 0x1d, 0x14, 0x4c, 0x88, - 0xdb, 0xb8, 0xc7, 0x33, 0xf0, 0xe8, 0xb3, 0xf6] - - -string2words :: String -> [Octet] -string2words = map (fromIntegral . ord) - --- Run the tests - -tests = - TestList [hmacTest1, hmacTest2, hmacTest3, hmacTest4, - hmacTest5, hmacTest6, hmacTest7] - -main = runTestTT tests - diff --git a/QuickTest.hs b/QuickTest.hs deleted file mode 100644 --- a/QuickTest.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} - -module Main where - -import Codec.Utils -import Codec.Encryption.Blowfish as Blowfish -import Codec.Encryption.AES as AES -import Codec.Encryption.Modes -import Codec.Encryption.Padding -import Data.LargeWord -import Data.Word -import Data.Bits -import Numeric -import Data.Char -import Test.QuickCheck - -instance Arbitrary Word128 where - arbitrary = - do n <- choose ((fromIntegral (minBound::Word128))::Integer, - (fromIntegral (maxBound::Word128))::Integer) - return (fromIntegral n) - -prop_decryptEncrypt k b = b == Blowfish.decrypt k (Blowfish.encrypt k b) - where types = (k :: Word8, b :: Word64) - -prop_AESIdempotent k b = b == AES.decrypt k (AES.encrypt k b) - where types = (k :: Word128, b :: Word128) - -prop_unCbcCbc iv k bs = - bs == (unPkcs5 $ unCbc Blowfish.decrypt iv k $ cbc Blowfish.encrypt iv k $ pkcs5 bs) - where types =(k :: Word8, iv :: Word64, bs :: [Octet]) - -prop_unPkcs5Pkcs5 os = - os == (unPkcs5 $ ((pkcs5 os)::[Word64])) - where types = (os :: [Octet]) - -prop_unNullsNulls os = - all (/=0) os ==> - os == (unPadNulls $ ((padNulls os)::[Word64])) - where types = (os :: [Octet]) - -prop_fromOctetsToOctets k n = - k >= 0 && n > 1 ==> - k == (fromOctets n $ toOctets n k) - where types = (k :: Int, n :: Word8) - -prop_unTwosCompTwosComp n = - n < (0) ==> - collect n $ - forAll g $ - \n -> n == (fromTwosComp $ toTwosComp n) - where types = (n::Int) - g = do n <- choose (minBound::Int,maxBound::Int) - return (13*n) - -main = do quickCheck prop_decryptEncrypt - quickCheck prop_AESIdempotent - quickCheck prop_unCbcCbc - quickCheck prop_unPkcs5Pkcs5 - quickCheck prop_unNullsNulls - quickCheck prop_fromOctetsToOctets - quickCheck prop_unTwosCompTwosComp diff --git a/RSATest.hs b/RSATest.hs deleted file mode 100644 --- a/RSATest.hs +++ /dev/null @@ -1,139 +0,0 @@ -module Main(main) where - -import Codec.Utils -import Data.Digest.SHA1(hash,Word160(Word160)) -import Codec.Encryption.RSA.MGF -import Codec.Encryption.RSA.EMEOAEP -import Codec.Encryption.RSA -import Test.HUnit - -n :: [Octet] -n = - [0xbb, 0xf8, 0x2f, 0x09, 0x06, 0x82, 0xce, 0x9c, - 0x23, 0x38, 0xac, 0x2b, 0x9d, 0xa8, 0x71, 0xf7, - 0x36, 0x8d, 0x07, 0xee, 0xd4, 0x10, 0x43, 0xa4, - 0x40, 0xd6, 0xb6, 0xf0, 0x74, 0x54, 0xf5, 0x1f, - 0xb8, 0xdf, 0xba, 0xaf, 0x03, 0x5c, 0x02, 0xab, - 0x61, 0xea, 0x48, 0xce, 0xeb, 0x6f, 0xcd, 0x48, - 0x76, 0xed, 0x52, 0x0d, 0x60, 0xe1, 0xec, 0x46, - 0x19, 0x71, 0x9d, 0x8a, 0x5b, 0x8b, 0x80, 0x7f, - 0xaf, 0xb8, 0xe0, 0xa3, 0xdf, 0xc7, 0x37, 0x72, - 0x3e, 0xe6, 0xb4, 0xb7, 0xd9, 0x3a, 0x25, 0x84, - 0xee, 0x6a, 0x64, 0x9d, 0x06, 0x09, 0x53, 0x74, - 0x88, 0x34, 0xb2, 0x45, 0x45, 0x98, 0x39, 0x4e, - 0xe0, 0xaa, 0xb1, 0x2d, 0x7b, 0x61, 0xa5, 0x1f, - 0x52, 0x7a, 0x9a, 0x41, 0xf6, 0xc1, 0x68, 0x7f, - 0xe2, 0x53, 0x72, 0x98, 0xca, 0x2a, 0x8f, 0x59, - 0x46, 0xf8, 0xe5, 0xfd, 0x09, 0x1d, 0xbd, 0xcb] - -p :: [Octet] -p = [0xee, 0xcf, 0xae, 0x81, 0xb1, 0xb9, 0xb3, 0xc9, - 0x08, 0x81, 0x0b, 0x10, 0xa1, 0xb5, 0x60, 0x01, - 0x99, 0xeb, 0x9f, 0x44, 0xae, 0xf4, 0xfd, 0xa4, - 0x93, 0xb8, 0x1a, 0x9e, 0x3d, 0x84, 0xf6, 0x32, - 0x12, 0x4e, 0xf0, 0x23, 0x6e, 0x5d, 0x1e, 0x3b, - 0x7e, 0x28, 0xfa, 0xe7, 0xaa, 0x04, 0x0a, 0x2d, - 0x5b, 0x25, 0x21, 0x76, 0x45, 0x9d, 0x1f, 0x39, - 0x75, 0x41, 0xba, 0x2a, 0x58, 0xfb, 0x65, 0x99] - -q :: [Octet] -q = [0xc9, 0x7f, 0xb1, 0xf0, 0x27, 0xf4, 0x53, 0xf6, - 0x34, 0x12, 0x33, 0xea, 0xaa, 0xd1, 0xd9, 0x35, - 0x3f, 0x6c, 0x42, 0xd0, 0x88, 0x66, 0xb1, 0xd0, - 0x5a, 0x0f, 0x20, 0x35, 0x02, 0x8b, 0x9d, 0x86, - 0x98, 0x40, 0xb4, 0x16, 0x66, 0xb4, 0x2e, 0x92, - 0xea, 0x0d, 0xa3, 0xb4, 0x32, 0x04, 0xb5, 0xcf, - 0xce, 0x33, 0x52, 0x52, 0x4d, 0x04, 0x16, 0xa5, - 0xa4, 0x41, 0xe7, 0x00, 0xaf, 0x46, 0x15, 0x03] - -popTest = - TestCase ( - assertEqual "Product of Primes" - (fromOctets 256 n) - ((fromOctets 256 p)*(fromOctets 256 q)) - ) - -d :: [Octet] -d = [0xa5, 0xda, 0xfc, 0x53, 0x41, 0xfa, 0xf2, - 0x89, 0xc4, 0xb9, 0x88, 0xdb, 0x30, 0xc1, 0xcd, - 0xf8, 0x3f, 0x31, 0x25, 0x1e, 0x06, 0x68, 0xb4, - 0x27, 0x84, 0x81, 0x38, 0x01, 0x57, 0x96, 0x41, - 0xb2, 0x94, 0x10, 0xb3, 0xc7, 0x99, 0x8d, 0x6b, - 0xc4, 0x65, 0x74, 0x5e, 0x5c, 0x39, 0x26, 0x69, - 0xd6, 0x87, 0x0d, 0xa2, 0xc0, 0x82, 0xa9, 0x39, - 0xe3, 0x7f, 0xdc, 0xb8, 0x2e, 0xc9, 0x3e, 0xda, - 0xc9, 0x7f, 0xf3, 0xad, 0x59, 0x50, 0xac, 0xcf, - 0xbc, 0x11, 0x1c, 0x76, 0xf1, 0xa9, 0x52, 0x94, - 0x44, 0xe5, 0x6a, 0xaf, 0x68, 0xc5, 0x6c, 0x09, - 0x2c, 0xd3, 0x8d, 0xc3, 0xbe, 0xf5, 0xd2, 0x0a, - 0x93, 0x99, 0x26, 0xed, 0x4f, 0x74, 0xa1, 0x3e, - 0xdd, 0xfb, 0xe1, 0xa1, 0xce, 0xcc, 0x48, 0x94, - 0xaf, 0x94, 0x28, 0xc2, 0xb7, 0xb8, 0x88, 0x3f, - 0xe4, 0x46, 0x3a, 0x4b, 0xc8, 0x5b, 0x1c, 0xb3, - 0xc1] - -dP :: [Octet] -dP = [0x54, 0x49, 0x4c, 0xa6, 0x3e, 0xba, 0x03, 0x37, - 0xe4, 0xe2, 0x40, 0x23, 0xfc, 0xd6, 0x9a, 0x5a, - 0xeb, 0x07, 0xdd, 0xdc, 0x01, 0x83, 0xa4, 0xd0, - 0xac, 0x9b, 0x54, 0xb0, 0x51, 0xf2, 0xb1, 0x3e, - 0xd9, 0x49, 0x09, 0x75, 0xea, 0xb7, 0x74, 0x14, - 0xff, 0x59, 0xc1, 0xf7, 0x69, 0x2e, 0x9a, 0x2e, - 0x20, 0x2b, 0x38, 0xfc, 0x91, 0x0a, 0x47, 0x41, - 0x74, 0xad, 0xc9, 0x3c, 0x1f, 0x67, 0xc9, 0x81] - -exponent1 = - toOctets 256 $ (fromOctets 256 d) `mod` ((fromOctets 256 p) - 1) - -e1Test = - TestCase ( - assertEqual "Exponent" dP exponent1 - ) - -dQ :: [Octet] -dQ = [0x47, 0x1e, 0x02, 0x90, 0xff, 0x0a, 0xf0, 0x75, - 0x03, 0x51, 0xb7, 0xf8, 0x78, 0x86, 0x4c, 0xa9, - 0x61, 0xad, 0xbd, 0x3a, 0x8a, 0x7e, 0x99, 0x1c, - 0x5c, 0x05, 0x56, 0xa9, 0x4c, 0x31, 0x46, 0xa7, - 0xf9, 0x80, 0x3f, 0x8f, 0x6f, 0x8a, 0xe3, 0x42, - 0xe9, 0x31, 0xfd, 0x8a, 0xe4, 0x7a, 0x22, 0x0d, - 0x1b, 0x99, 0xa4, 0x95, 0x84, 0x98, 0x07, 0xfe, - 0x39, 0xf9, 0x24, 0x5a, 0x98, 0x36, 0xda, 0x3d] - -m :: [Octet] -m = [0xd4, 0x36, 0xe9, 0x95, 0x69, 0xfd, 0x32, 0xa7, - 0xc8, 0xa0, 0x5b, 0xbc, 0x90, 0xd3, 0x2c, 0x49] - -seed :: [Octet] -seed = [0xaa, 0xfd, 0x12, 0xf6, 0x59, 0xca, 0xe6, 0x34, - 0x89, 0xb4, 0x79, 0xe5, 0x07, 0x6d, 0xde, 0xc2, - 0xf0, 0x6c, 0xb5, 0x8f] - -e :: [Octet] -e = [0x11] - -hash' xs = let (Word160 a b c d e) = hash xs in concatMap (toOctets 256) [a,b,c,d,e] - -encodedText = encode mgf hash' [] seed n m - -decodedText = decode mgf hash' [] encodedText - -encodingTest = - TestCase ( - assertEqual "Encoding / Decoding" m decodedText - ) - -cipherText = encrypt (n,e) encodedText - -plainText = decrypt (n,d) cipherText - -decodedText' = decode mgf hash' [] plainText - -encryptionTest = - TestCase ( - assertEqual "Encrypting / Decrypting" m decodedText - ) - -tests = TestList [popTest, e1Test, encodingTest, encryptionTest] - -main = runTestTT tests diff --git a/SHA1Test.hs b/SHA1Test.hs deleted file mode 100644 --- a/SHA1Test.hs +++ /dev/null @@ -1,35 +0,0 @@ -import Test.HUnit -import Codec.Text.Raw (hexdumpBy) -import Data.Digest.SHA1 (hash,Word160(Word160)) -import Text.PrettyPrint -import Data.Char (ord) -import Codec.Utils (toOctets) - -testCases = - [ ("Hello" , "f7ff9e8b7bb2e09b70935a5d785e0cc5d9d0abf0") - , ("haskell" , "f0234175f95a989496bf7f5ba03dea4dbc773e58") - , ("Cryptography" , "b804ec5a0d83d19d8db908572f51196505d09f98") - , ("Message Digest", "d52066b0fa1d68ef07eeab73031c3a3671298417") - ] - -testCases' = - [ ([] , "da39a3ee5e6b4b0d3255bfef95601890afd80709") - , ([0xa8] , "99f2aa95e36f95c2acb0eaf23998f030638f3f15") - , (toOctets 256 0x7e3a4c325cb9c52b88387f93d01ae86d42098f5efa7f9457388b5e74b6d28b2438d42d8b64703324d4aa25ab6aad153ae30cd2b2af4d5e5c00a8a2d0220c6116, "a3054427cdb13f164a610b348702724c808a0dcc") - , (toOctets 256 0xec29561244ede706b6eb30a1c371d74450a105c3f9735f7fa9fe38cf67f304a5736a106e92e17139a6813b1c81a4f3d3fb9546ab4296fa9f722826c066869edacd73b2548035185813e22634a9da44000d95a281ff9f264ecce0a931222162d021cca28db5f3c2aa24945ab1e31cb413ae29810fd794cad5dfaf29ec43cb38d198fe4ae1da2359780221405bd6712a5305da4b1b737fce7cd21c0eb7728d08235a9011, "970111c4e77bcc88cc20459c02b69b4aa8f58217") - , (toOctets 256 0x4893f1c763625f2c6ce53aacf28026f14b3cd8687e1a1d3b60a81e80fcd1e2b038f9145ab64a0718f948f7c3c9ac92e3d86fb669a5257da1a18c776291653688338210a3242120f101788e8acc9110db9258b1554bf3d26602516ea93606a25a7f566c0c758fb39ecd9d876bc5d8abc1c3205095382c2474cb1f8bbdb45c2c0e659cb0fc703ec607a5de6bcc7a28687db1ee1c8f34797bb2441d5706d210df8c2d7d65dbded36414d063c117b52a51f7a4eb9cac0782e008b47459ed5acac0bc1f20121087f992ad985511b33c866d18e63f585478ee5a5e654b19d81231d98683ae3f0533565aba43dce408d7e3c4c6be11d8f05165f29c9dcb2030c4ee31d3a04e7421aa92c3231a1fc07e50e95fea7389a5e65891afaba51cf55e36a9d089bf293accb356d5d06547307d6e41456d4ed146a056179971c56521c83109bf922866186e184a99a96c7bb96df8937e35970e438412a2b8d744cf2ad87cb605d4232e976f9f15169776e4e5b6b786132c966b25fc56d815c56c819af5e159aa39f8a93d38115f5580cda93bc073c30b39920e726fe861b72483a3f886269ab7a8eefe952f35d25c4eb7f443f4f3f26e43d51fb54591e6a6dad25fcdf5142033084e5624bdd51435e77dea86b8, "dc5859dd5163c4354d5d577b855fa98e37f04384") - , (toOctets 256 0xcf494c18a4e17bf03910631471bca5ba7edea8b9a63381e3463517961749848eb03abefd4ce676dece3740860255f57c261a558aa9c7f11432f549a9e4ce31d8e17c79450ce2ccfc148ad904aedfb138219d7052088520495355dadd90f72e6f69f9c6176d3d45f113f275b7fbc2a295784d41384cd7d629b23d1459a22e45fd5097ec9bf65fa965d3555ec77367903c32141065fc24da5c56963d46a2da3c279e4035fb2fb1c0025d9dda5b9e3443d457d92401a0d3f58b48469ecb1862dc975cdbe75ca099526db8b0329b03928206f084c633c04eef5e8e377f118d30edf592504be9d2802651ec78aeb02aea167a03fc3e23e5fc907c324f283f89ab37e84687a9c74ccf055402db95c29ba2c8d79b2bd4fa96459f8e3b78e07e923b81198267492196ecb71e01c331f8df245ec5bdf8d0e05c91e63bb299f0f6324895304dda721d39410458f117c87b7dd6a0ee734b79fcbe482b2c9e9aa0cef03a39d4b0c86de3bc34b4aadabfa373fd2258f7c40c187744d237080762382f547a36adb117839ca72f8ebbc5a20a07e86f4c8bb923f5787698d278f6db0040e76e54645bb0f97083995b34b9aa445fc424455058795828dd00c32471ec402a307f5aa1b37b1a86d6dae3bcbfbe9ba41cab0beeabf489af0073d4b3837d3f14b815120bc3602d072b5aeefcdec655fe756b660eba7dcf34675acbce317746270599424b9248791a0780449c1eabbb9459cc1e588bfd74df9b1b711c85c09d8aa171b309281947e8f4b6ac438753158f4f36fa, "4c17926feb6e87f5bca7890d8a5cde744f231dab") - , (toOctets 256 0xe79701ff44ecfe5a7e97306a9c93791a2b4a6948e0aa06797f7cc8cbfbf1e82bdf7edbc7ecea19c604a62237475cc3487bca95b9b1d1c89025c91e0d67183ae0b8031b9ab7c4e4623ddcdee985aabfa0903d2d28c7677e09e312c2a80ad703733acdcb5feb9fe794f0e26b669fa5f6883149377c6c93b04e7fffba822d57ca4b2d85f2fed1a6abc5e75fd198dd74ef692896bd9fe57de7c6c137108517c017d059d2995eb1feb75ee8fc1966864032ac3bcdc6787d4eaad97363cc981239736a865dc769d3d293c5bc614ab7e43048b733965bef7b2e82ef5b2af4a264ea64817bce84067e48c8642b356c753d6db8f4d79883ec2644f6704335928d56fc747d01ccd81dfc88dda2fc208887da1e0ac9f17c4657c8b98ec4f12cad4030972bc6e0ffcc9793bb5ae6f9cca4d5036cc7a047e9ac18a7b4d2542db54ea33ae210c4e010675a8c09c89ae8decb47ff7f76e0a388be180b5e4b86c17b7c9ebc06abe0c8a7b24f2f99ad25920102c5187e9ff1cb01833d3edf80c373243f19fd2b8480626bb35ec39494efbfdb53379491cb3b87fb0370875ef9740d599ffc4677240e74057470922102603614c585bce28026a11f479a2d033fff55c1a52fdf1512f0c71cfd6be26981e0c1556097d896491adf1456a179f8d9ce1405589a102bd69023595439fc9498d726462d5530d8ab7f0b82396fb3624f4711ccc12621e2f954506483c028c9d0ad2e8e33a80bce30bdeb13f6ea236c2ad416bfe6b9596102a615e492eaad30afcaa1d57b76b3a05f3c486d97fc103bf1dce986d13c01d179ed3b82879dd5f2bf9647c50ba96e77c064e938238cc4fa2cc753c88a986159e6908be56cc3e637887ae804ed27857bdc9e981da38185cf64fc1c2d17b3c122d2f9cab54843292691dc4b3a29da40d33a501bc31ec59ce21fe50c5f82776953c58fc39c2405e6e862253910c5a8e6a863e43bd49c3f515ce8e9eb03d3cba01545ba3d4007f165a483be7a2dcb7bc121ddc0c0f526d7eb65447080c41096b090dce2ff49f9efed837d0dd63b423a1767324e72d0c275b424bde2944743c2dfeb116fd26003e7c7add67c15df33cd31a1e9f4190d7b01f2c2daa8ef377336764f6cc97e2d2bc13c491972fec3a51b57f88b1c7c545663ee672328593aa9dabce37659cb577b659280cb575a8fa00ed0949f2d644b5d84f03921cb9af8ec96fbd0b6858187fbbb11797692f1eb2d8de69cad8f999d974a3f635bf9791b4452793db5b66764b2ac035da18d8b7d5281df383ea9e3f00c9e250b5a1bc048b9f68053f9554697a81eae53d5aff0f019d00492d9e50aedc569e85aa4973529546a56390cc8e6c7e5fa5c849960e7ea8a639dcf06aad53bc991d177c3d7a1661c96431876790f9d7229531775083a13ac22f21a4d610d822000288a3f41cba71a639118bdce89c05692db35f10faf1587f54a9937707a6cd39c35bd9e3f7d9354b786606b311bda991c3e0696de0f9523c5ef744b40e49fe94f3f366a387dd2d47c6c1907098f9044b1c2b1ebdb213e897827d4113913c36aff901d2a94940da298896a1abeab8c5d38b15f796fafb5c0f83be112c3cf815f966e9b67ba8aecc4f5267c2bb83876ef985137c6027fa5d02b73c2d547df81cffb22d8a814271644798a77c25efdf5ffbbeb625cfd5bb4c2fb16a0e32b0c6ac216f4fb75093334290eff82681ac4b29788c607c3c6098a9d4f6ea2c2d91ee440cf2b2c560175ed7c9bcbc5a3535355bee72c4f81c751d0690ec1f1fcb7dd99520e1195d464b6ea44073769fe7273857dc063622067fd2e2e2258b4192f102effbbec5b769bbed2893c8b96feddeceadbfbb467280dd34bf5727b149fa8814e50be05a9c50c554e54210f732dfd862de08167861f239dd0c5e67139188af69f4bffa4a548204306ac9e0b29123a09f69438c4e98f102164a766844a0b3c38c9fa671177873f4fa1999bc6df35fd3cec000913b5ff3c28b0a2dafa6f01280f7565dc93480ad243c8230089be1face8b82bdc9b15f80f795cbe2a1cd281b5424b934773405a3fe52253b59cee57b1d5021d9aa52f01f1de0f033f3298134b9bf28c91fa86fef0fe5830a347966572cb71df29792ba24a1d717aff84ec3f52e01358a06d437e4b5511c2b0d2dfd25992ad78735f326382ff2b2a5359f48e32da55005e179e63bab4f612c584f025ccf15ff05f9f6ccd014ce51c23fbd8875451618bb23fc033a4e1ae27cba6f2e635b22f50d48000672fcc465658b0c1b31e0dde01832cd07971a5e20aa8800c9efb9bc49fbc4b16b97546f7e2d8c1d798f9d5756abb27f7ba88c83ac1465a67d48675c7e5fe49d84c3984a0c88d7641c04e72cecf41785d8053125d568b7c2a103e07df2a82bf6ca7e44ce80e5e1628b383ad9037fd672952394bf4d0612d7eda8b1bb57730f8fa53df6777be32ebb3f7024c63abd73c84b9a23aa638afb78bbbd577f0d3f03babd6919df6dff33b0b163117f132b73e953cf6a81c955d60783a84e43947aacfa6ba61b50d7a884f57987ad8dfd485b685639e5dfeef52716ee0002a38da46fd1486b9796396d96fc0034455d89929ec7bb60021f34f78319433b1119494ac0d1dc300afa13bcee26ee1f657828a8b28a0be85bca3bcb6ea13bd0061f67dc447e8f89d206e714ff288b9faa685ae94b21b0295f5b73ef4e2120653e1059e77f29eadfa94734144e53614b70a8a0e2ad1150a9995d7dd1a63ba94135a6afeab58666b7ed358b29504a279954b39b036cfb65ff765aaa211b332f1a995cca549bf69b891a4c4cd2a97f170fc30399ea1f22588192ad994bf1aa3a57b57d49c3a70cf1f9bd05f99ebe64e81548333e051838b0d65af0bbb0de23536f36b2aea64b3bf250420d21ec138df35050ace7c30c90f7745bbe920e3510f2e78987597b1d061543559c56492d7cc13778eb37c250eda4d20151bca2ab15a1571a55dac080ede339446df7448093ea413d689e7179813175e8648c1c8483d71485b8c3050b65e4a8aaec955c9175d6e3facf9c6f0b1e35e66d6180ea75fe1cc6482a72b7310082280582b0fff4950fb64d6ab20979f72a8a2cd35b8ad3d6ead2de259a658640542dc0dababd0e640d3eb1d46fdf4aae780793244c7c42c0b9d0b4247a7e7fa7d320795f4302638547c3a497366ef1c6b6b53cff044d372e023666b1c390819977b6ab8aca6e885b580bb22d961703b25f3986ade36c25816c7a6267e61a30b7ba46c3e7c15fe168a67d56f21f95f513e9fb1ccb9a57926d51133391629a016523574ee0b864f33fcb7effaf233a4a4ddf704bd279adf24448a766c8b98e78344b7ec910200c52333fa7389f519277c2b84fa05d01bde9a8cb9d58985b6619a78b13bef088c473056b7c8e5d1b2d12350cdfc6b5e335dcfd426b956ae8cf4a217abc9d0c631bea08d7756d62f0688e0735b70b876e7450c455a8b9dab2189e5482dfefce3f710bc02c18524b71e35fabcb4bfb4c2417c9907dcb124277e09a934c0423a08e626ccda1dbd961001c1ba54625227ea48ebbe413495b4c8a95a3702ebfd54dd07, "0eb8d69f6661b8124ddf76a635dc2821cbac32d7") - ] - -genTests' cases = - "SHA1" ~: map f cases - where f (val, dgst) = dgst ~=? hexHash' val - -hexHash' x = - let (Word160 a b c d e) = hash x in - render . (hexdumpBy "" 20) . concatMap (toOctets 256) $ [a,b,c,d,e] - -main = runTestTT $ genTests' testCases' - - diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/SymmetricTest.hs b/SymmetricTest.hs deleted file mode 100644 --- a/SymmetricTest.hs +++ /dev/null @@ -1,232 +0,0 @@ -module Main(main) where - -import Codec.Utils -import Codec.Encryption.Blowfish as Blowfish -import Codec.Encryption.Modes -import Codec.Encryption.Padding -import Codec.Encryption.DES as DES -import Codec.Encryption.AES as AES -import Data.Word -import Data.Bits -import Data.Char -import Data.LargeWord -import Test.HUnit -import Numeric - --- AES Tests. - --- Comparision with resuts from --- http://www.cs.ucsd.edu/~fritz/rijndael_test.html - -ad = 0xF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word128 -ak16 = 0xF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word128 -ae16 = 0x6e94fffbb861b2c1769cd4629f3d724b :: Word128 -ae16' = AES.encrypt ak16 ad -aesTest1 = - TestCase ( - assertEqual "AES Key Length 128" ae16 ae16' - ) - -ak24 = 0xF0E1D2C3B4A5968778695A4B3C2D1E0FF0E1D2C3B4A59687 :: Word192 -ae24' = AES.encrypt ak24 ad -ae24 = 0x07d806bb62ebb4399354594ea6586ec6 :: Word128 -aesTest2 = - TestCase ( - assertEqual "AES Key Length 192" ae24 ae24' - ) - -ak32 = 0xF0E1D2C3B4A5968778695A4B3C2D1E0FF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word256 -ae32' = AES.encrypt ak32 ad -ae32 = 0x28e88482d9b146fdde7e080fcbae1b98 :: Word128 -aes3 = ae32 == ae32' -aesTest3 = - TestCase ( - assertEqual "AES Key Length 256" ae32 ae32' - ) - --- Comparision with resuts from --- http://www.zvon.org/tmRFC/RFC3602/Output/chapter4.html - -aeskey16 = 0x06a9214036b8a15b512e03d534120006 :: Word128 -aesiv16 = 0x3dafba429d9eb430b422da802c9fac41 :: Word128 -aesplaintext = "Single block msg" -aesciphertext = [0xe353779c1079aeb82708942dbe77181a] :: [Word128] -aesciphertext' = - cbc AES.encrypt aesiv16 aeskey16 $ - pkcs5 $ - map (fromIntegral . ord) aesplaintext --- aescbc1 = aesciphertext == take 1 aesciphertext' -aescbcTest1 = - TestCase ( - assertEqual "AES CBC PKCS5 Key Length 128" - aesciphertext (take 1 aesciphertext') - ) - -aesplaintext' = - map (chr . fromIntegral) $ - unPkcs5 $ - unCbc AES.decrypt aesiv16 aeskey16 aesciphertext' -aescbcTest2 = - TestCase ( - assertEqual "AES CBC PKCS5 Decryption Key Length 128" - aesplaintext aesplaintext' - ) - -aes2key16 = 0x6c3ea0477630ce21a2ce334aa746c2cd :: Word128 -aes2iv16 = 0xc782dc4c098c66cbd9cd27d825682c81 :: Word128 -aes2plaintext = "This is a 48-byte message (exactly 3 AES blocks)" -aes2ciphertext = [0xd0a02b3836451753d493665d33f0e886, - 0x2dea54cdb293abc7506939276772f8d5, - 0x021c19216bad525c8579695d83ba2684] :: [Word128] -aes2ciphertext' = - cbc AES.encrypt aes2iv16 aes2key16 $ - pkcs5 $ - map (fromIntegral . ord) aes2plaintext -aescbcTest3 = - TestCase ( - assertEqual "AES CBC PKCS5 3 Blocks Key Length 128" - aes2ciphertext (take 3 aes2ciphertext') - ) - --- Comparision with resuts from --- http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf - -aes3key24 = - 0x8e73b0f7da0e6452c810f32b809079e562f8ead2522c6b7b :: Word192 -aes3iv16 = 0x000102030405060708090a0b0c0d0e0f :: Word128 -aes3plaintext = - [0x6bc1bee22e409f96e93d7e117393172a, - 0xae2d8a571e03ac9c9eb76fac45af8e51, - 0x30c81c46a35ce411e5fbc1191a0a52ef, - 0xf69f2445df4f9b17ad2b417be66c3710] :: [Word128] -aes3ciphertext' = - cbc AES.encrypt aes3iv16 aes3key24 $ - pkcs5 $ - concat $ - map (toOctets 256) aes3plaintext -aes3ciphertext = - [0x4f021db243bc633d7178183a9fa071e8, - 0xb4d9ada9ad7dedf4e5e738763f69145a, - 0x571b242012fb7ae07fa9baac3df102e0, - 0x08b0e27988598881d920a9e64f5615cd] :: [Word128] -aescbcTest4 = - TestCase ( - assertEqual "AES CBC PKCS5 4 Blocks Key Length 192" - aes3ciphertext (take 4 aes3ciphertext') - ) - -aes4key32 = - 0x603deb1015ca71be2b73aef0857d77811f352c073b6108d72d9810a30914dff4 - :: Word256 -aes4iv16 = 0x000102030405060708090a0b0c0d0e0f :: Word128 -aes4plaintext = - [0x6bc1bee22e409f96e93d7e117393172a, - 0xae2d8a571e03ac9c9eb76fac45af8e51, - 0x30c81c46a35ce411e5fbc1191a0a52ef, - 0xf69f2445df4f9b17ad2b417be66c3710] :: [Word128] -aes4ciphertext' = - cbc AES.encrypt aes4iv16 aes4key32 $ - pkcs5 $ - concat $ - map (toOctets 256) aes3plaintext -aes4ciphertext = - [0xf58c4c04d6e5f1ba779eabfb5f7bfbd6, - 0x9cfc4e967edb808d679f777bc6702c7d, - 0x39f23369a9d9bacfa530e26304231461, - 0xb2eb05e2c39be9fcda6c19078c6a9d1b] :: [Word128] -aescbcTest5 = - TestCase ( - assertEqual "AES CBC PKCS5 4 Blocks Key Length 256" - aes4ciphertext (take 4 aes4ciphertext') - ) - --- Blowfish Tests. - --- Tests from http://www.counterpane.com/vectors.txt. - -d = 0xFEDCBA9876543210 :: Word64 -k = 0xF0 :: Word8 -e = 0xF9AD597C49DB005E :: Word64 -e' = Blowfish.encrypt k d -bfTest1 = - TestCase ( - assertEqual "Blowfish Key Length 8" e e' - ) - -k2 = 0xF0E1 :: Word16 -e2 = 0xE91D21C1D961A6D6 :: Word64 -e2' = Blowfish.encrypt k2 d -bfTest2 = - TestCase ( - assertEqual "Blowfish Key Length 16" e2 e2' - ) - -e8 = 0xE87A244E2CC85E82 :: Word64 -k8 = 0xF0E1D2C3B4A59687 :: Word64 -e8' = Blowfish.encrypt k8 d -bfTest3 = - TestCase ( - assertEqual "Blowfish Key Length 64" e8 e8' - ) - -e16 = 0x93142887EE3BE15C :: Word64 -k16= 0xF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word128 -e16' = Blowfish.encrypt k16 d -bfTest4 = - TestCase ( - assertEqual "Blowfish Key Length 128" e16 e16' - ) - --- Blowfish test with Cipher Block Chaining. --- Set up the published key, initialization vector and data. - -key16 = 0x0123456789ABCDEFF0E1D2C3B4A59687 :: Word128 -iv8 = 0xFEDCBA9876543210 :: Word64 -data29 = "7654321 Now is the time for \NUL" - --- Pad with nulls as in the example. - -e29' = - cbc Blowfish.encrypt iv8 key16 $ padNulls $ map (fromIntegral . ord) data29 - -e29 = [0x6B,0x77,0xB4,0xD6,0x30,0x06,0xDE,0xE6, - 0x05,0xB1,0x56,0xE2,0x74,0x03,0x97,0x93, - 0x58,0xDE,0xB9,0xE7,0x15,0x46,0x16,0xD9, - 0x59,0xF1,0x65,0x2B,0xD5,0xFF,0x92,0xCC] :: [Octet] - -bfTest5 = - TestCase ( - assertEqual "AES CBC Nulls Key Length 128" - e29 (concat $ map (toOctets 256) e29') - ) - --- DES Tests - --- Test from http://www.itl.nist.gov/fipspubs/fip81.htm - -key = 0x0123456789abcdef :: Word64 -iv = 0x1234567890abcdef :: Word64 -expectedDES = [0xe5c7cdde872bf27c, - 0x43e934008c389c0f, - 0x683788499a7c05f6] :: [Word64] -plainText = "Now is the time for all " - --- Pad using PKCS#5 so only take the first 3 blocks of the ciphertext. - -cipherText = - cbc DES.encrypt iv key $ pkcs5 $ map (fromIntegral . ord) plainText -descbcTest1 = - TestCase ( - assertEqual "DES CBC PKCS5 3 Blocks" - expectedDES (take 3 cipherText) - ) - -tests = - TestList [ - aesTest1, aesTest2, aesTest3, aescbcTest1, - aescbcTest2, aescbcTest3, aescbcTest4, aescbcTest5, - bfTest1, bfTest2, bfTest3, bfTest4, bfTest5, - descbcTest1 - ] - -main = runTestTT tests diff --git a/WordListTest.hs b/WordListTest.hs deleted file mode 100644 --- a/WordListTest.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, PatternSignatures, - FlexibleInstances, UndecidableInstances, - TypeSynonymInstances #-} - -import Data.LargeWord (Word128, Word192, Word256, LargeKey) -import Codec.Utils (listFromOctets, listToOctets) -import Data.Word (Word8, Word32, Word64) -import Test.QuickCheck - -main :: IO () -main = sequence_ $ map test checks where - test :: (String, IO ()) -> IO () - test (s, t) = do putStrLn $ "Checking " ++ s - putStr " " - t - -checks :: [(String, IO ())] -checks = [ - ("Word32", - quickCheck (\(w :: [Word32]) -> (listFromOctets . listToOctets) w == w)), - ("Word64", - quickCheck (\(w :: [Word64]) -> (listFromOctets . listToOctets) w == w)), - ("Word128", - quickCheck (\(w :: [Word128]) -> (listFromOctets . listToOctets) w == w)), - ("Word192", - quickCheck (\(w :: [Word192]) -> (listFromOctets . listToOctets) w == w)), - ("Word256", - quickCheck (\(w :: [Word256]) -> (listFromOctets . listToOctets) w == w))] - -instance Arbitrary Word128 where - arbitrary = do - x <- vector (128 `div` 8) :: Gen [Word8] - return $ head $ listFromOctets x - -instance Arbitrary Word192 where - arbitrary = do - x <- vector (192 `div` 8) :: Gen [Word8] - return $ head $ listFromOctets x - -instance Arbitrary Word256 where - arbitrary = do - x <- vector (256 `div` 8) :: Gen [Word8] - return $ head $ listFromOctets x diff --git a/src-test/HMACTest.hs b/src-test/HMACTest.hs new file mode 100644 --- /dev/null +++ b/src-test/HMACTest.hs @@ -0,0 +1,183 @@ +module Main(main) where + +import Data.HMAC +import Test.HUnit +import Codec.Utils (Octet) +import Data.Char(ord) + +-- HMAC-SHA1 tests from +-- + +-- HMAC-MD5 tests from +-- + +-- Test #1: SHA-1 64-byte key (single block) + +hmacTest1 = + TestCase ( + assertEqual "Test HMAC-SHA1 #1 with 64-byte key" + hmac_1 (hmac_sha1 key_1 message_1) + ) + +message_1 = string2words "Sample #1" + +key_1 :: [Octet] +key_1 = + [0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, + 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, + 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, + 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, + 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, + 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, + 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, + 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f] + +hmac_1 :: [Octet] +hmac_1 = + [0x4f, 0x4c, 0xa3, 0xd5, 0xd6, 0x8b, 0xa7, 0xcc, + 0x0a, 0x12, 0x08, 0xc9, 0xc6, 0x1e, 0x9c, 0x5d, + 0xa0, 0x40, 0x3c, 0x0a] + + +-- Test #2: SHA 20-byte key (short block) + +hmacTest2 = + TestCase ( + assertEqual "Test HMAC-SHA1 #2 with 20-byte key" + hmac_2 (hmac_sha1 key_2 message_2) + ) + +message_2 = string2words "Sample #2" + +key_2 :: [Octet] +key_2 = + [0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, + 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, + 0x40, 0x41, 0x42, 0x43] + +hmac_2 :: [Octet] +hmac_2 = + [0x09, 0x22, 0xd3, 0x40, 0x5f, 0xaa, 0x3d, 0x19, + 0x4f, 0x82, 0xa4, 0x58, 0x30, 0x73, 0x7d, 0x5c, + 0xc6, 0xc7, 0x5d, 0x24] + +-- Test #3: SHA 100-byte key (multi-block) + +hmacTest3 = + TestCase ( + assertEqual "Test HMAC-SHA1 #3 with 100-byte key" + hmac_3 (hmac_sha1 key_3 message_3) + ) + +message_3 = string2words "Sample #3" + +key_3 :: [Octet] +key_3 = + [0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, + 0x58, 0x59, 0x5a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, + 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, + 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, + 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, + 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f, + 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, + 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f, + 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, + 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, + 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, + 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf, + 0xb0, 0xb1, 0xb2, 0xb3] + +hmac_3 :: [Octet] +hmac_3 = + [0xbc, 0xf4, 0x1e, 0xab, 0x8b, 0xb2, 0xd8, 0x02, + 0xf3, 0xd0, 0x5c, 0xaf, 0x7c, 0xb0, 0x92, 0xec, + 0xf8, 0xd1, 0xa3, 0xaa] + +-- Test #4: SHA 49-byte key (truncated to 12-byte HMAC) + +hmacTest4 = + TestCase ( + assertEqual "Test HMAC-SHA1 #4 with 49-byte key, truncated to 12-bytes" + hmac_4 (take 12 (hmac_sha1 key_4 message_4)) + ) + +message_4 = string2words "Sample #4" + +key_4 :: [Octet] +key_4 = + [0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, + 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f, + 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, + 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f, + 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, + 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, + 0xa0] + +hmac_4 :: [Octet] +hmac_4 = + [0x9e, 0xa8, 0x86, 0xef, 0xe2, 0x68, 0xdb, 0xec, + 0xce, 0x42, 0x0c, 0x75] + +-- Test #5: MD5 Test from rfc 2104 (16-byte key) + +hmacTest5 = + TestCase ( + assertEqual "Test HMAC-MD5 with 16-byte key" + hmac_5 (hmac_md5 key_5 message_5) + ) + +message_5 = string2words "Hi There" + +key_5 :: [Octet] +key_5 = take 16 (repeat 0xb) + +hmac_5 :: [Octet] +hmac_5 = [0x92, 0x94, 0x72, 0x7a, 0x36, 0x38, 0xbb, 0x1c, + 0x13, 0xf4, 0x8e, 0xf8, 0x15, 0x8b, 0xfc, 0x9d] + +-- Test #6: MD5 Test from rfc 2104 (28-byte key) + +hmacTest6 = + TestCase ( + assertEqual "Test HMAC-MD5 with 28-byte key" + hmac_6 (hmac_md5 key_6 message_6) + ) + +message_6 = string2words "what do ya want for nothing?" + +key_6 :: [Octet] +key_6 = string2words "Jefe" + +hmac_6 :: [Octet] +hmac_6 = [0x75, 0x0c, 0x78, 0x3e, 0x6a, 0xb0, 0xb5, 0x03, + 0xea, 0xa8, 0x6e, 0x31, 0x0a, 0x5d, 0xb7, 0x38] + +-- Test #7: MD5 Test from rfc 2104 (16-byte key) + +hmacTest7 = + TestCase ( + assertEqual "Test HMAC-MD5 with 16-byte key" + hmac_7 (hmac_md5 key_7 message_7) + ) + +message_7 = take 50 (repeat 0xdd) + +key_7 :: [Octet] +key_7 = take 16 (repeat 0xaa) + +hmac_7 :: [Octet] +hmac_7 = [0x56, 0xbe, 0x34, 0x52, 0x1d, 0x14, 0x4c, 0x88, + 0xdb, 0xb8, 0xc7, 0x33, 0xf0, 0xe8, 0xb3, 0xf6] + + +string2words :: String -> [Octet] +string2words = map (fromIntegral . ord) + +-- Run the tests + +tests = + TestList [hmacTest1, hmacTest2, hmacTest3, hmacTest4, + hmacTest5, hmacTest6, hmacTest7] + +main :: IO () +main = runTestTTAndExit tests diff --git a/src-test/QuickTest.hs b/src-test/QuickTest.hs new file mode 100644 --- /dev/null +++ b/src-test/QuickTest.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Main(main) where + +import Codec.Encryption.AES as AES +import Codec.Encryption.Blowfish as Blowfish +import Codec.Encryption.Modes +import Codec.Encryption.Padding +import Codec.Utils +import Control.Monad (unless) +import Data.Bits +import Data.Char +import Data.LargeWord +import Data.Word +import Numeric +import Test.QuickCheck + +instance Arbitrary Word128 where + arbitrary = + do n <- choose ((fromIntegral (minBound::Word128))::Integer, + (fromIntegral (maxBound::Word128))::Integer) + return (fromIntegral n) + +prop_decryptEncrypt k b = b == Blowfish.decrypt k (Blowfish.encrypt k b) + where types = (k :: Word8, b :: Word64) + +prop_AESIdempotent k b = b == AES.decrypt k (AES.encrypt k b) + where types = (k :: Word128, b :: Word128) + +prop_unCbcCbc iv k bs = + bs == (unPkcs5 $ unCbc Blowfish.decrypt iv k $ cbc Blowfish.encrypt iv k $ pkcs5 bs) + where types =(k :: Word8, iv :: Word64, bs :: [Octet]) + +prop_unPkcs5Pkcs5 os = + os == (unPkcs5 $ ((pkcs5 os)::[Word64])) + where types = (os :: [Octet]) + +prop_unNullsNulls os = + all (/=0) os ==> + os == (unPadNulls $ ((padNulls os)::[Word64])) + where types = (os :: [Octet]) + +prop_fromOctetsToOctets k n = + k >= 0 && n > 1 ==> + k == (fromOctets n $ toOctets n k) + where types = (k :: Int, n :: Word8) + +prop_unTwosCompTwosComp n = + n < (0) ==> + collect n $ + forAll g $ + \n -> n == (fromTwosComp $ toTwosComp n) + where types = (n::Int) + g = do n <- choose (minBound::Int,maxBound::Int) + return (13*n) + +main :: IO () +main = do + results <- sequence + [ quickCheckWithResult args prop_decryptEncrypt + , quickCheckWithResult args prop_AESIdempotent + , quickCheckWithResult args prop_unCbcCbc + , quickCheckWithResult args prop_unPkcs5Pkcs5 + , quickCheckWithResult args prop_unNullsNulls + , quickCheckWithResult args prop_fromOctetsToOctets + , quickCheckWithResult args prop_unTwosCompTwosComp + ] + + unless (all isSuccess results) $ do + fail "SOME TESTS FAILED!" + + putStrLn "=> all tests passed!" + where + args = stdArgs { maxSuccess = 500 } diff --git a/src-test/RSATest.hs b/src-test/RSATest.hs new file mode 100644 --- /dev/null +++ b/src-test/RSATest.hs @@ -0,0 +1,140 @@ +module Main(main) where + +import Codec.Utils +import Data.Digest.SHA1(hash,Word160(Word160)) +import Codec.Encryption.RSA.MGF +import Codec.Encryption.RSA.EMEOAEP +import Codec.Encryption.RSA +import Test.HUnit + +n :: [Octet] +n = + [0xbb, 0xf8, 0x2f, 0x09, 0x06, 0x82, 0xce, 0x9c, + 0x23, 0x38, 0xac, 0x2b, 0x9d, 0xa8, 0x71, 0xf7, + 0x36, 0x8d, 0x07, 0xee, 0xd4, 0x10, 0x43, 0xa4, + 0x40, 0xd6, 0xb6, 0xf0, 0x74, 0x54, 0xf5, 0x1f, + 0xb8, 0xdf, 0xba, 0xaf, 0x03, 0x5c, 0x02, 0xab, + 0x61, 0xea, 0x48, 0xce, 0xeb, 0x6f, 0xcd, 0x48, + 0x76, 0xed, 0x52, 0x0d, 0x60, 0xe1, 0xec, 0x46, + 0x19, 0x71, 0x9d, 0x8a, 0x5b, 0x8b, 0x80, 0x7f, + 0xaf, 0xb8, 0xe0, 0xa3, 0xdf, 0xc7, 0x37, 0x72, + 0x3e, 0xe6, 0xb4, 0xb7, 0xd9, 0x3a, 0x25, 0x84, + 0xee, 0x6a, 0x64, 0x9d, 0x06, 0x09, 0x53, 0x74, + 0x88, 0x34, 0xb2, 0x45, 0x45, 0x98, 0x39, 0x4e, + 0xe0, 0xaa, 0xb1, 0x2d, 0x7b, 0x61, 0xa5, 0x1f, + 0x52, 0x7a, 0x9a, 0x41, 0xf6, 0xc1, 0x68, 0x7f, + 0xe2, 0x53, 0x72, 0x98, 0xca, 0x2a, 0x8f, 0x59, + 0x46, 0xf8, 0xe5, 0xfd, 0x09, 0x1d, 0xbd, 0xcb] + +p :: [Octet] +p = [0xee, 0xcf, 0xae, 0x81, 0xb1, 0xb9, 0xb3, 0xc9, + 0x08, 0x81, 0x0b, 0x10, 0xa1, 0xb5, 0x60, 0x01, + 0x99, 0xeb, 0x9f, 0x44, 0xae, 0xf4, 0xfd, 0xa4, + 0x93, 0xb8, 0x1a, 0x9e, 0x3d, 0x84, 0xf6, 0x32, + 0x12, 0x4e, 0xf0, 0x23, 0x6e, 0x5d, 0x1e, 0x3b, + 0x7e, 0x28, 0xfa, 0xe7, 0xaa, 0x04, 0x0a, 0x2d, + 0x5b, 0x25, 0x21, 0x76, 0x45, 0x9d, 0x1f, 0x39, + 0x75, 0x41, 0xba, 0x2a, 0x58, 0xfb, 0x65, 0x99] + +q :: [Octet] +q = [0xc9, 0x7f, 0xb1, 0xf0, 0x27, 0xf4, 0x53, 0xf6, + 0x34, 0x12, 0x33, 0xea, 0xaa, 0xd1, 0xd9, 0x35, + 0x3f, 0x6c, 0x42, 0xd0, 0x88, 0x66, 0xb1, 0xd0, + 0x5a, 0x0f, 0x20, 0x35, 0x02, 0x8b, 0x9d, 0x86, + 0x98, 0x40, 0xb4, 0x16, 0x66, 0xb4, 0x2e, 0x92, + 0xea, 0x0d, 0xa3, 0xb4, 0x32, 0x04, 0xb5, 0xcf, + 0xce, 0x33, 0x52, 0x52, 0x4d, 0x04, 0x16, 0xa5, + 0xa4, 0x41, 0xe7, 0x00, 0xaf, 0x46, 0x15, 0x03] + +popTest = + TestCase ( + assertEqual "Product of Primes" + (fromOctets 256 n) + ((fromOctets 256 p)*(fromOctets 256 q)) + ) + +d :: [Octet] +d = [0xa5, 0xda, 0xfc, 0x53, 0x41, 0xfa, 0xf2, + 0x89, 0xc4, 0xb9, 0x88, 0xdb, 0x30, 0xc1, 0xcd, + 0xf8, 0x3f, 0x31, 0x25, 0x1e, 0x06, 0x68, 0xb4, + 0x27, 0x84, 0x81, 0x38, 0x01, 0x57, 0x96, 0x41, + 0xb2, 0x94, 0x10, 0xb3, 0xc7, 0x99, 0x8d, 0x6b, + 0xc4, 0x65, 0x74, 0x5e, 0x5c, 0x39, 0x26, 0x69, + 0xd6, 0x87, 0x0d, 0xa2, 0xc0, 0x82, 0xa9, 0x39, + 0xe3, 0x7f, 0xdc, 0xb8, 0x2e, 0xc9, 0x3e, 0xda, + 0xc9, 0x7f, 0xf3, 0xad, 0x59, 0x50, 0xac, 0xcf, + 0xbc, 0x11, 0x1c, 0x76, 0xf1, 0xa9, 0x52, 0x94, + 0x44, 0xe5, 0x6a, 0xaf, 0x68, 0xc5, 0x6c, 0x09, + 0x2c, 0xd3, 0x8d, 0xc3, 0xbe, 0xf5, 0xd2, 0x0a, + 0x93, 0x99, 0x26, 0xed, 0x4f, 0x74, 0xa1, 0x3e, + 0xdd, 0xfb, 0xe1, 0xa1, 0xce, 0xcc, 0x48, 0x94, + 0xaf, 0x94, 0x28, 0xc2, 0xb7, 0xb8, 0x88, 0x3f, + 0xe4, 0x46, 0x3a, 0x4b, 0xc8, 0x5b, 0x1c, 0xb3, + 0xc1] + +dP :: [Octet] +dP = [0x54, 0x49, 0x4c, 0xa6, 0x3e, 0xba, 0x03, 0x37, + 0xe4, 0xe2, 0x40, 0x23, 0xfc, 0xd6, 0x9a, 0x5a, + 0xeb, 0x07, 0xdd, 0xdc, 0x01, 0x83, 0xa4, 0xd0, + 0xac, 0x9b, 0x54, 0xb0, 0x51, 0xf2, 0xb1, 0x3e, + 0xd9, 0x49, 0x09, 0x75, 0xea, 0xb7, 0x74, 0x14, + 0xff, 0x59, 0xc1, 0xf7, 0x69, 0x2e, 0x9a, 0x2e, + 0x20, 0x2b, 0x38, 0xfc, 0x91, 0x0a, 0x47, 0x41, + 0x74, 0xad, 0xc9, 0x3c, 0x1f, 0x67, 0xc9, 0x81] + +exponent1 = + toOctets 256 $ (fromOctets 256 d) `mod` ((fromOctets 256 p) - 1) + +e1Test = + TestCase ( + assertEqual "Exponent" dP exponent1 + ) + +dQ :: [Octet] +dQ = [0x47, 0x1e, 0x02, 0x90, 0xff, 0x0a, 0xf0, 0x75, + 0x03, 0x51, 0xb7, 0xf8, 0x78, 0x86, 0x4c, 0xa9, + 0x61, 0xad, 0xbd, 0x3a, 0x8a, 0x7e, 0x99, 0x1c, + 0x5c, 0x05, 0x56, 0xa9, 0x4c, 0x31, 0x46, 0xa7, + 0xf9, 0x80, 0x3f, 0x8f, 0x6f, 0x8a, 0xe3, 0x42, + 0xe9, 0x31, 0xfd, 0x8a, 0xe4, 0x7a, 0x22, 0x0d, + 0x1b, 0x99, 0xa4, 0x95, 0x84, 0x98, 0x07, 0xfe, + 0x39, 0xf9, 0x24, 0x5a, 0x98, 0x36, 0xda, 0x3d] + +m :: [Octet] +m = [0xd4, 0x36, 0xe9, 0x95, 0x69, 0xfd, 0x32, 0xa7, + 0xc8, 0xa0, 0x5b, 0xbc, 0x90, 0xd3, 0x2c, 0x49] + +seed :: [Octet] +seed = [0xaa, 0xfd, 0x12, 0xf6, 0x59, 0xca, 0xe6, 0x34, + 0x89, 0xb4, 0x79, 0xe5, 0x07, 0x6d, 0xde, 0xc2, + 0xf0, 0x6c, 0xb5, 0x8f] + +e :: [Octet] +e = [0x11] + +hash' xs = let (Word160 a b c d e) = hash xs in concatMap (toOctets 256) [a,b,c,d,e] + +encodedText = encode mgf hash' [] seed n m + +decodedText = decode mgf hash' [] encodedText + +encodingTest = + TestCase ( + assertEqual "Encoding / Decoding" m decodedText + ) + +cipherText = encrypt (n,e) encodedText + +plainText = decrypt (n,d) cipherText + +decodedText' = decode mgf hash' [] plainText + +encryptionTest = + TestCase ( + assertEqual "Encrypting / Decrypting" m decodedText + ) + +tests = TestList [popTest, e1Test, encodingTest, encryptionTest] + +main :: IO () +main = runTestTTAndExit tests diff --git a/src-test/SHA1Test.hs b/src-test/SHA1Test.hs new file mode 100644 --- /dev/null +++ b/src-test/SHA1Test.hs @@ -0,0 +1,38 @@ +module Main(main) where + +import Codec.Text.Raw (hexdumpBy) +import Codec.Utils (toOctets) +import Data.Char (ord) +import Data.Digest.SHA1 (Word160 (Word160), hash) +import Test.HUnit (runTestTTAndExit, (~:), (~=?)) +import Text.PrettyPrint (render) + +testCases = + [ ("Hello" , "f7ff9e8b7bb2e09b70935a5d785e0cc5d9d0abf0") + , ("haskell" , "f0234175f95a989496bf7f5ba03dea4dbc773e58") + , ("Cryptography" , "b804ec5a0d83d19d8db908572f51196505d09f98") + , ("Message Digest", "d52066b0fa1d68ef07eeab73031c3a3671298417") + ] + +testCases' = + [ ([] , "da39a3ee5e6b4b0d3255bfef95601890afd80709") + , ([0xa8] , "99f2aa95e36f95c2acb0eaf23998f030638f3f15") + , (toOctets 256 0x7e3a4c325cb9c52b88387f93d01ae86d42098f5efa7f9457388b5e74b6d28b2438d42d8b64703324d4aa25ab6aad153ae30cd2b2af4d5e5c00a8a2d0220c6116, "a3054427cdb13f164a610b348702724c808a0dcc") + , (toOctets 256 0xec29561244ede706b6eb30a1c371d74450a105c3f9735f7fa9fe38cf67f304a5736a106e92e17139a6813b1c81a4f3d3fb9546ab4296fa9f722826c066869edacd73b2548035185813e22634a9da44000d95a281ff9f264ecce0a931222162d021cca28db5f3c2aa24945ab1e31cb413ae29810fd794cad5dfaf29ec43cb38d198fe4ae1da2359780221405bd6712a5305da4b1b737fce7cd21c0eb7728d08235a9011, "970111c4e77bcc88cc20459c02b69b4aa8f58217") + , (toOctets 256 0x4893f1c763625f2c6ce53aacf28026f14b3cd8687e1a1d3b60a81e80fcd1e2b038f9145ab64a0718f948f7c3c9ac92e3d86fb669a5257da1a18c776291653688338210a3242120f101788e8acc9110db9258b1554bf3d26602516ea93606a25a7f566c0c758fb39ecd9d876bc5d8abc1c3205095382c2474cb1f8bbdb45c2c0e659cb0fc703ec607a5de6bcc7a28687db1ee1c8f34797bb2441d5706d210df8c2d7d65dbded36414d063c117b52a51f7a4eb9cac0782e008b47459ed5acac0bc1f20121087f992ad985511b33c866d18e63f585478ee5a5e654b19d81231d98683ae3f0533565aba43dce408d7e3c4c6be11d8f05165f29c9dcb2030c4ee31d3a04e7421aa92c3231a1fc07e50e95fea7389a5e65891afaba51cf55e36a9d089bf293accb356d5d06547307d6e41456d4ed146a056179971c56521c83109bf922866186e184a99a96c7bb96df8937e35970e438412a2b8d744cf2ad87cb605d4232e976f9f15169776e4e5b6b786132c966b25fc56d815c56c819af5e159aa39f8a93d38115f5580cda93bc073c30b39920e726fe861b72483a3f886269ab7a8eefe952f35d25c4eb7f443f4f3f26e43d51fb54591e6a6dad25fcdf5142033084e5624bdd51435e77dea86b8, "dc5859dd5163c4354d5d577b855fa98e37f04384") + , (toOctets 256 0xcf494c18a4e17bf03910631471bca5ba7edea8b9a63381e3463517961749848eb03abefd4ce676dece3740860255f57c261a558aa9c7f11432f549a9e4ce31d8e17c79450ce2ccfc148ad904aedfb138219d7052088520495355dadd90f72e6f69f9c6176d3d45f113f275b7fbc2a295784d41384cd7d629b23d1459a22e45fd5097ec9bf65fa965d3555ec77367903c32141065fc24da5c56963d46a2da3c279e4035fb2fb1c0025d9dda5b9e3443d457d92401a0d3f58b48469ecb1862dc975cdbe75ca099526db8b0329b03928206f084c633c04eef5e8e377f118d30edf592504be9d2802651ec78aeb02aea167a03fc3e23e5fc907c324f283f89ab37e84687a9c74ccf055402db95c29ba2c8d79b2bd4fa96459f8e3b78e07e923b81198267492196ecb71e01c331f8df245ec5bdf8d0e05c91e63bb299f0f6324895304dda721d39410458f117c87b7dd6a0ee734b79fcbe482b2c9e9aa0cef03a39d4b0c86de3bc34b4aadabfa373fd2258f7c40c187744d237080762382f547a36adb117839ca72f8ebbc5a20a07e86f4c8bb923f5787698d278f6db0040e76e54645bb0f97083995b34b9aa445fc424455058795828dd00c32471ec402a307f5aa1b37b1a86d6dae3bcbfbe9ba41cab0beeabf489af0073d4b3837d3f14b815120bc3602d072b5aeefcdec655fe756b660eba7dcf34675acbce317746270599424b9248791a0780449c1eabbb9459cc1e588bfd74df9b1b711c85c09d8aa171b309281947e8f4b6ac438753158f4f36fa, "4c17926feb6e87f5bca7890d8a5cde744f231dab") + , (toOctets 256 0xe79701ff44ecfe5a7e97306a9c93791a2b4a6948e0aa06797f7cc8cbfbf1e82bdf7edbc7ecea19c604a62237475cc3487bca95b9b1d1c89025c91e0d67183ae0b8031b9ab7c4e4623ddcdee985aabfa0903d2d28c7677e09e312c2a80ad703733acdcb5feb9fe794f0e26b669fa5f6883149377c6c93b04e7fffba822d57ca4b2d85f2fed1a6abc5e75fd198dd74ef692896bd9fe57de7c6c137108517c017d059d2995eb1feb75ee8fc1966864032ac3bcdc6787d4eaad97363cc981239736a865dc769d3d293c5bc614ab7e43048b733965bef7b2e82ef5b2af4a264ea64817bce84067e48c8642b356c753d6db8f4d79883ec2644f6704335928d56fc747d01ccd81dfc88dda2fc208887da1e0ac9f17c4657c8b98ec4f12cad4030972bc6e0ffcc9793bb5ae6f9cca4d5036cc7a047e9ac18a7b4d2542db54ea33ae210c4e010675a8c09c89ae8decb47ff7f76e0a388be180b5e4b86c17b7c9ebc06abe0c8a7b24f2f99ad25920102c5187e9ff1cb01833d3edf80c373243f19fd2b8480626bb35ec39494efbfdb53379491cb3b87fb0370875ef9740d599ffc4677240e74057470922102603614c585bce28026a11f479a2d033fff55c1a52fdf1512f0c71cfd6be26981e0c1556097d896491adf1456a179f8d9ce1405589a102bd69023595439fc9498d726462d5530d8ab7f0b82396fb3624f4711ccc12621e2f954506483c028c9d0ad2e8e33a80bce30bdeb13f6ea236c2ad416bfe6b9596102a615e492eaad30afcaa1d57b76b3a05f3c486d97fc103bf1dce986d13c01d179ed3b82879dd5f2bf9647c50ba96e77c064e938238cc4fa2cc753c88a986159e6908be56cc3e637887ae804ed27857bdc9e981da38185cf64fc1c2d17b3c122d2f9cab54843292691dc4b3a29da40d33a501bc31ec59ce21fe50c5f82776953c58fc39c2405e6e862253910c5a8e6a863e43bd49c3f515ce8e9eb03d3cba01545ba3d4007f165a483be7a2dcb7bc121ddc0c0f526d7eb65447080c41096b090dce2ff49f9efed837d0dd63b423a1767324e72d0c275b424bde2944743c2dfeb116fd26003e7c7add67c15df33cd31a1e9f4190d7b01f2c2daa8ef377336764f6cc97e2d2bc13c491972fec3a51b57f88b1c7c545663ee672328593aa9dabce37659cb577b659280cb575a8fa00ed0949f2d644b5d84f03921cb9af8ec96fbd0b6858187fbbb11797692f1eb2d8de69cad8f999d974a3f635bf9791b4452793db5b66764b2ac035da18d8b7d5281df383ea9e3f00c9e250b5a1bc048b9f68053f9554697a81eae53d5aff0f019d00492d9e50aedc569e85aa4973529546a56390cc8e6c7e5fa5c849960e7ea8a639dcf06aad53bc991d177c3d7a1661c96431876790f9d7229531775083a13ac22f21a4d610d822000288a3f41cba71a639118bdce89c05692db35f10faf1587f54a9937707a6cd39c35bd9e3f7d9354b786606b311bda991c3e0696de0f9523c5ef744b40e49fe94f3f366a387dd2d47c6c1907098f9044b1c2b1ebdb213e897827d4113913c36aff901d2a94940da298896a1abeab8c5d38b15f796fafb5c0f83be112c3cf815f966e9b67ba8aecc4f5267c2bb83876ef985137c6027fa5d02b73c2d547df81cffb22d8a814271644798a77c25efdf5ffbbeb625cfd5bb4c2fb16a0e32b0c6ac216f4fb75093334290eff82681ac4b29788c607c3c6098a9d4f6ea2c2d91ee440cf2b2c560175ed7c9bcbc5a3535355bee72c4f81c751d0690ec1f1fcb7dd99520e1195d464b6ea44073769fe7273857dc063622067fd2e2e2258b4192f102effbbec5b769bbed2893c8b96feddeceadbfbb467280dd34bf5727b149fa8814e50be05a9c50c554e54210f732dfd862de08167861f239dd0c5e67139188af69f4bffa4a548204306ac9e0b29123a09f69438c4e98f102164a766844a0b3c38c9fa671177873f4fa1999bc6df35fd3cec000913b5ff3c28b0a2dafa6f01280f7565dc93480ad243c8230089be1face8b82bdc9b15f80f795cbe2a1cd281b5424b934773405a3fe52253b59cee57b1d5021d9aa52f01f1de0f033f3298134b9bf28c91fa86fef0fe5830a347966572cb71df29792ba24a1d717aff84ec3f52e01358a06d437e4b5511c2b0d2dfd25992ad78735f326382ff2b2a5359f48e32da55005e179e63bab4f612c584f025ccf15ff05f9f6ccd014ce51c23fbd8875451618bb23fc033a4e1ae27cba6f2e635b22f50d48000672fcc465658b0c1b31e0dde01832cd07971a5e20aa8800c9efb9bc49fbc4b16b97546f7e2d8c1d798f9d5756abb27f7ba88c83ac1465a67d48675c7e5fe49d84c3984a0c88d7641c04e72cecf41785d8053125d568b7c2a103e07df2a82bf6ca7e44ce80e5e1628b383ad9037fd672952394bf4d0612d7eda8b1bb57730f8fa53df6777be32ebb3f7024c63abd73c84b9a23aa638afb78bbbd577f0d3f03babd6919df6dff33b0b163117f132b73e953cf6a81c955d60783a84e43947aacfa6ba61b50d7a884f57987ad8dfd485b685639e5dfeef52716ee0002a38da46fd1486b9796396d96fc0034455d89929ec7bb60021f34f78319433b1119494ac0d1dc300afa13bcee26ee1f657828a8b28a0be85bca3bcb6ea13bd0061f67dc447e8f89d206e714ff288b9faa685ae94b21b0295f5b73ef4e2120653e1059e77f29eadfa94734144e53614b70a8a0e2ad1150a9995d7dd1a63ba94135a6afeab58666b7ed358b29504a279954b39b036cfb65ff765aaa211b332f1a995cca549bf69b891a4c4cd2a97f170fc30399ea1f22588192ad994bf1aa3a57b57d49c3a70cf1f9bd05f99ebe64e81548333e051838b0d65af0bbb0de23536f36b2aea64b3bf250420d21ec138df35050ace7c30c90f7745bbe920e3510f2e78987597b1d061543559c56492d7cc13778eb37c250eda4d20151bca2ab15a1571a55dac080ede339446df7448093ea413d689e7179813175e8648c1c8483d71485b8c3050b65e4a8aaec955c9175d6e3facf9c6f0b1e35e66d6180ea75fe1cc6482a72b7310082280582b0fff4950fb64d6ab20979f72a8a2cd35b8ad3d6ead2de259a658640542dc0dababd0e640d3eb1d46fdf4aae780793244c7c42c0b9d0b4247a7e7fa7d320795f4302638547c3a497366ef1c6b6b53cff044d372e023666b1c390819977b6ab8aca6e885b580bb22d961703b25f3986ade36c25816c7a6267e61a30b7ba46c3e7c15fe168a67d56f21f95f513e9fb1ccb9a57926d51133391629a016523574ee0b864f33fcb7effaf233a4a4ddf704bd279adf24448a766c8b98e78344b7ec910200c52333fa7389f519277c2b84fa05d01bde9a8cb9d58985b6619a78b13bef088c473056b7c8e5d1b2d12350cdfc6b5e335dcfd426b956ae8cf4a217abc9d0c631bea08d7756d62f0688e0735b70b876e7450c455a8b9dab2189e5482dfefce3f710bc02c18524b71e35fabcb4bfb4c2417c9907dcb124277e09a934c0423a08e626ccda1dbd961001c1ba54625227ea48ebbe413495b4c8a95a3702ebfd54dd07, "0eb8d69f6661b8124ddf76a635dc2821cbac32d7") + ] + +-- genTests' :: [([Word8], String)] -> Test +genTests' cases = + "SHA1" ~: map f cases + where f (val, dgst) = dgst ~=? hexHash' val + +-- hexHash' :: [Word8] -> String +hexHash' x = + let (Word160 a b c d e) = hash x in + render . (hexdumpBy "" 20) . concatMap (toOctets 256) $ [a,b,c,d,e] + +main :: IO () +main = runTestTTAndExit $ genTests' testCases' diff --git a/src-test/SHA2Test.hs b/src-test/SHA2Test.hs new file mode 100644 --- /dev/null +++ b/src-test/SHA2Test.hs @@ -0,0 +1,58 @@ +-- Copyright : (c) Russell O'Connor 2006 +-- License : BSD-style (see the file ReadMe.tex) + +module Main(main) where + +import Data.Digest.SHA2 +import Test.HUnit (runTestTTAndExit, test, (~:), (~?=)) + +----------------------------------------------------------------------------- +-- ** Test cases +-- | Below are test cases from the FIPS 180-2 document +----------------------------------------------------------------------------- + +-- Should this go into it's own module? + +test_sha256 = "SHA-256" ~: test + [toOctets (sha256Ascii "abc") ~?= + [0xba,0x78,0x16,0xbf,0x8f,0x01,0xcf,0xea,0x41,0x41,0x40,0xde,0x5d,0xae,0x22,0x23,0xb0,0x03,0x61,0xa3,0x96,0x17,0x7a,0x9c,0xb4,0x10,0xff,0x61,0xf2,0x00,0x15,0xad] + ,toOctets (sha256Ascii "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq") ~?= + [0x24,0x8d,0x6a,0x61,0xd2,0x06,0x38,0xb8,0xe5,0xc0,0x26,0x93,0x0c,0x3e,0x60,0x39,0xa3,0x3c,0xe4,0x59,0x64,0xff,0x21,0x67,0xf6,0xec,0xed,0xd4,0x19,0xdb,0x06,0xc1] + ,toOctets (sha256Ascii (replicate 1000000 'a')) ~?= + [0xcd,0xc7,0x6e,0x5c,0x99,0x14,0xfb,0x92,0x81,0xa1,0xc7,0xe2,0x84,0xd7,0x3e,0x67,0xf1,0x80,0x9a,0x48,0xa4,0x97,0x20,0x0e,0x04,0x6d,0x39,0xcc,0xc7,0x11,0x2c,0xd0] + ] + +test_sha512 = "SHA-512" ~: test + [toOctets (sha512Ascii "abc") ~?= + [0xdd,0xaf,0x35,0xa1,0x93,0x61,0x7a,0xba,0xcc,0x41,0x73,0x49,0xae,0x20,0x41,0x31,0x12,0xe6,0xfa,0x4e,0x89,0xa9,0x7e,0xa2,0x0a,0x9e,0xee,0xe6,0x4b,0x55,0xd3,0x9a,0x21,0x92,0x99,0x2a,0x27,0x4f,0xc1,0xa8,0x36,0xba,0x3c,0x23,0xa3,0xfe,0xeb,0xbd,0x45,0x4d,0x44,0x23,0x64,0x3c,0xe8,0x0e,0x2a,0x9a,0xc9,0x4f,0xa5,0x4c,0xa4,0x9f] + ,toOctets (sha512Ascii ("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmn"++ + "hijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu")) ~?= + [0x8e,0x95,0x9b,0x75,0xda,0xe3,0x13,0xda,0x8c,0xf4,0xf7,0x28,0x14,0xfc,0x14,0x3f,0x8f,0x77,0x79,0xc6,0xeb,0x9f,0x7f,0xa1,0x72,0x99,0xae,0xad,0xb6,0x88,0x90,0x18,0x50,0x1d,0x28,0x9e,0x49,0x00,0xf7,0xe4,0x33,0x1b,0x99,0xde,0xc4,0xb5,0x43,0x3a,0xc7,0xd3,0x29,0xee,0xb6,0xdd,0x26,0x54,0x5e,0x96,0xe5,0x5b,0x87,0x4b,0xe9,0x09] + ,toOctets (sha512Ascii (replicate 1000000 'a')) ~?= + [0xe7,0x18,0x48,0x3d,0x0c,0xe7,0x69,0x64,0x4e,0x2e,0x42,0xc7,0xbc,0x15,0xb4,0x63,0x8e,0x1f,0x98,0xb1,0x3b,0x20,0x44,0x28,0x56,0x32,0xa8,0x03,0xaf,0xa9,0x73,0xeb,0xde,0x0f,0xf2,0x44,0x87,0x7e,0xa6,0x0a,0x4c,0xb0,0x43,0x2c,0xe5,0x77,0xc3,0x1b,0xeb,0x00,0x9c,0x5c,0x2c,0x49,0xaa,0x2e,0x4e,0xad,0xb2,0x17,0xad,0x8c,0xc0,0x9b] + ] + +test_sha384 = "SHA-384" ~: test + [toOctets (sha384Ascii "abc") ~?= + [0xcb,0x00,0x75,0x3f,0x45,0xa3,0x5e,0x8b,0xb5,0xa0,0x3d,0x69,0x9a,0xc6,0x50,0x07,0x27,0x2c,0x32,0xab,0x0e,0xde,0xd1,0x63,0x1a,0x8b,0x60,0x5a,0x43,0xff,0x5b,0xed,0x80,0x86,0x07,0x2b,0xa1,0xe7,0xcc,0x23,0x58,0xba,0xec,0xa1,0x34,0xc8,0x25,0xa7] + ,toOctets (sha384Ascii ("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmn"++ + "hijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu")) ~?= + [0x09,0x33,0x0c,0x33,0xf7,0x11,0x47,0xe8,0x3d,0x19,0x2f,0xc7,0x82,0xcd,0x1b,0x47,0x53,0x11,0x1b,0x17,0x3b,0x3b,0x05,0xd2,0x2f,0xa0,0x80,0x86,0xe3,0xb0,0xf7,0x12,0xfc,0xc7,0xc7,0x1a,0x55,0x7e,0x2d,0xb9,0x66,0xc3,0xe9,0xfa,0x91,0x74,0x60,0x39] + ,toOctets (sha384Ascii (replicate 1000000 'a')) ~?= + [0x9d,0x0e,0x18,0x09,0x71,0x64,0x74,0xcb,0x08,0x6e,0x83,0x4e,0x31,0x0a,0x4a,0x1c,0xed,0x14,0x9e,0x9c,0x00,0xf2,0x48,0x52,0x79,0x72,0xce,0xc5,0x70,0x4c,0x2a,0x5b,0x07,0xb8,0xb3,0xdc,0x38,0xec,0xc4,0xeb,0xae,0x97,0xdd,0xd8,0x7f,0x3d,0x89,0x85] + ] + +test_sha224 = "SHA-224" ~: test + [toOctets (sha224Ascii "abc") ~?= + [0x23,0x09,0x7d,0x22,0x34,0x05,0xd8,0x22,0x86,0x42,0xa4,0x77,0xbd,0xa2,0x55,0xb3,0x2a,0xad,0xbc,0xe4,0xbd,0xa0,0xb3,0xf7,0xe3,0x6c,0x9d,0xa7] + ,toOctets (sha224Ascii "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq") ~?= + [0x75,0x38,0x8b,0x16,0x51,0x27,0x76,0xcc,0x5d,0xba,0x5d,0xa1,0xfd,0x89,0x01,0x50,0xb0,0xc6,0x45,0x5c,0xb4,0xf5,0x8b,0x19,0x52,0x52,0x25,0x25] + ,toOctets (sha224Ascii (replicate 1000000 'a')) ~?= + [0x20,0x79,0x46,0x55,0x98,0x0c,0x91,0xd8,0xbb,0xb4,0xc1,0xea,0x97,0x61,0x8a,0x4b,0xf0,0x3f,0x42,0x58,0x19,0x48,0xb2,0xee,0x4e,0xe7,0xad,0x67] + ] + + +test_sha2 = "SHA-2" ~: test [test_sha256, test_sha512, test_sha384, test_sha224] + +main :: IO () +main = runTestTTAndExit test_sha2 >> return () diff --git a/src-test/SymmetricTest.hs b/src-test/SymmetricTest.hs new file mode 100644 --- /dev/null +++ b/src-test/SymmetricTest.hs @@ -0,0 +1,233 @@ +module Main(main) where + +import Codec.Utils +import Codec.Encryption.Blowfish as Blowfish +import Codec.Encryption.Modes +import Codec.Encryption.Padding +import Codec.Encryption.DES as DES +import Codec.Encryption.AES as AES +import Data.Word +import Data.Bits +import Data.Char +import Data.LargeWord +import Test.HUnit +import Numeric + +-- AES Tests. + +-- Comparision with resuts from +-- http://www.cs.ucsd.edu/~fritz/rijndael_test.html + +ad = 0xF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word128 +ak16 = 0xF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word128 +ae16 = 0x6e94fffbb861b2c1769cd4629f3d724b :: Word128 +ae16' = AES.encrypt ak16 ad +aesTest1 = + TestCase ( + assertEqual "AES Key Length 128" ae16 ae16' + ) + +ak24 = 0xF0E1D2C3B4A5968778695A4B3C2D1E0FF0E1D2C3B4A59687 :: Word192 +ae24' = AES.encrypt ak24 ad +ae24 = 0x07d806bb62ebb4399354594ea6586ec6 :: Word128 +aesTest2 = + TestCase ( + assertEqual "AES Key Length 192" ae24 ae24' + ) + +ak32 = 0xF0E1D2C3B4A5968778695A4B3C2D1E0FF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word256 +ae32' = AES.encrypt ak32 ad +ae32 = 0x28e88482d9b146fdde7e080fcbae1b98 :: Word128 +aes3 = ae32 == ae32' +aesTest3 = + TestCase ( + assertEqual "AES Key Length 256" ae32 ae32' + ) + +-- Comparision with resuts from +-- http://www.zvon.org/tmRFC/RFC3602/Output/chapter4.html + +aeskey16 = 0x06a9214036b8a15b512e03d534120006 :: Word128 +aesiv16 = 0x3dafba429d9eb430b422da802c9fac41 :: Word128 +aesplaintext = "Single block msg" +aesciphertext = [0xe353779c1079aeb82708942dbe77181a] :: [Word128] +aesciphertext' = + cbc AES.encrypt aesiv16 aeskey16 $ + pkcs5 $ + map (fromIntegral . ord) aesplaintext +-- aescbc1 = aesciphertext == take 1 aesciphertext' +aescbcTest1 = + TestCase ( + assertEqual "AES CBC PKCS5 Key Length 128" + aesciphertext (take 1 aesciphertext') + ) + +aesplaintext' = + map (chr . fromIntegral) $ + unPkcs5 $ + unCbc AES.decrypt aesiv16 aeskey16 aesciphertext' +aescbcTest2 = + TestCase ( + assertEqual "AES CBC PKCS5 Decryption Key Length 128" + aesplaintext aesplaintext' + ) + +aes2key16 = 0x6c3ea0477630ce21a2ce334aa746c2cd :: Word128 +aes2iv16 = 0xc782dc4c098c66cbd9cd27d825682c81 :: Word128 +aes2plaintext = "This is a 48-byte message (exactly 3 AES blocks)" +aes2ciphertext = [0xd0a02b3836451753d493665d33f0e886, + 0x2dea54cdb293abc7506939276772f8d5, + 0x021c19216bad525c8579695d83ba2684] :: [Word128] +aes2ciphertext' = + cbc AES.encrypt aes2iv16 aes2key16 $ + pkcs5 $ + map (fromIntegral . ord) aes2plaintext +aescbcTest3 = + TestCase ( + assertEqual "AES CBC PKCS5 3 Blocks Key Length 128" + aes2ciphertext (take 3 aes2ciphertext') + ) + +-- Comparision with resuts from +-- http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf + +aes3key24 = + 0x8e73b0f7da0e6452c810f32b809079e562f8ead2522c6b7b :: Word192 +aes3iv16 = 0x000102030405060708090a0b0c0d0e0f :: Word128 +aes3plaintext = + [0x6bc1bee22e409f96e93d7e117393172a, + 0xae2d8a571e03ac9c9eb76fac45af8e51, + 0x30c81c46a35ce411e5fbc1191a0a52ef, + 0xf69f2445df4f9b17ad2b417be66c3710] :: [Word128] +aes3ciphertext' = + cbc AES.encrypt aes3iv16 aes3key24 $ + pkcs5 $ + concat $ + map (toOctets 256) aes3plaintext +aes3ciphertext = + [0x4f021db243bc633d7178183a9fa071e8, + 0xb4d9ada9ad7dedf4e5e738763f69145a, + 0x571b242012fb7ae07fa9baac3df102e0, + 0x08b0e27988598881d920a9e64f5615cd] :: [Word128] +aescbcTest4 = + TestCase ( + assertEqual "AES CBC PKCS5 4 Blocks Key Length 192" + aes3ciphertext (take 4 aes3ciphertext') + ) + +aes4key32 = + 0x603deb1015ca71be2b73aef0857d77811f352c073b6108d72d9810a30914dff4 + :: Word256 +aes4iv16 = 0x000102030405060708090a0b0c0d0e0f :: Word128 +aes4plaintext = + [0x6bc1bee22e409f96e93d7e117393172a, + 0xae2d8a571e03ac9c9eb76fac45af8e51, + 0x30c81c46a35ce411e5fbc1191a0a52ef, + 0xf69f2445df4f9b17ad2b417be66c3710] :: [Word128] +aes4ciphertext' = + cbc AES.encrypt aes4iv16 aes4key32 $ + pkcs5 $ + concat $ + map (toOctets 256) aes3plaintext +aes4ciphertext = + [0xf58c4c04d6e5f1ba779eabfb5f7bfbd6, + 0x9cfc4e967edb808d679f777bc6702c7d, + 0x39f23369a9d9bacfa530e26304231461, + 0xb2eb05e2c39be9fcda6c19078c6a9d1b] :: [Word128] +aescbcTest5 = + TestCase ( + assertEqual "AES CBC PKCS5 4 Blocks Key Length 256" + aes4ciphertext (take 4 aes4ciphertext') + ) + +-- Blowfish Tests. + +-- Tests from http://www.counterpane.com/vectors.txt. + +d = 0xFEDCBA9876543210 :: Word64 +k = 0xF0 :: Word8 +e = 0xF9AD597C49DB005E :: Word64 +e' = Blowfish.encrypt k d +bfTest1 = + TestCase ( + assertEqual "Blowfish Key Length 8" e e' + ) + +k2 = 0xF0E1 :: Word16 +e2 = 0xE91D21C1D961A6D6 :: Word64 +e2' = Blowfish.encrypt k2 d +bfTest2 = + TestCase ( + assertEqual "Blowfish Key Length 16" e2 e2' + ) + +e8 = 0xE87A244E2CC85E82 :: Word64 +k8 = 0xF0E1D2C3B4A59687 :: Word64 +e8' = Blowfish.encrypt k8 d +bfTest3 = + TestCase ( + assertEqual "Blowfish Key Length 64" e8 e8' + ) + +e16 = 0x93142887EE3BE15C :: Word64 +k16= 0xF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word128 +e16' = Blowfish.encrypt k16 d +bfTest4 = + TestCase ( + assertEqual "Blowfish Key Length 128" e16 e16' + ) + +-- Blowfish test with Cipher Block Chaining. +-- Set up the published key, initialization vector and data. + +key16 = 0x0123456789ABCDEFF0E1D2C3B4A59687 :: Word128 +iv8 = 0xFEDCBA9876543210 :: Word64 +data29 = "7654321 Now is the time for \NUL" + +-- Pad with nulls as in the example. + +e29' = + cbc Blowfish.encrypt iv8 key16 $ padNulls $ map (fromIntegral . ord) data29 + +e29 = [0x6B,0x77,0xB4,0xD6,0x30,0x06,0xDE,0xE6, + 0x05,0xB1,0x56,0xE2,0x74,0x03,0x97,0x93, + 0x58,0xDE,0xB9,0xE7,0x15,0x46,0x16,0xD9, + 0x59,0xF1,0x65,0x2B,0xD5,0xFF,0x92,0xCC] :: [Octet] + +bfTest5 = + TestCase ( + assertEqual "AES CBC Nulls Key Length 128" + e29 (concat $ map (toOctets 256) e29') + ) + +-- DES Tests + +-- Test from http://www.itl.nist.gov/fipspubs/fip81.htm + +key = 0x0123456789abcdef :: Word64 +iv = 0x1234567890abcdef :: Word64 +expectedDES = [0xe5c7cdde872bf27c, + 0x43e934008c389c0f, + 0x683788499a7c05f6] :: [Word64] +plainText = "Now is the time for all " + +-- Pad using PKCS#5 so only take the first 3 blocks of the ciphertext. + +cipherText = + cbc DES.encrypt iv key $ pkcs5 $ map (fromIntegral . ord) plainText +descbcTest1 = + TestCase ( + assertEqual "DES CBC PKCS5 3 Blocks" + expectedDES (take 3 cipherText) + ) + +tests = + TestList [ + aesTest1, aesTest2, aesTest3, aescbcTest1, + aescbcTest2, aescbcTest3, aescbcTest4, aescbcTest5, + bfTest1, bfTest2, bfTest3, bfTest4, bfTest5, + descbcTest1 + ] + +main :: IO () +main = runTestTTAndExit tests diff --git a/src-test/WordListTest.hs b/src-test/WordListTest.hs new file mode 100644 --- /dev/null +++ b/src-test/WordListTest.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Main(main) where + +import Codec.Utils (listFromOctets, listToOctets) +import Control.Monad (unless) +import Data.Bits (Bits, bitSize) +import Data.LargeWord (Word128, Word160, Word192, Word224, Word256, Word96) +import Data.Word (Word32, Word64, Word8) +import Test.QuickCheck + +newtype WordsX a = WordsX [a] + +instance Show a => Show (WordsX a) where + show (WordsX x) = show x + +instance (Bounded a, Integral a, Bits a) => Arbitrary (WordsX a) where + arbitrary = fmap WordsX (liftArbitrary $ chooseBoundedIntegral (minBound,maxBound)) + +checks :: [(String, IO Result)] +checks = + [ ("Word32", quickCheckWithResult args $ + \w -> not (hasTrailingZero w) ==> (listFromOctets . listToOctets) w === (w :: [Word32])) + , ("Word64", quickCheckWithResult args $ + \w -> not (hasTrailingZero w) ==> (listFromOctets . listToOctets) w === (w :: [Word64])) + , ("Word96", quickCheckWithResult args $ + \(WordsX w) -> not (hasTrailingZero w) ==> (listFromOctets . listToOctets) w === (w :: [Word96])) + , ("Word128", quickCheckWithResult args $ + \(WordsX w) -> not (hasTrailingZero w) ==> (listFromOctets . listToOctets) w === (w :: [Word128])) + , ("Word160", quickCheckWithResult args $ + \(WordsX w) -> not (hasTrailingZero w) ==> (listFromOctets . listToOctets) w === (w :: [Word160])) + , ("Word192", quickCheckWithResult args $ + \(WordsX w) -> not (hasTrailingZero w) ==> (listFromOctets . listToOctets) w === (w :: [Word192])) + , ("Word224", quickCheckWithResult args $ + \(WordsX w) -> not (hasTrailingZero w) ==> (listFromOctets . listToOctets) w === (w :: [Word224])) + , ("Word256", quickCheckWithResult args $ + \(WordsX w) -> not (hasTrailingZero w) ==> (listFromOctets . listToOctets) w === (w :: [Word256])) + ] + where + args = stdArgs { maxSuccess = 1000 } + + -- (listFromOctets . listToOctets) isn't a proper identity due to 'trimNulls' + hasTrailingZero :: (Eq x, Num x) => [x] -> Bool + hasTrailingZero [] = False + hasTrailingZero xs = last xs == 0 + +main :: IO () +main = do + results <- mapM test checks + + unless (all isSuccess results) $ + fail "SOME TESTS FAILED!" + + putStrLn "=> all tests passed!" + where + test :: (String, IO a) -> IO a + test (s, t) = do putStrLn $ "Checking " ++ s + putStr " " + t diff --git a/src/Codec/Binary/BubbleBabble.hs b/src/Codec/Binary/BubbleBabble.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Binary/BubbleBabble.hs @@ -0,0 +1,40 @@ +module Codec.Binary.BubbleBabble(encode) where + + +import Data.Array.Unboxed +import Data.Bits +import Data.Word + +import Codec.Utils + + +vowel :: UArray Int Char +vowel = listArray (0,5) "aeiouy" + +consonant :: UArray Int Char +consonant = listArray (0,16) "bcdfghklmnprstvzx" + + +-- | Encode binary data into the /Bubble Babble/ human readable encoding. +-- /Bubble Babble/ is an encoding that represents binary data as psuedowords +-- which are more pronouncable and memorable than standard hexadecimal encoding. +-- +-- It is mainly used for representing cryptographic fingerprints. +-- In addition, there is an amount of redundancy and error correction built into +-- the representation so that transcription errors can be more readily identified. +-- +-- See also for more details. + +encode :: [Octet] -> String +encode cs = 'x' : bb 1 (map fromIntegral cs) where + bb seed [] = vcvx ((seed `mod` 6),16,(seed `div` 6)) + bb seed [x] = vcvx ((((x `shiftR` 6) .&. 3) + seed) `mod` 6, (x `shiftR` 2) .&. 15, ((x .&. 3) + (seed `div` 6)) `mod` 6) + bb seed (x:y:xs) = vcvcc (a,b,c,d,e) $ bb ((seed * 5 + (x * 7 + y)) `mod` 36) xs where + a = (((x `shiftR` 6) .&. 3) + seed) `mod` 6 + b = (x `shiftR` 2) .&. 15 + c = ((x .&. 3) + (seed `div` 6)) `mod` 6 + d = (y `shiftR` 4) .&. 15 + e = y .&. 15 + vcvx (a,b,c) = vowel!a : consonant!b : vowel!c : "x" + vcvcc (a,b,c,d,e) xs = vowel!a : consonant!b : vowel!c : consonant!d : '-' : consonant!e : xs + diff --git a/src/Codec/Encryption/AES.hs b/src/Codec/Encryption/AES.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/AES.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.AES +-- Copyright : (c) Dominic Steinitz 2004 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +-- Takes the AES module supplied by Lukasz Anforowicz and wraps it so it can +-- used with the standard modes. +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.AES ( + -- * Function Types + encrypt, decrypt, AESKey) where + +import Codec.Encryption.AESAux +import Codec.Utils +import Data.Bits +import Data.LargeWord +import Data.Word + +class (Bits a, Integral a) => AESKeyIndirection a +class AESKeyIndirection a => AESKey a + +instance AESKeyIndirection Word128 +instance AESKeyIndirection Word192 +instance AESKeyIndirection Word256 + +instance AESKey Word128 +instance AESKey Word192 +instance AESKey Word256 + +-- | Basic AES encryption which takes a key and a block of plaintext +-- and returns the encrypted block of ciphertext according to the standard. + +encrypt :: AESKey a => a -> Word128 -> Word128 +encrypt k p = + case bitSize k of + 128 -> f aes128Encrypt k p + 192 -> f aes192Encrypt k p + 256 -> f aes256Encrypt k p + +f g k p = + fromIntegral $ fromOctets 256 $ + g (i2osp (bitSize k `div` bitSize (0::Octet)) $ fromIntegral k) + (i2osp (bitSize p `div` bitSize (0::Octet)) $ fromIntegral p) + +-- | Basic AES decryption which takes a key and a block of ciphertext and +-- returns the decrypted block of plaintext according to the standard. + +decrypt :: AESKey a => a -> Word128 -> Word128 +decrypt k p = + case bitSize k of + 128 -> f aes128Decrypt k p + 192 -> f aes192Decrypt k p + 256 -> f aes256Decrypt k p diff --git a/src/Codec/Encryption/AESAux.hs b/src/Codec/Encryption/AESAux.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/AESAux.hs @@ -0,0 +1,1008 @@ +-- | Advanced Encryption System (specification can be found in FIPS-197) +module Codec.Encryption.AESAux( + aes128Encrypt, + aes192Encrypt, + aes256Encrypt, + aes128Decrypt, + aes192Decrypt, + aes256Decrypt, +) where + +import Data.Bits +import Data.Int(Int) +import Data.Word(Word32) + +import Codec.Utils(Octet) + +aes128Encrypt :: [Octet] -- ^ key (16 octets) + -> [Octet] -- ^ msg (16 octets) + -> [Octet] -- ^ enciphered msg (16 octets) +aes128Encrypt = aesEncrypt 10 4 + +aes192Encrypt :: [Octet] -- ^ key (24 octets) + -> [Octet] -- ^ msg (16 octets) + -> [Octet] -- ^ enciphered msg (16 octets) +aes192Encrypt = aesEncrypt 12 6 + +aes256Encrypt :: [Octet] -- ^ key (32 octets) + -> [Octet] -- ^ msg (16 octets) + -> [Octet] -- ^ enciphered msg (16 octets) +aes256Encrypt = aesEncrypt 14 8 + +aes128Decrypt :: [Octet] -- ^ key (16 octets) + -> [Octet] -- ^ enciphered msg (16 octets) + -> [Octet] -- ^ deciphered msg (16 octets) +aes128Decrypt = aesDecrypt 10 4 + +aes192Decrypt :: [Octet] -- ^ key (24 octets) + -> [Octet] -- ^ enciphered msg (16 octets) + -> [Octet] -- ^ deciphered msg (16 octets) +aes192Decrypt = aesDecrypt 12 6 + +aes256Decrypt :: [Octet] -- ^ key (32 octets) + -> [Octet] -- ^ enciphered msg (16 octets) + -> [Octet] -- ^ deciphered msg (16 octets) +aes256Decrypt = aesDecrypt 14 8 + +aesEncrypt :: Int -- ^ nr + -> Int -- ^ nk + -> [Octet] -- ^ key + -> [Octet] -- ^ msg + -> [Octet] -- ^ enciphered msg +aesEncrypt nr nk key + [i00, i10, i20, i30, + i01, i11, i21, i31, + i02, i12, i22, i32, + i03, i13, i23, i33] = + [fo o00, fo o10, fo o20, fo o30, + fo o01, fo o11, fo o21, fo o31, + fo o02, fo o12, fo o22, fo o32, + fo o03, fo o13, fo o23, fo o33] + where State (o00, o01, o02, o03) + (o10, o11, o12, o13) + (o20, o21, o22, o23) + (o30, o31, o32, o33) = transform ( + State(fi i00, fi i01, fi i02, fi i03) + (fi i10, fi i11, fi i12, fi i13) + (fi i20, fi i21, fi i22, fi i23) + (fi i30, fi i31, fi i32, fi i33)) + fi = (fromIntegral :: Octet -> Word32) + fo = (fromIntegral :: Word32 -> Octet) + (kt0:kts) = genAddRoundKey (generateKeys nr nk key) + transform = foldr (.) kt0 (reverse rest) + mss = replicate (nr - 1) (mixColumns . shiftRows . subBytes) + rest = zipWith (.) kts (mss ++ [shiftRows . subBytes ]) + + +aesDecrypt :: Int -- ^ nr + -> Int -- ^ nk + -> [Octet] -- ^ key + -> [Octet] -- ^ enciphered msg + -> [Octet] -- ^ deciphered msg +aesDecrypt nr nk key + [i00, i10, i20, i30, + i01, i11, i21, i31, + i02, i12, i22, i32, + i03, i13, i23, i33] = + [fo o00, fo o10, fo o20, fo o30, + fo o01, fo o11, fo o21, fo o31, + fo o02, fo o12, fo o22, fo o32, + fo o03, fo o13, fo o23, fo o33] + where State (o00, o01, o02, o03) + (o10, o11, o12, o13) + (o20, o21, o22, o23) + (o30, o31, o32, o33) = transform ( + State(fi i00, fi i01, fi i02, fi i03) + (fi i10, fi i11, fi i12, fi i13) + (fi i20, fi i21, fi i22, fi i23) + (fi i30, fi i31, fi i32, fi i33)) + fi = (fromIntegral :: Octet -> Word32) + fo = (fromIntegral :: Word32 -> Octet) + (kt0:kts) = reverse (genAddRoundKey (generateKeys nr nk key)) + transform = foldr (.) kt0 (reverse rest) + ssm = replicate (nr - 1) + (subBytesRev . shiftRowsRev . mixColumnsRev) + rest = zipWith (.) kts ([subBytesRev . shiftRowsRev] ++ ssm) + + + +data State = State !(Word32, Word32, Word32, Word32) + !(Word32, Word32, Word32, Word32) + !(Word32, Word32, Word32, Word32) + !(Word32, Word32, Word32, Word32) + +sbox :: Word32 -> Word32 +sboxRev :: Word32 -> Word32 + +sbox 0x00 = 0x63 +sbox 0x01 = 0x7C +sbox 0x02 = 0x77 +sbox 0x03 = 0x7B +sbox 0x04 = 0xF2 +sbox 0x05 = 0x6B +sbox 0x06 = 0x6F +sbox 0x07 = 0xC5 + +sbox 0x08 = 0x30 +sbox 0x09 = 0x01 +sbox 0x0a = 0x67 +sbox 0x0b = 0x2B +sbox 0x0c = 0xFE +sbox 0x0d = 0xD7 +sbox 0x0e = 0xAB +sbox 0x0f = 0x76 + +sbox 0x10 = 0xCA +sbox 0x11 = 0x82 +sbox 0x12 = 0xC9 +sbox 0x13 = 0x7D +sbox 0x14 = 0xFA +sbox 0x15 = 0x59 +sbox 0x16 = 0x47 +sbox 0x17 = 0xF0 + +sbox 0x18 = 0xAD +sbox 0x19 = 0xD4 +sbox 0x1a = 0xA2 +sbox 0x1b = 0xAF +sbox 0x1c = 0x9C +sbox 0x1d = 0xA4 +sbox 0x1e = 0x72 +sbox 0x1f = 0xC0 + +sbox 0x20 = 0xB7 +sbox 0x21 = 0xFD +sbox 0x22 = 0x93 +sbox 0x23 = 0x26 +sbox 0x24 = 0x36 +sbox 0x25 = 0x3F +sbox 0x26 = 0xF7 +sbox 0x27 = 0xCC + +sbox 0x28 = 0x34 +sbox 0x29 = 0xA5 +sbox 0x2a = 0xE5 +sbox 0x2b = 0xF1 +sbox 0x2c = 0x71 +sbox 0x2d = 0xD8 +sbox 0x2e = 0x31 +sbox 0x2f = 0x15 + +sbox 0x30 = 0x04 +sbox 0x31 = 0xC7 +sbox 0x32 = 0x23 +sbox 0x33 = 0xC3 +sbox 0x34 = 0x18 +sbox 0x35 = 0x96 +sbox 0x36 = 0x05 +sbox 0x37 = 0x9A + +sbox 0x38 = 0x07 +sbox 0x39 = 0x12 +sbox 0x3a = 0x80 +sbox 0x3b = 0xE2 +sbox 0x3c = 0xEB +sbox 0x3d = 0x27 +sbox 0x3e = 0xB2 +sbox 0x3f = 0x75 + +sbox 0x40 = 0x09 +sbox 0x41 = 0x83 +sbox 0x42 = 0x2C +sbox 0x43 = 0x1A +sbox 0x44 = 0x1B +sbox 0x45 = 0x6E +sbox 0x46 = 0x5A +sbox 0x47 = 0xA0 + +sbox 0x48 = 0x52 +sbox 0x49 = 0x3B +sbox 0x4a = 0xD6 +sbox 0x4b = 0xB3 +sbox 0x4c = 0x29 +sbox 0x4d = 0xE3 +sbox 0x4e = 0x2F +sbox 0x4f = 0x84 + +sbox 0x50 = 0x53 +sbox 0x51 = 0xD1 +sbox 0x52 = 0x00 +sbox 0x53 = 0xED +sbox 0x54 = 0x20 +sbox 0x55 = 0xFC +sbox 0x56 = 0xB1 +sbox 0x57 = 0x5B + +sbox 0x58 = 0x6A +sbox 0x59 = 0xCB +sbox 0x5a = 0xBE +sbox 0x5b = 0x39 +sbox 0x5c = 0x4A +sbox 0x5d = 0x4C +sbox 0x5e = 0x58 +sbox 0x5f = 0xCF + +sbox 0x60 = 0xD0 +sbox 0x61 = 0xEF +sbox 0x62 = 0xAA +sbox 0x63 = 0xFB +sbox 0x64 = 0x43 +sbox 0x65 = 0x4D +sbox 0x66 = 0x33 +sbox 0x67 = 0x85 + +sbox 0x68 = 0x45 +sbox 0x69 = 0xF9 +sbox 0x6a = 0x02 +sbox 0x6b = 0x7F +sbox 0x6c = 0x50 +sbox 0x6d = 0x3C +sbox 0x6e = 0x9F +sbox 0x6f = 0xA8 + +sbox 0x70 = 0x51 +sbox 0x71 = 0xA3 +sbox 0x72 = 0x40 +sbox 0x73 = 0x8F +sbox 0x74 = 0x92 +sbox 0x75 = 0x9D +sbox 0x76 = 0x38 +sbox 0x77 = 0xF5 + +sbox 0x78 = 0xBC +sbox 0x79 = 0xB6 +sbox 0x7a = 0xDA +sbox 0x7b = 0x21 +sbox 0x7c = 0x10 +sbox 0x7d = 0xFF +sbox 0x7e = 0xF3 +sbox 0x7f = 0xD2 + +sbox 0x80 = 0xCD +sbox 0x81 = 0x0C +sbox 0x82 = 0x13 +sbox 0x83 = 0xEC +sbox 0x84 = 0x5F +sbox 0x85 = 0x97 +sbox 0x86 = 0x44 +sbox 0x87 = 0x17 + +sbox 0x88 = 0xC4 +sbox 0x89 = 0xA7 +sbox 0x8a = 0x7E +sbox 0x8b = 0x3D +sbox 0x8c = 0x64 +sbox 0x8d = 0x5D +sbox 0x8e = 0x19 +sbox 0x8f = 0x73 + +sbox 0x90 = 0x60 +sbox 0x91 = 0x81 +sbox 0x92 = 0x4F +sbox 0x93 = 0xDC +sbox 0x94 = 0x22 +sbox 0x95 = 0x2A +sbox 0x96 = 0x90 +sbox 0x97 = 0x88 + +sbox 0x98 = 0x46 +sbox 0x99 = 0xEE +sbox 0x9a = 0xB8 +sbox 0x9b = 0x14 +sbox 0x9c = 0xDE +sbox 0x9d = 0x5E +sbox 0x9e = 0x0B +sbox 0x9f = 0xDB + +sbox 0xa0 = 0xE0 +sbox 0xa1 = 0x32 +sbox 0xa2 = 0x3A +sbox 0xa3 = 0x0A +sbox 0xa4 = 0x49 +sbox 0xa5 = 0x06 +sbox 0xa6 = 0x24 +sbox 0xa7 = 0x5C + +sbox 0xa8 = 0xC2 +sbox 0xa9 = 0xD3 +sbox 0xaa = 0xAC +sbox 0xab = 0x62 +sbox 0xac = 0x91 +sbox 0xad = 0x95 +sbox 0xae = 0xE4 +sbox 0xaf = 0x79 + +sbox 0xb0 = 0xE7 +sbox 0xb1 = 0xC8 +sbox 0xb2 = 0x37 +sbox 0xb3 = 0x6D +sbox 0xb4 = 0x8D +sbox 0xb5 = 0xD5 +sbox 0xb6 = 0x4E +sbox 0xb7 = 0xA9 + +sbox 0xb8 = 0x6C +sbox 0xb9 = 0x56 +sbox 0xba = 0xF4 +sbox 0xbb = 0xEA +sbox 0xbc = 0x65 +sbox 0xbd = 0x7A +sbox 0xbe = 0xAE +sbox 0xbf = 0x08 + +sbox 0xc0 = 0xBA +sbox 0xc1 = 0x78 +sbox 0xc2 = 0x25 +sbox 0xc3 = 0x2E +sbox 0xc4 = 0x1C +sbox 0xc5 = 0xA6 +sbox 0xc6 = 0xB4 +sbox 0xc7 = 0xC6 + +sbox 0xc8 = 0xE8 +sbox 0xc9 = 0xDD +sbox 0xca = 0x74 +sbox 0xcb = 0x1F +sbox 0xcc = 0x4B +sbox 0xcd = 0xBD +sbox 0xce = 0x8B +sbox 0xcf = 0x8A + +sbox 0xd0 = 0x70 +sbox 0xd1 = 0x3E +sbox 0xd2 = 0xB5 +sbox 0xd3 = 0x66 +sbox 0xd4 = 0x48 +sbox 0xd5 = 0x03 +sbox 0xd6 = 0xF6 +sbox 0xd7 = 0x0E + +sbox 0xd8 = 0x61 +sbox 0xd9 = 0x35 +sbox 0xda = 0x57 +sbox 0xdb = 0xB9 +sbox 0xdc = 0x86 +sbox 0xdd = 0xC1 +sbox 0xde = 0x1D +sbox 0xdf = 0x9E + +sbox 0xe0 = 0xE1 +sbox 0xe1 = 0xF8 +sbox 0xe2 = 0x98 +sbox 0xe3 = 0x11 +sbox 0xe4 = 0x69 +sbox 0xe5 = 0xD9 +sbox 0xe6 = 0x8E +sbox 0xe7 = 0x94 + +sbox 0xe8 = 0x9B +sbox 0xe9 = 0x1E +sbox 0xea = 0x87 +sbox 0xeb = 0xE9 +sbox 0xec = 0xCE +sbox 0xed = 0x55 +sbox 0xee = 0x28 +sbox 0xef = 0xDF + +sbox 0xf0 = 0x8C +sbox 0xf1 = 0xA1 +sbox 0xf2 = 0x89 +sbox 0xf3 = 0x0D +sbox 0xf4 = 0xBF +sbox 0xf5 = 0xE6 +sbox 0xf6 = 0x42 +sbox 0xf7 = 0x68 + +sbox 0xf8 = 0x41 +sbox 0xf9 = 0x99 +sbox 0xfa = 0x2D +sbox 0xfb = 0x0F +sbox 0xfc = 0xB0 +sbox 0xfd = 0x54 +sbox 0xfe = 0xBB +sbox 0xff = 0x16 + +{----} + +sboxRev 0x63 = 0x00 +sboxRev 0x7C = 0x01 +sboxRev 0x77 = 0x02 +sboxRev 0x7B = 0x03 +sboxRev 0xF2 = 0x04 +sboxRev 0x6B = 0x05 +sboxRev 0x6F = 0x06 +sboxRev 0xC5 = 0x07 + +sboxRev 0x30 = 0x08 +sboxRev 0x01 = 0x09 +sboxRev 0x67 = 0x0a +sboxRev 0x2B = 0x0b +sboxRev 0xFE = 0x0c +sboxRev 0xD7 = 0x0d +sboxRev 0xAB = 0x0e +sboxRev 0x76 = 0x0f + +sboxRev 0xCA = 0x10 +sboxRev 0x82 = 0x11 +sboxRev 0xC9 = 0x12 +sboxRev 0x7D = 0x13 +sboxRev 0xFA = 0x14 +sboxRev 0x59 = 0x15 +sboxRev 0x47 = 0x16 +sboxRev 0xF0 = 0x17 + +sboxRev 0xAD = 0x18 +sboxRev 0xD4 = 0x19 +sboxRev 0xA2 = 0x1a +sboxRev 0xAF = 0x1b +sboxRev 0x9C = 0x1c +sboxRev 0xA4 = 0x1d +sboxRev 0x72 = 0x1e +sboxRev 0xC0 = 0x1f + +sboxRev 0xB7 = 0x20 +sboxRev 0xFD = 0x21 +sboxRev 0x93 = 0x22 +sboxRev 0x26 = 0x23 +sboxRev 0x36 = 0x24 +sboxRev 0x3F = 0x25 +sboxRev 0xF7 = 0x26 +sboxRev 0xCC = 0x27 + +sboxRev 0x34 = 0x28 +sboxRev 0xA5 = 0x29 +sboxRev 0xE5 = 0x2a +sboxRev 0xF1 = 0x2b +sboxRev 0x71 = 0x2c +sboxRev 0xD8 = 0x2d +sboxRev 0x31 = 0x2e +sboxRev 0x15 = 0x2f + +sboxRev 0x04 = 0x30 +sboxRev 0xC7 = 0x31 +sboxRev 0x23 = 0x32 +sboxRev 0xC3 = 0x33 +sboxRev 0x18 = 0x34 +sboxRev 0x96 = 0x35 +sboxRev 0x05 = 0x36 +sboxRev 0x9A = 0x37 + +sboxRev 0x07 = 0x38 +sboxRev 0x12 = 0x39 +sboxRev 0x80 = 0x3a +sboxRev 0xE2 = 0x3b +sboxRev 0xEB = 0x3c +sboxRev 0x27 = 0x3d +sboxRev 0xB2 = 0x3e +sboxRev 0x75 = 0x3f + +sboxRev 0x09 = 0x40 +sboxRev 0x83 = 0x41 +sboxRev 0x2C = 0x42 +sboxRev 0x1A = 0x43 +sboxRev 0x1B = 0x44 +sboxRev 0x6E = 0x45 +sboxRev 0x5A = 0x46 +sboxRev 0xA0 = 0x47 + +sboxRev 0x52 = 0x48 +sboxRev 0x3B = 0x49 +sboxRev 0xD6 = 0x4a +sboxRev 0xB3 = 0x4b +sboxRev 0x29 = 0x4c +sboxRev 0xE3 = 0x4d +sboxRev 0x2F = 0x4e +sboxRev 0x84 = 0x4f + +sboxRev 0x53 = 0x50 +sboxRev 0xD1 = 0x51 +sboxRev 0x00 = 0x52 +sboxRev 0xED = 0x53 +sboxRev 0x20 = 0x54 +sboxRev 0xFC = 0x55 +sboxRev 0xB1 = 0x56 +sboxRev 0x5B = 0x57 + +sboxRev 0x6A = 0x58 +sboxRev 0xCB = 0x59 +sboxRev 0xBE = 0x5a +sboxRev 0x39 = 0x5b +sboxRev 0x4A = 0x5c +sboxRev 0x4C = 0x5d +sboxRev 0x58 = 0x5e +sboxRev 0xCF = 0x5f + +sboxRev 0xD0 = 0x60 +sboxRev 0xEF = 0x61 +sboxRev 0xAA = 0x62 +sboxRev 0xFB = 0x63 +sboxRev 0x43 = 0x64 +sboxRev 0x4D = 0x65 +sboxRev 0x33 = 0x66 +sboxRev 0x85 = 0x67 + +sboxRev 0x45 = 0x68 +sboxRev 0xF9 = 0x69 +sboxRev 0x02 = 0x6a +sboxRev 0x7F = 0x6b +sboxRev 0x50 = 0x6c +sboxRev 0x3C = 0x6d +sboxRev 0x9F = 0x6e +sboxRev 0xA8 = 0x6f + +sboxRev 0x51 = 0x70 +sboxRev 0xA3 = 0x71 +sboxRev 0x40 = 0x72 +sboxRev 0x8F = 0x73 +sboxRev 0x92 = 0x74 +sboxRev 0x9D = 0x75 +sboxRev 0x38 = 0x76 +sboxRev 0xF5 = 0x77 + +sboxRev 0xBC = 0x78 +sboxRev 0xB6 = 0x79 +sboxRev 0xDA = 0x7a +sboxRev 0x21 = 0x7b +sboxRev 0x10 = 0x7c +sboxRev 0xFF = 0x7d +sboxRev 0xF3 = 0x7e +sboxRev 0xD2 = 0x7f + +sboxRev 0xCD = 0x80 +sboxRev 0x0C = 0x81 +sboxRev 0x13 = 0x82 +sboxRev 0xEC = 0x83 +sboxRev 0x5F = 0x84 +sboxRev 0x97 = 0x85 +sboxRev 0x44 = 0x86 +sboxRev 0x17 = 0x87 + +sboxRev 0xC4 = 0x88 +sboxRev 0xA7 = 0x89 +sboxRev 0x7E = 0x8a +sboxRev 0x3D = 0x8b +sboxRev 0x64 = 0x8c +sboxRev 0x5D = 0x8d +sboxRev 0x19 = 0x8e +sboxRev 0x73 = 0x8f + +sboxRev 0x60 = 0x90 +sboxRev 0x81 = 0x91 +sboxRev 0x4F = 0x92 +sboxRev 0xDC = 0x93 +sboxRev 0x22 = 0x94 +sboxRev 0x2A = 0x95 +sboxRev 0x90 = 0x96 +sboxRev 0x88 = 0x97 + +sboxRev 0x46 = 0x98 +sboxRev 0xEE = 0x99 +sboxRev 0xB8 = 0x9a +sboxRev 0x14 = 0x9b +sboxRev 0xDE = 0x9c +sboxRev 0x5E = 0x9d +sboxRev 0x0B = 0x9e +sboxRev 0xDB = 0x9f + +sboxRev 0xE0 = 0xa0 +sboxRev 0x32 = 0xa1 +sboxRev 0x3A = 0xa2 +sboxRev 0x0A = 0xa3 +sboxRev 0x49 = 0xa4 +sboxRev 0x06 = 0xa5 +sboxRev 0x24 = 0xa6 +sboxRev 0x5C = 0xa7 + +sboxRev 0xC2 = 0xa8 +sboxRev 0xD3 = 0xa9 +sboxRev 0xAC = 0xaa +sboxRev 0x62 = 0xab +sboxRev 0x91 = 0xac +sboxRev 0x95 = 0xad +sboxRev 0xE4 = 0xae +sboxRev 0x79 = 0xaf + +sboxRev 0xE7 = 0xb0 +sboxRev 0xC8 = 0xb1 +sboxRev 0x37 = 0xb2 +sboxRev 0x6D = 0xb3 +sboxRev 0x8D = 0xb4 +sboxRev 0xD5 = 0xb5 +sboxRev 0x4E = 0xb6 +sboxRev 0xA9 = 0xb7 + +sboxRev 0x6C = 0xb8 +sboxRev 0x56 = 0xb9 +sboxRev 0xF4 = 0xba +sboxRev 0xEA = 0xbb +sboxRev 0x65 = 0xbc +sboxRev 0x7A = 0xbd +sboxRev 0xAE = 0xbe +sboxRev 0x08 = 0xbf + +sboxRev 0xBA = 0xc0 +sboxRev 0x78 = 0xc1 +sboxRev 0x25 = 0xc2 +sboxRev 0x2E = 0xc3 +sboxRev 0x1C = 0xc4 +sboxRev 0xA6 = 0xc5 +sboxRev 0xB4 = 0xc6 +sboxRev 0xC6 = 0xc7 + +sboxRev 0xE8 = 0xc8 +sboxRev 0xDD = 0xc9 +sboxRev 0x74 = 0xca +sboxRev 0x1F = 0xcb +sboxRev 0x4B = 0xcc +sboxRev 0xBD = 0xcd +sboxRev 0x8B = 0xce +sboxRev 0x8A = 0xcf + +sboxRev 0x70 = 0xd0 +sboxRev 0x3E = 0xd1 +sboxRev 0xB5 = 0xd2 +sboxRev 0x66 = 0xd3 +sboxRev 0x48 = 0xd4 +sboxRev 0x03 = 0xd5 +sboxRev 0xF6 = 0xd6 +sboxRev 0x0E = 0xd7 + +sboxRev 0x61 = 0xd8 +sboxRev 0x35 = 0xd9 +sboxRev 0x57 = 0xda +sboxRev 0xB9 = 0xdb +sboxRev 0x86 = 0xdc +sboxRev 0xC1 = 0xdd +sboxRev 0x1D = 0xde +sboxRev 0x9E = 0xdf + +sboxRev 0xE1 = 0xe0 +sboxRev 0xF8 = 0xe1 +sboxRev 0x98 = 0xe2 +sboxRev 0x11 = 0xe3 +sboxRev 0x69 = 0xe4 +sboxRev 0xD9 = 0xe5 +sboxRev 0x8E = 0xe6 +sboxRev 0x94 = 0xe7 + +sboxRev 0x9B = 0xe8 +sboxRev 0x1E = 0xe9 +sboxRev 0x87 = 0xea +sboxRev 0xE9 = 0xeb +sboxRev 0xCE = 0xec +sboxRev 0x55 = 0xed +sboxRev 0x28 = 0xee +sboxRev 0xDF = 0xef + +sboxRev 0x8C = 0xf0 +sboxRev 0xA1 = 0xf1 +sboxRev 0x89 = 0xf2 +sboxRev 0x0D = 0xf3 +sboxRev 0xBF = 0xf4 +sboxRev 0xE6 = 0xf5 +sboxRev 0x42 = 0xf6 +sboxRev 0x68 = 0xf7 + +sboxRev 0x41 = 0xf8 +sboxRev 0x99 = 0xf9 +sboxRev 0x2D = 0xfa +sboxRev 0x0F = 0xfb +sboxRev 0xB0 = 0xfc +sboxRev 0x54 = 0xfd +sboxRev 0xBB = 0xfe +sboxRev 0x16 = 0xff + +xtime :: Word32 -> Word32 +xtime x = b + where a = x `shiftL` 1 + b = if a .&. (0x0100) == 0 then a else a `xor` 0x11b + +xtimeX2 :: Word32 -> Word32 +--xtimeX2 = xtime . xtime +xtimeX2 x = c + where a = x `shiftL` 2 + b = if a .&. (0x0200) == 0 then a else a `xor` 0x236 + c = if b .&. (0x0100) == 0 then b else b `xor` 0x11b + +xtimeX3 :: Word32 -> Word32 +--xtimeX3 = xtime . xtime . xtime +xtimeX3 x = d + where a = x `shiftL` 3 + b = if a .&. (0x0400) == 0 then a else a `xor` 0x46c + c = if b .&. (0x0200) == 0 then b else b `xor` 0x236 + d = if c .&. (0x0100) == 0 then c else c `xor` 0x11b + +xtime03 :: Word32 -> Word32 +xtime03 x = x `xor` (xtime x) + +xtime0e :: Word32 -> Word32 +xtime0e x = xtime (x `xor` (xtime (x `xor` (xtime x)))) + +xtime09 :: Word32 -> Word32 +xtime09 x = x `xor` (xtimeX3 x) + +xtime0d :: Word32 -> Word32 +xtime0d x = x `xor` (xtimeX2 (x `xor` (xtime x))) + +xtime0b :: Word32 -> Word32 +xtime0b x = x `xor` (xtime (x `xor` (xtimeX2 x))) + +generateKey :: Int -> Int -> Word32 -> Word32 -> Word32 +generateKey nk i wIminus1 wIminusNk = + (temp' `xor` wIminusNk) + where temp' = + if (i `mod` nk) == 0 then (subword(rotword temp)) `xor` rcon + else if (nk > 6) && ((i `mod` nk) == 4) then subword temp + else temp + temp = wIminus1 + subword :: Word32 -> Word32 + subword w = (a `shiftL` 24) .|. (b `shiftL` 16) .|. + (c `shiftL` 8) .|. d + where a = sbox ((w `shiftR` 24) .&. 0xff) + b = sbox ((w `shiftR` 16) .&. 0xff) + c = sbox ((w `shiftR` 8) .&. 0xff) + d = sbox ( w .&. 0xff) + rotword :: Word32 -> Word32 + rotword w = w `rotateL` 8 + rcon :: Word32 + rcon = ((fromIntegral rconMSB)::Word32) `shiftL` 24 + rconMSB = (iterate xtime 0x01) !! ((i `div` nk) - 1) + +wordify :: [Octet] -> [Word32] +wordify [] = [] +wordify octets = firstWord:otherWords + where + (firstWord, otherOctets) = getWord32 octets + otherWords = wordify otherOctets + +generateKeys :: Int -> Int -> [Octet] -> [Word32] +generateKeys nr nk mainKey = + -- assert ((nk * 4) == length mainKey) $ + (take (4 * (nr + 1)) xs) + where + xs = (wordify mainKey) ++ (zipWith3 (generateKey nk) + (drop nk [0,1..]) + (drop (nk - 1) xs) + xs + ) + +subBytes :: State -> State +subBytes (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (sbox s00, sbox s01, sbox s02, sbox s03) + (sbox s10, sbox s11, sbox s12, sbox s13) + (sbox s20, sbox s21, sbox s22, sbox s23) + (sbox s30, sbox s31, sbox s32, sbox s33) + +subBytesRev :: State -> State +subBytesRev (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (sboxRev s00, sboxRev s01, sboxRev s02, sboxRev s03) + (sboxRev s10, sboxRev s11, sboxRev s12, sboxRev s13) + (sboxRev s20, sboxRev s21, sboxRev s22, sboxRev s23) + (sboxRev s30, sboxRev s31, sboxRev s32, sboxRev s33) + +shiftRows :: State -> State +shiftRows (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (s00, s01, s02, s03) + (s11, s12, s13, s10) + (s22, s23, s20, s21) + (s33, s30, s31, s32) + +shiftRowsRev :: State -> State +shiftRowsRev (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (s00, s01, s02, s03) + (s13, s10, s11, s12) + (s22, s23, s20, s21) + (s31, s32, s33, s30) + +mixColumn:: (Word32, Word32, Word32, Word32) -> (Word32, Word32, Word32, Word32) +mixColumn (s0,s1,s2,s3) = + ((xtime s0) `xor` (xtime03 s1) `xor` s2 `xor` s3 , + s0 `xor` (xtime s1) `xor` (xtime03 s2) `xor` s3 , + s0 `xor` s1 `xor` (xtime s2) `xor` (xtime03 s3), + (xtime03 s0) `xor` s1 `xor` s2 `xor` (xtime s3)) + +mixColumns :: State -> State +mixColumns (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (r00, r01, r02, r03) + (r10, r11, r12, r13) + (r20, r21, r22, r23) + (r30, r31, r32, r33) + where (r00, r10, r20, r30) = mixColumn (s00, s10, s20, s30) + (r01, r11, r21, r31) = mixColumn (s01, s11, s21, s31) + (r02, r12, r22, r32) = mixColumn (s02, s12, s22, s32) + (r03, r13, r23, r33) = mixColumn (s03, s13, s23, s33) + +mixColumnRev :: (Word32, Word32, Word32, Word32) + -> (Word32, Word32, Word32, Word32) +mixColumnRev (s0,s1,s2,s3) = + ((xtime0e s0) `xor` (xtime0b s1) `xor` (xtime0d s2) `xor` (xtime09 s3), + (xtime09 s0) `xor` (xtime0e s1) `xor` (xtime0b s2) `xor` (xtime0d s3), + (xtime0d s0) `xor` (xtime09 s1) `xor` (xtime0e s2) `xor` (xtime0b s3), + (xtime0b s0) `xor` (xtime0d s1) `xor` (xtime09 s2) `xor` (xtime0e s3)) + +mixColumnsRev :: State -> State +mixColumnsRev (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (r00, r01, r02, r03) + (r10, r11, r12, r13) + (r20, r21, r22, r23) + (r30, r31, r32, r33) + where (r00, r10, r20, r30) = mixColumnRev (s00, s10, s20, s30) + (r01, r11, r21, r31) = mixColumnRev (s01, s11, s21, s31) + (r02, r12, r22, r32) = mixColumnRev (s02, s12, s22, s32) + (r03, r13, r23, r33) = mixColumnRev (s03, s13, s23, s33) + +addRoundKey :: State -> State -> State +addRoundKey (State (k00, k01, k02, k03) + (k10, k11, k12, k13) + (k20, k21, k22, k23) + (k30, k31, k32, k33)) + (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (s00 `xor` k00, s01 `xor` k01, s02 `xor` k02, s03 `xor` k03) + (s10 `xor` k10, s11 `xor` k11, s12 `xor` k12, s13 `xor` k13) + (s20 `xor` k20, s21 `xor` k21, s22 `xor` k22, s23 `xor` k23) + (s30 `xor` k30, s31 `xor` k31, s32 `xor` k32, s33 `xor` k33) + +genAddRoundKey :: [Word32] -> [State -> State] +genAddRoundKey [] = [] +genAddRoundKey (a:b:c:d:ks) = (addRoundKey k):(genAddRoundKey ks) + where k = State (fromIntegral s00, fromIntegral s01, + fromIntegral s02, fromIntegral s03) + (fromIntegral s10, fromIntegral s11, + fromIntegral s12, fromIntegral s13) + (fromIntegral s20, fromIntegral s21, + fromIntegral s22, fromIntegral s23) + (fromIntegral s30, fromIntegral s31, + fromIntegral s32, fromIntegral s33) + [s00, s10, s20, s30] = putWord32 a + [s01, s11, s21, s31] = putWord32 b + [s02, s12, s22, s32] = putWord32 c + [s03, s13, s23, s33] = putWord32 d + +getWord32 :: [Octet] -> (Word32, [Octet]) +getWord32 (a:b:c:d:xs) = (x, xs) + where + x = ((fromIntegral a) `shiftL` 24) .|. + ((fromIntegral b) `shiftL` 16) .|. + ((fromIntegral c) `shiftL` 8) .|. + ((fromIntegral d) ) + +putWord32 :: Word32 -> [Octet] +--a bit slower putWord32 x = map fromIntegral [a,b,c,d] +putWord32 x = [fromIntegral a, fromIntegral b, fromIntegral c, fromIntegral d] + where + a = (x `shiftR` 24) + b = (x `shiftR` 16) .&. 255 + c = (x `shiftR` 8) .&. 255 + d = (x ) .&. 255 + +{- +testGenerateKeys128 :: Test +testGenerateKeys128 = + let key = [0x2b, 0x7e, 0x15, 0x16, + 0x28, 0xae, 0xd2, 0xa6, + 0xab, 0xf7, 0x15, 0x88, + 0x09, 0xcf, 0x4f, 0x3c] + expected = [0x2b7e1516, 0x28aed2a6, 0xabf71588, 0x09cf4f3c, + 0xa0fafe17, 0x88542cb1, 0x23a33939, 0x2a6c7605, + 0xf2c295f2, 0x7a96b943, 0x5935807a, 0x7359f67f, + 0x3d80477d, 0x4716fe3e, 0x1e237e44, 0x6d7a883b, + 0xef44a541, 0xa8525b7f, 0xb671253b, 0xdb0bad00, + 0xd4d1c6f8, 0x7c839d87, 0xcaf2b8bc, 0x11f915bc, + 0x6d88a37a, 0x110b3efd, 0xdbf98641, 0xca0093fd, + 0x4e54f70e, 0x5f5fc9f3, 0x84a64fb2, 0x4ea6dc4f, + 0xead27321, 0xb58dbad2, 0x312bf560, 0x7f8d292f, + 0xac7766f3, 0x19fadc21, 0x28d12941, 0x575c006e, + 0xd014f9a8, 0xc9ee2589, 0xe13f0cc8, 0xb6630ca6 + ] + in TestCase (do + assertEqual "" expected (generateKeys 10 4 key) + ) + + +testGenerateKeys192 :: Test +testGenerateKeys192 = + let key = [0x8e, 0x73, 0xb0, 0xf7, + 0xda, 0x0e, 0x64, 0x52, + 0xc8, 0x10, 0xf3, 0x2b, + 0x80, 0x90, 0x79, 0xe5, + 0x62, 0xf8, 0xea, 0xd2, + 0x52, 0x2c, 0x6b, 0x7b] + expected = [0x8e73b0f7, 0xda0e6452, 0xc810f32b, 0x809079e5, + 0x62f8ead2, 0x522c6b7b, 0xfe0c91f7, 0x2402f5a5, + 0xec12068e, 0x6c827f6b, 0x0e7a95b9, 0x5c56fec2, + 0x4db7b4bd, 0x69b54118, 0x85a74796, 0xe92538fd, + 0xe75fad44, 0xbb095386, 0x485af057, 0x21efb14f + ] + in TestCase (do + assertEqual "" expected + (take (length expected) (generateKeys 12 6 key)) + ) + +testGenerateKeys256 :: Test +testGenerateKeys256 = + let key = [0x60, 0x3d, 0xeb, 0x10, + 0x15, 0xca, 0x71, 0xbe, + 0x2b, 0x73, 0xae, 0xf0, + 0x85, 0x7d, 0x77, 0x81, + 0x1f, 0x35, 0x2c, 0x07, + 0x3b, 0x61, 0x08, 0xd7, + 0x2d, 0x98, 0x10, 0xa3, + 0x09, 0x14, 0xdf, 0xf4] + expected = [0x603deb10, 0x15ca71be, 0x2b73aef0, 0x857d7781, + 0x1f352c07, 0x3b6108d7, 0x2d9810a3, 0x0914dff4, + 0x9ba35411, 0x8e6925af, 0xa51a8b5f, 0x2067fcde, + 0xa8b09c1a, 0x93d194cd, 0xbe49846e, 0xb75d5b9a, + 0xd59aecb8, 0x5bf3c917, 0xfee94248, 0xde8ebe96 + ] + in TestCase (do + assertEqual "" expected + (take (length expected) (generateKeys 14 8 key)) + ) + +testAes128 :: Test +testAes128 = + let key = [0x2b, 0x7e, 0x15, 0x16, + 0x28, 0xae, 0xd2, 0xa6, + 0xab, 0xf7, 0x15, 0x88, + 0x09, 0xcf, 0x4f, 0x3c] + input = [0x32, 0x43, 0xf6, 0xa8, + 0x88, 0x5a, 0x30, 0x8d, + 0x31, 0x31, 0x98, 0xa2, + 0xe0, 0x37, 0x07, 0x34] + output = [0x39, 0x25, 0x84, 0x1d, + 0x02, 0xdc, 0x09, 0xfb, + 0xdc, 0x11, 0x85, 0x97, + 0x19, 0x6a, 0x0b, 0x32] + in TestCase (do + assertEqual "encrypt test" output (aes128Encrypt key input) + assertEqual "encrypt/decrypt test" input + (aes128Decrypt key (aes128Encrypt key input)) + ) + +testAesRandom :: Test +testAesRandom = + TestCase (do + key128 <- getRandomOctets 16 + key192 <- getRandomOctets 24 + key256 <- getRandomOctets 32 + msg <- getRandomOctets 16 + assertEqual "aes128" msg + (aes128Decrypt key128 (aes128Encrypt key128 msg)) + assertEqual "aes192" msg + (aes192Decrypt key192 (aes192Encrypt key192 msg)) + assertEqual "aes256" msg + (aes256Decrypt key256 (aes256Encrypt key256 msg)) + ) + +-- | HUnit tests +tests :: Test +tests = TestList [ + TestLabel "testGenerateKeys128" testGenerateKeys128, + TestLabel "testGenerateKeys192" testGenerateKeys192, + TestLabel "testGenerateKeys256" testGenerateKeys256, + TestLabel "testAes128" testAes128, + TestLabel "testAesRandom" testAesRandom + ] +-} + diff --git a/src/Codec/Encryption/Blowfish.hs b/src/Codec/Encryption/Blowfish.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/Blowfish.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Coded.Encryption.Blowfish +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : non-portable +-- +-- Takes the Blowfish module supplied by Doug Hoyte and wraps it so it can +-- used with the standard modes. +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.Blowfish + ( + -- * Function Types + encrypt, + decrypt + ) where + +import Data.Bits +import Data.Word +import Data.Char +import Codec.Utils +import Codec.Encryption.BlowfishAux + +-- * Basic Blowfish Encryption + +-- | Basic Blowfish encryption which takes a key and a block of plaintext +-- and returns the encrypted block of ciphertext according to the standard. +-- Typical keys are Word8, Word16, Word32, Word64, Word128. See +-- . + +encrypt :: (Integral a) => a -> Word64 -> Word64 +encrypt k p = mergeWord32 (lo,hi) where + lo = head e + hi = head $ tail e + e = bfEnc (bfMakeKey (map (chr . fromIntegral) (toOctets 256 k))) [lo',hi'] + (lo',hi') = (splitZord64 p) + +-- | Basic Blowfish decryption which takes a key and a block of ciphertext +-- and returns the decrypted block of plaintext. + +decrypt :: (Integral a) => a -> Word64 -> Word64 +decrypt k p = mergeWord32 (lo,hi) where + lo = head d + hi = head $ tail d + d = bfDec (bfMakeKey (map (chr . fromIntegral) (toOctets 256 k))) [lo',hi'] + (lo',hi') = splitZord64 p + +splitZord64 :: Word64 -> (Word32,Word32) +splitZord64 x = (fromIntegral (shiftR (x .&. 0xffffffff00000000) 32), + fromIntegral (x .&. 0x00000000ffffffff)) + +mergeWord32 :: (Word32,Word32) -> Word64 +mergeWord32 (lo,hi) = shift (fromIntegral lo) 32 + fromIntegral hi diff --git a/src/Codec/Encryption/BlowfishAux.hs b/src/Codec/Encryption/BlowfishAux.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/BlowfishAux.hs @@ -0,0 +1,282 @@ +-- BlowfishAux.hs (C) 2002 HardCore SoftWare, Doug Hoyte +-- +-- Doug has kindly agreed to release this under BSD. +-- +-- Haskell implementation of Bruce Schneier's blowfish encryption algorithm. +-- This implementation uses 16 rounds and produces the same ciphertext as +-- the OpenBSD and Paul Kocher 16-round implementations. +-- +-- The function bfMakeKey should be passed a list of Chars. These represent +-- the key. It will return a datatype called "BF", which contains the +-- initialized key information. +-- +-- The function bfEnc is passed a BF datatype representing the key and a +-- list of 2 Word32s (the plaintext). It returns a list of 2 Word32s +-- (the ciphertext). +-- +-- The function bfDec is passed a BF datatype representing the key and a list +-- of 2 Word32s (the ciphertext) and a BF datatype representing the key. It +-- returns a list of 2 Word32s (the plaintext). + +module Codec.Encryption.BlowfishAux + (bfMakeKey, + bfEnc, + bfDec) where + +import Data.Array +import Data.Bits +import Data.Word +import Data.Char + +type Pbox = Array Word32 Word32 +type Sbox = Array Word32 Word32 + +data BF = BF Pbox Sbox Sbox Sbox Sbox + + + +bfEnc :: BF -> [Word32] -> [Word32] +bfEnc a b = aux a b 0 + where + aux :: BF -> [Word32] -> Word32 -> [Word32] + aux bs@(BF p s0 s1 s2 s3) (l:r:[]) 16 = (r `xor` p!17):(l `xor` p!16):[] + aux bs@(BF p s0 s1 s2 s3) (l:r:[]) i = aux bs (newr:newl:[]) (i+1) + where newl = l `xor` (p ! i) + newr = r `xor` (f newl) + f :: Word32 -> Word32 + f t = ((s0!a + s1!b) `xor` (s2 ! c)) + (s3 ! d) + where a = (t `shiftR` 24) + b = ((t `shiftL` 8) `shiftR` 24) + c = ((t `shiftL` 16) `shiftR` 24) + d = ((t `shiftL` 24) `shiftR` 24) + + +bfDec :: BF -> [Word32] -> [Word32] +bfDec (BF p s0 s1 s2 s3) a = bfEnc (BF (revP p) s0 s1 s2 s3) a + where revP :: Pbox -> Pbox + revP x = x//[(i, x ! (17-i)) | i <- [0..17]] + + +bfMakeKey :: [Char] -> BF +bfMakeKey [] = procKey [0,0] (BF iPbox iSbox0 iSbox1 iSbox2 iSbox3) 0 +bfMakeKey k = procKey [0,0] (BF (string2Pbox k) iSbox0 iSbox1 iSbox2 iSbox3) 0 + + +string2Pbox :: [Char] -> Pbox +string2Pbox k = array (0,17) [(fromIntegral i,xtext!!i) | i <- [0..17]] + where xtext = zipWith (xor) + (compress4 (doShift (makeTo72 (charsToWord32s k) 0) 0)) + [iPbox ! (fromIntegral i) | i <- [0..17]] + charsToWord32s [] = [] + charsToWord32s (k:ks) = (fromIntegral $ fromEnum k) : charsToWord32s ks + makeTo72 k 72 = [] + makeTo72 k i = k!!(i `mod` (length k)) : makeTo72 k (i+1) + doShift [] i = [] + doShift (w:ws) i = w `shiftL` (8*(3 - (i `mod` 4))) : doShift ws (i+1) + compress4 [] = [] + compress4 (a:b:c:d:etc) = (a .|. b .|. c .|. d) : compress4 etc + + +procKey :: [Word32] -> BF -> Word32 -> BF +procKey (l:r:[]) tpbf@(BF p s0 s1 s2 s3) 1042 = tpbf +procKey (l:r:[]) tpbf@(BF p s0 s1 s2 s3) i = procKey [nl,nr] (newbf i) (i+2) + where [nl,nr] = bfEnc tpbf [l,r] + newbf x | x < 18 = (BF (p//[(x,nl),(x+1,nr)]) s0 s1 s2 s3) + | x < 274 = (BF p (s0//[(x-18,nl),(x-17,nr)]) s1 s2 s3) + | x < 530 = (BF p s0 (s1//[(x-274,nl),(x-273,nr)]) s2 s3) + | x < 786 = (BF p s0 s1 (s2//[(x-530,nl),(x-529,nr)]) s3) + | x < 1042 = (BF p s0 s1 s2 (s3//[(x-786,nl),(x-785,nr)])) + + + +---------- INITIAL S AND P BOXES ARE THE HEXADECIMAL DIGITS OF PI ------------ + +iPbox :: Pbox +iPbox = array (0,17) (zip [0..17] + [0x243f6a88, 0x85a308d3, 0x13198a2e, 0x03707344, 0xa4093822, 0x299f31d0, + 0x082efa98, 0xec4e6c89, 0x452821e6, 0x38d01377, 0xbe5466cf, 0x34e90c6c, + 0xc0ac29b7, 0xc97c50dd, 0x3f84d5b5, 0xb5470917, 0x9216d5d9, 0x8979fb1b]) + +iSbox0 :: Sbox +iSbox0 = array (0,255) (zip [0..255] + [0xd1310ba6, 0x98dfb5ac, 0x2ffd72db, 0xd01adfb7, 0xb8e1afed, 0x6a267e96, + 0xba7c9045, 0xf12c7f99, 0x24a19947, 0xb3916cf7, 0x0801f2e2, 0x858efc16, + 0x636920d8, 0x71574e69, 0xa458fea3, 0xf4933d7e, 0x0d95748f, 0x728eb658, + 0x718bcd58, 0x82154aee, 0x7b54a41d, 0xc25a59b5, 0x9c30d539, 0x2af26013, + 0xc5d1b023, 0x286085f0, 0xca417918, 0xb8db38ef, 0x8e79dcb0, 0x603a180e, + 0x6c9e0e8b, 0xb01e8a3e, 0xd71577c1, 0xbd314b27, 0x78af2fda, 0x55605c60, + 0xe65525f3, 0xaa55ab94, 0x57489862, 0x63e81440, 0x55ca396a, 0x2aab10b6, + 0xb4cc5c34, 0x1141e8ce, 0xa15486af, 0x7c72e993, 0xb3ee1411, 0x636fbc2a, + 0x2ba9c55d, 0x741831f6, 0xce5c3e16, 0x9b87931e, 0xafd6ba33, 0x6c24cf5c, + 0x7a325381, 0x28958677, 0x3b8f4898, 0x6b4bb9af, 0xc4bfe81b, 0x66282193, + 0x61d809cc, 0xfb21a991, 0x487cac60, 0x5dec8032, 0xef845d5d, 0xe98575b1, + 0xdc262302, 0xeb651b88, 0x23893e81, 0xd396acc5, 0x0f6d6ff3, 0x83f44239, + 0x2e0b4482, 0xa4842004, 0x69c8f04a, 0x9e1f9b5e, 0x21c66842, 0xf6e96c9a, + 0x670c9c61, 0xabd388f0, 0x6a51a0d2, 0xd8542f68, 0x960fa728, 0xab5133a3, + 0x6eef0b6c, 0x137a3be4, 0xba3bf050, 0x7efb2a98, 0xa1f1651d, 0x39af0176, + 0x66ca593e, 0x82430e88, 0x8cee8619, 0x456f9fb4, 0x7d84a5c3, 0x3b8b5ebe, + 0xe06f75d8, 0x85c12073, 0x401a449f, 0x56c16aa6, 0x4ed3aa62, 0x363f7706, + 0x1bfedf72, 0x429b023d, 0x37d0d724, 0xd00a1248, 0xdb0fead3, 0x49f1c09b, + 0x075372c9, 0x80991b7b, 0x25d479d8, 0xf6e8def7, 0xe3fe501a, 0xb6794c3b, + 0x976ce0bd, 0x04c006ba, 0xc1a94fb6, 0x409f60c4, 0x5e5c9ec2, 0x196a2463, + 0x68fb6faf, 0x3e6c53b5, 0x1339b2eb, 0x3b52ec6f, 0x6dfc511f, 0x9b30952c, + 0xcc814544, 0xaf5ebd09, 0xbee3d004, 0xde334afd, 0x660f2807, 0x192e4bb3, + 0xc0cba857, 0x45c8740f, 0xd20b5f39, 0xb9d3fbdb, 0x5579c0bd, 0x1a60320a, + 0xd6a100c6, 0x402c7279, 0x679f25fe, 0xfb1fa3cc, 0x8ea5e9f8, 0xdb3222f8, + 0x3c7516df, 0xfd616b15, 0x2f501ec8, 0xad0552ab, 0x323db5fa, 0xfd238760, + 0x53317b48, 0x3e00df82, 0x9e5c57bb, 0xca6f8ca0, 0x1a87562e, 0xdf1769db, + 0xd542a8f6, 0x287effc3, 0xac6732c6, 0x8c4f5573, 0x695b27b0, 0xbbca58c8, + 0xe1ffa35d, 0xb8f011a0, 0x10fa3d98, 0xfd2183b8, 0x4afcb56c, 0x2dd1d35b, + 0x9a53e479, 0xb6f84565, 0xd28e49bc, 0x4bfb9790, 0xe1ddf2da, 0xa4cb7e33, + 0x62fb1341, 0xcee4c6e8, 0xef20cada, 0x36774c01, 0xd07e9efe, 0x2bf11fb4, + 0x95dbda4d, 0xae909198, 0xeaad8e71, 0x6b93d5a0, 0xd08ed1d0, 0xafc725e0, + 0x8e3c5b2f, 0x8e7594b7, 0x8ff6e2fb, 0xf2122b64, 0x8888b812, 0x900df01c, + 0x4fad5ea0, 0x688fc31c, 0xd1cff191, 0xb3a8c1ad, 0x2f2f2218, 0xbe0e1777, + 0xea752dfe, 0x8b021fa1, 0xe5a0cc0f, 0xb56f74e8, 0x18acf3d6, 0xce89e299, + 0xb4a84fe0, 0xfd13e0b7, 0x7cc43b81, 0xd2ada8d9, 0x165fa266, 0x80957705, + 0x93cc7314, 0x211a1477, 0xe6ad2065, 0x77b5fa86, 0xc75442f5, 0xfb9d35cf, + 0xebcdaf0c, 0x7b3e89a0, 0xd6411bd3, 0xae1e7e49, 0x00250e2d, 0x2071b35e, + 0x226800bb, 0x57b8e0af, 0x2464369b, 0xf009b91e, 0x5563911d, 0x59dfa6aa, + 0x78c14389, 0xd95a537f, 0x207d5ba2, 0x02e5b9c5, 0x83260376, 0x6295cfa9, + 0x11c81968, 0x4e734a41, 0xb3472dca, 0x7b14a94a, 0x1b510052, 0x9a532915, + 0xd60f573f, 0xbc9bc6e4, 0x2b60a476, 0x81e67400, 0x08ba6fb5, 0x571be91f, + 0xf296ec6b, 0x2a0dd915, 0xb6636521, 0xe7b9f9b6, 0xff34052e, 0xc5855664, + 0x53b02d5d, 0xa99f8fa1, 0x08ba4799, 0x6e85076a]) + +iSbox1 :: Sbox +iSbox1 = array (0,255) (zip [0..255] + [0x4b7a70e9, 0xb5b32944, 0xdb75092e, 0xc4192623, 0xad6ea6b0, 0x49a7df7d, + 0x9cee60b8, 0x8fedb266, 0xecaa8c71, 0x699a17ff, 0x5664526c, 0xc2b19ee1, + 0x193602a5, 0x75094c29, 0xa0591340, 0xe4183a3e, 0x3f54989a, 0x5b429d65, + 0x6b8fe4d6, 0x99f73fd6, 0xa1d29c07, 0xefe830f5, 0x4d2d38e6, 0xf0255dc1, + 0x4cdd2086, 0x8470eb26, 0x6382e9c6, 0x021ecc5e, 0x09686b3f, 0x3ebaefc9, + 0x3c971814, 0x6b6a70a1, 0x687f3584, 0x52a0e286, 0xb79c5305, 0xaa500737, + 0x3e07841c, 0x7fdeae5c, 0x8e7d44ec, 0x5716f2b8, 0xb03ada37, 0xf0500c0d, + 0xf01c1f04, 0x0200b3ff, 0xae0cf51a, 0x3cb574b2, 0x25837a58, 0xdc0921bd, + 0xd19113f9, 0x7ca92ff6, 0x94324773, 0x22f54701, 0x3ae5e581, 0x37c2dadc, + 0xc8b57634, 0x9af3dda7, 0xa9446146, 0x0fd0030e, 0xecc8c73e, 0xa4751e41, + 0xe238cd99, 0x3bea0e2f, 0x3280bba1, 0x183eb331, 0x4e548b38, 0x4f6db908, + 0x6f420d03, 0xf60a04bf, 0x2cb81290, 0x24977c79, 0x5679b072, 0xbcaf89af, + 0xde9a771f, 0xd9930810, 0xb38bae12, 0xdccf3f2e, 0x5512721f, 0x2e6b7124, + 0x501adde6, 0x9f84cd87, 0x7a584718, 0x7408da17, 0xbc9f9abc, 0xe94b7d8c, + 0xec7aec3a, 0xdb851dfa, 0x63094366, 0xc464c3d2, 0xef1c1847, 0x3215d908, + 0xdd433b37, 0x24c2ba16, 0x12a14d43, 0x2a65c451, 0x50940002, 0x133ae4dd, + 0x71dff89e, 0x10314e55, 0x81ac77d6, 0x5f11199b, 0x043556f1, 0xd7a3c76b, + 0x3c11183b, 0x5924a509, 0xf28fe6ed, 0x97f1fbfa, 0x9ebabf2c, 0x1e153c6e, + 0x86e34570, 0xeae96fb1, 0x860e5e0a, 0x5a3e2ab3, 0x771fe71c, 0x4e3d06fa, + 0x2965dcb9, 0x99e71d0f, 0x803e89d6, 0x5266c825, 0x2e4cc978, 0x9c10b36a, + 0xc6150eba, 0x94e2ea78, 0xa5fc3c53, 0x1e0a2df4, 0xf2f74ea7, 0x361d2b3d, + 0x1939260f, 0x19c27960, 0x5223a708, 0xf71312b6, 0xebadfe6e, 0xeac31f66, + 0xe3bc4595, 0xa67bc883, 0xb17f37d1, 0x018cff28, 0xc332ddef, 0xbe6c5aa5, + 0x65582185, 0x68ab9802, 0xeecea50f, 0xdb2f953b, 0x2aef7dad, 0x5b6e2f84, + 0x1521b628, 0x29076170, 0xecdd4775, 0x619f1510, 0x13cca830, 0xeb61bd96, + 0x0334fe1e, 0xaa0363cf, 0xb5735c90, 0x4c70a239, 0xd59e9e0b, 0xcbaade14, + 0xeecc86bc, 0x60622ca7, 0x9cab5cab, 0xb2f3846e, 0x648b1eaf, 0x19bdf0ca, + 0xa02369b9, 0x655abb50, 0x40685a32, 0x3c2ab4b3, 0x319ee9d5, 0xc021b8f7, + 0x9b540b19, 0x875fa099, 0x95f7997e, 0x623d7da8, 0xf837889a, 0x97e32d77, + 0x11ed935f, 0x16681281, 0x0e358829, 0xc7e61fd6, 0x96dedfa1, 0x7858ba99, + 0x57f584a5, 0x1b227263, 0x9b83c3ff, 0x1ac24696, 0xcdb30aeb, 0x532e3054, + 0x8fd948e4, 0x6dbc3128, 0x58ebf2ef, 0x34c6ffea, 0xfe28ed61, 0xee7c3c73, + 0x5d4a14d9, 0xe864b7e3, 0x42105d14, 0x203e13e0, 0x45eee2b6, 0xa3aaabea, + 0xdb6c4f15, 0xfacb4fd0, 0xc742f442, 0xef6abbb5, 0x654f3b1d, 0x41cd2105, + 0xd81e799e, 0x86854dc7, 0xe44b476a, 0x3d816250, 0xcf62a1f2, 0x5b8d2646, + 0xfc8883a0, 0xc1c7b6a3, 0x7f1524c3, 0x69cb7492, 0x47848a0b, 0x5692b285, + 0x095bbf00, 0xad19489d, 0x1462b174, 0x23820e00, 0x58428d2a, 0x0c55f5ea, + 0x1dadf43e, 0x233f7061, 0x3372f092, 0x8d937e41, 0xd65fecf1, 0x6c223bdb, + 0x7cde3759, 0xcbee7460, 0x4085f2a7, 0xce77326e, 0xa6078084, 0x19f8509e, + 0xe8efd855, 0x61d99735, 0xa969a7aa, 0xc50c06c2, 0x5a04abfc, 0x800bcadc, + 0x9e447a2e, 0xc3453484, 0xfdd56705, 0x0e1e9ec9, 0xdb73dbd3, 0x105588cd, + 0x675fda79, 0xe3674340, 0xc5c43465, 0x713e38d8, 0x3d28f89e, 0xf16dff20, + 0x153e21e7, 0x8fb03d4a, 0xe6e39f2b, 0xdb83adf7]) + +iSbox2 :: Sbox +iSbox2 = array (0,255) (zip [0..255] + [0xe93d5a68, 0x948140f7, 0xf64c261c, 0x94692934, 0x411520f7, 0x7602d4f7, + 0xbcf46b2e, 0xd4a20068, 0xd4082471, 0x3320f46a, 0x43b7d4b7, 0x500061af, + 0x1e39f62e, 0x97244546, 0x14214f74, 0xbf8b8840, 0x4d95fc1d, 0x96b591af, + 0x70f4ddd3, 0x66a02f45, 0xbfbc09ec, 0x03bd9785, 0x7fac6dd0, 0x31cb8504, + 0x96eb27b3, 0x55fd3941, 0xda2547e6, 0xabca0a9a, 0x28507825, 0x530429f4, + 0x0a2c86da, 0xe9b66dfb, 0x68dc1462, 0xd7486900, 0x680ec0a4, 0x27a18dee, + 0x4f3ffea2, 0xe887ad8c, 0xb58ce006, 0x7af4d6b6, 0xaace1e7c, 0xd3375fec, + 0xce78a399, 0x406b2a42, 0x20fe9e35, 0xd9f385b9, 0xee39d7ab, 0x3b124e8b, + 0x1dc9faf7, 0x4b6d1856, 0x26a36631, 0xeae397b2, 0x3a6efa74, 0xdd5b4332, + 0x6841e7f7, 0xca7820fb, 0xfb0af54e, 0xd8feb397, 0x454056ac, 0xba489527, + 0x55533a3a, 0x20838d87, 0xfe6ba9b7, 0xd096954b, 0x55a867bc, 0xa1159a58, + 0xcca92963, 0x99e1db33, 0xa62a4a56, 0x3f3125f9, 0x5ef47e1c, 0x9029317c, + 0xfdf8e802, 0x04272f70, 0x80bb155c, 0x05282ce3, 0x95c11548, 0xe4c66d22, + 0x48c1133f, 0xc70f86dc, 0x07f9c9ee, 0x41041f0f, 0x404779a4, 0x5d886e17, + 0x325f51eb, 0xd59bc0d1, 0xf2bcc18f, 0x41113564, 0x257b7834, 0x602a9c60, + 0xdff8e8a3, 0x1f636c1b, 0x0e12b4c2, 0x02e1329e, 0xaf664fd1, 0xcad18115, + 0x6b2395e0, 0x333e92e1, 0x3b240b62, 0xeebeb922, 0x85b2a20e, 0xe6ba0d99, + 0xde720c8c, 0x2da2f728, 0xd0127845, 0x95b794fd, 0x647d0862, 0xe7ccf5f0, + 0x5449a36f, 0x877d48fa, 0xc39dfd27, 0xf33e8d1e, 0x0a476341, 0x992eff74, + 0x3a6f6eab, 0xf4f8fd37, 0xa812dc60, 0xa1ebddf8, 0x991be14c, 0xdb6e6b0d, + 0xc67b5510, 0x6d672c37, 0x2765d43b, 0xdcd0e804, 0xf1290dc7, 0xcc00ffa3, + 0xb5390f92, 0x690fed0b, 0x667b9ffb, 0xcedb7d9c, 0xa091cf0b, 0xd9155ea3, + 0xbb132f88, 0x515bad24, 0x7b9479bf, 0x763bd6eb, 0x37392eb3, 0xcc115979, + 0x8026e297, 0xf42e312d, 0x6842ada7, 0xc66a2b3b, 0x12754ccc, 0x782ef11c, + 0x6a124237, 0xb79251e7, 0x06a1bbe6, 0x4bfb6350, 0x1a6b1018, 0x11caedfa, + 0x3d25bdd8, 0xe2e1c3c9, 0x44421659, 0x0a121386, 0xd90cec6e, 0xd5abea2a, + 0x64af674e, 0xda86a85f, 0xbebfe988, 0x64e4c3fe, 0x9dbc8057, 0xf0f7c086, + 0x60787bf8, 0x6003604d, 0xd1fd8346, 0xf6381fb0, 0x7745ae04, 0xd736fccc, + 0x83426b33, 0xf01eab71, 0xb0804187, 0x3c005e5f, 0x77a057be, 0xbde8ae24, + 0x55464299, 0xbf582e61, 0x4e58f48f, 0xf2ddfda2, 0xf474ef38, 0x8789bdc2, + 0x5366f9c3, 0xc8b38e74, 0xb475f255, 0x46fcd9b9, 0x7aeb2661, 0x8b1ddf84, + 0x846a0e79, 0x915f95e2, 0x466e598e, 0x20b45770, 0x8cd55591, 0xc902de4c, + 0xb90bace1, 0xbb8205d0, 0x11a86248, 0x7574a99e, 0xb77f19b6, 0xe0a9dc09, + 0x662d09a1, 0xc4324633, 0xe85a1f02, 0x09f0be8c, 0x4a99a025, 0x1d6efe10, + 0x1ab93d1d, 0x0ba5a4df, 0xa186f20f, 0x2868f169, 0xdcb7da83, 0x573906fe, + 0xa1e2ce9b, 0x4fcd7f52, 0x50115e01, 0xa70683fa, 0xa002b5c4, 0x0de6d027, + 0x9af88c27, 0x773f8641, 0xc3604c06, 0x61a806b5, 0xf0177a28, 0xc0f586e0, + 0x006058aa, 0x30dc7d62, 0x11e69ed7, 0x2338ea63, 0x53c2dd94, 0xc2c21634, + 0xbbcbee56, 0x90bcb6de, 0xebfc7da1, 0xce591d76, 0x6f05e409, 0x4b7c0188, + 0x39720a3d, 0x7c927c24, 0x86e3725f, 0x724d9db9, 0x1ac15bb4, 0xd39eb8fc, + 0xed545578, 0x08fca5b5, 0xd83d7cd3, 0x4dad0fc4, 0x1e50ef5e, 0xb161e6f8, + 0xa28514d9, 0x6c51133c, 0x6fd5c7e7, 0x56e14ec4, 0x362abfce, 0xddc6c837, + 0xd79a3234, 0x92638212, 0x670efa8e, 0x406000e0]) + +iSbox3 :: Sbox +iSbox3 = array (0,255) (zip [0..255] + [0x3a39ce37, 0xd3faf5cf, 0xabc27737, 0x5ac52d1b, 0x5cb0679e, 0x4fa33742, + 0xd3822740, 0x99bc9bbe, 0xd5118e9d, 0xbf0f7315, 0xd62d1c7e, 0xc700c47b, + 0xb78c1b6b, 0x21a19045, 0xb26eb1be, 0x6a366eb4, 0x5748ab2f, 0xbc946e79, + 0xc6a376d2, 0x6549c2c8, 0x530ff8ee, 0x468dde7d, 0xd5730a1d, 0x4cd04dc6, + 0x2939bbdb, 0xa9ba4650, 0xac9526e8, 0xbe5ee304, 0xa1fad5f0, 0x6a2d519a, + 0x63ef8ce2, 0x9a86ee22, 0xc089c2b8, 0x43242ef6, 0xa51e03aa, 0x9cf2d0a4, + 0x83c061ba, 0x9be96a4d, 0x8fe51550, 0xba645bd6, 0x2826a2f9, 0xa73a3ae1, + 0x4ba99586, 0xef5562e9, 0xc72fefd3, 0xf752f7da, 0x3f046f69, 0x77fa0a59, + 0x80e4a915, 0x87b08601, 0x9b09e6ad, 0x3b3ee593, 0xe990fd5a, 0x9e34d797, + 0x2cf0b7d9, 0x022b8b51, 0x96d5ac3a, 0x017da67d, 0xd1cf3ed6, 0x7c7d2d28, + 0x1f9f25cf, 0xadf2b89b, 0x5ad6b472, 0x5a88f54c, 0xe029ac71, 0xe019a5e6, + 0x47b0acfd, 0xed93fa9b, 0xe8d3c48d, 0x283b57cc, 0xf8d56629, 0x79132e28, + 0x785f0191, 0xed756055, 0xf7960e44, 0xe3d35e8c, 0x15056dd4, 0x88f46dba, + 0x03a16125, 0x0564f0bd, 0xc3eb9e15, 0x3c9057a2, 0x97271aec, 0xa93a072a, + 0x1b3f6d9b, 0x1e6321f5, 0xf59c66fb, 0x26dcf319, 0x7533d928, 0xb155fdf5, + 0x03563482, 0x8aba3cbb, 0x28517711, 0xc20ad9f8, 0xabcc5167, 0xccad925f, + 0x4de81751, 0x3830dc8e, 0x379d5862, 0x9320f991, 0xea7a90c2, 0xfb3e7bce, + 0x5121ce64, 0x774fbe32, 0xa8b6e37e, 0xc3293d46, 0x48de5369, 0x6413e680, + 0xa2ae0810, 0xdd6db224, 0x69852dfd, 0x09072166, 0xb39a460a, 0x6445c0dd, + 0x586cdecf, 0x1c20c8ae, 0x5bbef7dd, 0x1b588d40, 0xccd2017f, 0x6bb4e3bb, + 0xdda26a7e, 0x3a59ff45, 0x3e350a44, 0xbcb4cdd5, 0x72eacea8, 0xfa6484bb, + 0x8d6612ae, 0xbf3c6f47, 0xd29be463, 0x542f5d9e, 0xaec2771b, 0xf64e6370, + 0x740e0d8d, 0xe75b1357, 0xf8721671, 0xaf537d5d, 0x4040cb08, 0x4eb4e2cc, + 0x34d2466a, 0x0115af84, 0xe1b00428, 0x95983a1d, 0x06b89fb4, 0xce6ea048, + 0x6f3f3b82, 0x3520ab82, 0x011a1d4b, 0x277227f8, 0x611560b1, 0xe7933fdc, + 0xbb3a792b, 0x344525bd, 0xa08839e1, 0x51ce794b, 0x2f32c9b7, 0xa01fbac9, + 0xe01cc87e, 0xbcc7d1f6, 0xcf0111c3, 0xa1e8aac7, 0x1a908749, 0xd44fbd9a, + 0xd0dadecb, 0xd50ada38, 0x0339c32a, 0xc6913667, 0x8df9317c, 0xe0b12b4f, + 0xf79e59b7, 0x43f5bb3a, 0xf2d519ff, 0x27d9459c, 0xbf97222c, 0x15e6fc2a, + 0x0f91fc71, 0x9b941525, 0xfae59361, 0xceb69ceb, 0xc2a86459, 0x12baa8d1, + 0xb6c1075e, 0xe3056a0c, 0x10d25065, 0xcb03a442, 0xe0ec6e0e, 0x1698db3b, + 0x4c98a0be, 0x3278e964, 0x9f1f9532, 0xe0d392df, 0xd3a0342b, 0x8971f21e, + 0x1b0a7441, 0x4ba3348c, 0xc5be7120, 0xc37632d8, 0xdf359f8d, 0x9b992f2e, + 0xe60b6f47, 0x0fe3f11d, 0xe54cda54, 0x1edad891, 0xce6279cf, 0xcd3e7e6f, + 0x1618b166, 0xfd2c1d05, 0x848fd2c5, 0xf6fb2299, 0xf523f357, 0xa6327623, + 0x93a83531, 0x56cccd02, 0xacf08162, 0x5a75ebb5, 0x6e163697, 0x88d273cc, + 0xde966292, 0x81b949d0, 0x4c50901b, 0x71c65614, 0xe6c6c7bd, 0x327a140a, + 0x45e1d006, 0xc3f27b9a, 0xc9aa53fd, 0x62a80f00, 0xbb25bfe2, 0x35bdd2f6, + 0x71126905, 0xb2040222, 0xb6cbcf7c, 0xcd769c2b, 0x53113ec0, 0x1640e3d3, + 0x38abbd60, 0x2547adf0, 0xba38209c, 0xf746ce76, 0x77afa1c5, 0x20756060, + 0x85cbfe4e, 0x8ae88dd8, 0x7aaaf9b0, 0x4cf9aa7e, 0x1948c25c, 0x02fb8a8c, + 0x01c36ae4, 0xd6ebe1f9, 0x90d4f869, 0xa65cdea0, 0x3f09252d, 0xc208e69f, + 0xb74e6132, 0xce77e25b, 0x578fdfe3, 0x3ac372e6]) diff --git a/src/Codec/Encryption/DES.hs b/src/Codec/Encryption/DES.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/DES.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.DES +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +-- Takes the DES module supplied by Ian Lynagh and wraps it so it can +-- used with the standard modes. +-- +-- See . +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.DES ( + -- * Function Types + encrypt, decrypt) where + +import Codec.Encryption.DESAux +import Data.Word + +-- | Basic DES encryption which takes a key and a block of plaintext +-- and returns the encrypted block of ciphertext according to the standard. + +encrypt :: Word64 -> Word64 -> Word64 +encrypt = flip des_enc + +-- | Basic DES decryption which takes a key and a block of ciphertext and +-- returns the decrypted block of plaintext according to the standard. + +decrypt :: Word64 -> Word64 -> Word64 +decrypt = flip des_dec diff --git a/src/Codec/Encryption/DESAux.hs b/src/Codec/Encryption/DESAux.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/DESAux.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Codec.Encryption.DESAux (des_enc, des_dec) where + +import Data.Word +import Data.Bits + +type Rotation = Int +type Key = Word64 +type Message = Word64 +type Enc = Word64 + +type BitsX = [Bool] +type Bits4 = [Bool] +type Bits6 = [Bool] +type Bits32 = [Bool] +type Bits48 = [Bool] +type Bits56 = [Bool] +type Bits64 = [Bool] + +instance Num [Bool] + +instance Bits [Bool] where + a `xor` b = (zipWith (\x y -> (not x && y) || (x && not y)) a b) + rotate bits rot = drop rot' bits ++ take rot' bits + where rot' = rot `mod` (length bits) + +bitify :: Word64 -> Bits64 +bitify w = map (\b -> w .&. (shiftL 1 b) /= 0) [63,62..0] + +unbitify :: Bits64 -> Word64 +unbitify bs = foldl (\i b -> if b then 1 + shiftL i 1 else shiftL i 1) 0 bs + +initial_permutation :: Bits64 -> Bits64 +initial_permutation mb = map ((!!) mb) i + where i = [57, 49, 41, 33, 25, 17, 9, 1, 59, 51, 43, 35, 27, 19, 11, 3, + 61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7, + 56, 48, 40, 32, 24, 16, 8, 0, 58, 50, 42, 34, 26, 18, 10, 2, + 60, 52, 44, 36, 28, 20, 12, 4, 62, 54, 46, 38, 30, 22, 14, 6] + +key_transformation :: Bits64 -> Bits56 +key_transformation kb = map ((!!) kb) i + where i = [56, 48, 40, 32, 24, 16, 8, 0, 57, 49, 41, 33, 25, 17, + 9, 1, 58, 50, 42, 34, 26, 18, 10, 2, 59, 51, 43, 35, + 62, 54, 46, 38, 30, 22, 14, 6, 61, 53, 45, 37, 29, 21, + 13, 5, 60, 52, 44, 36, 28, 20, 12, 4, 27, 19, 11, 3] + +des_enc :: Message -> Key -> Enc +des_enc = do_des [1,2,4,6,8,10,12,14,15,17,19,21,23,25,27,28] + +des_dec :: Message -> Key -> Enc +des_dec = do_des [28,27,25,23,21,19,17,15,14,12,10,8,6,4,2,1] + +do_des :: [Rotation] -> Message -> Key -> Enc +do_des rots m k = des_work rots (takeDrop 32 mb) kb + where kb = key_transformation $ bitify k + mb = initial_permutation $ bitify m + +des_work :: [Rotation] -> (Bits32, Bits32) -> Bits56 -> Enc +des_work [] (ml, mr) _ = unbitify $ final_perm $ (mr ++ ml) +des_work (r:rs) mb kb = des_work rs mb' kb + where mb' = do_round r mb kb + +do_round :: Rotation -> (Bits32, Bits32) -> Bits56 -> (Bits32, Bits32) +do_round r (ml, mr) kb = (mr, m') + where kb' = get_key kb r + comp_kb = compression_permutation kb' + expa_mr = expansion_permutation mr + res = comp_kb `xor` expa_mr + res' = tail $ iterate (trans 6) ([], res) + trans n (_, b) = (take n b, drop n b) + res_s = concat $ zipWith (\f (x,_) -> f x) [s_box_1, s_box_2, + s_box_3, s_box_4, + s_box_5, s_box_6, + s_box_7, s_box_8] res' + res_p = p_box res_s + m' = res_p `xor` ml + +get_key :: Bits56 -> Rotation -> Bits56 +get_key kb r = kb' + where (kl, kr) = takeDrop 28 kb + kb' = rotateL kl r ++ rotateL kr r + +compression_permutation :: Bits56 -> Bits48 +compression_permutation kb = map ((!!) kb) i + where i = [13, 16, 10, 23, 0, 4, 2, 27, 14, 5, 20, 9, + 22, 18, 11, 3, 25, 7, 15, 6, 26, 19, 12, 1, + 40, 51, 30, 36, 46, 54, 29, 39, 50, 44, 32, 47, + 43, 48, 38, 55, 33, 52, 45, 41, 49, 35, 28, 31] + +expansion_permutation :: Bits32 -> Bits48 +expansion_permutation mb = map ((!!) mb) i + where i = [31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, + 7, 8, 9, 10, 11, 12, 11, 12, 13, 14, 15, 16, + 15, 16, 17, 18, 19, 20, 19, 20, 21, 22, 23, 24, + 23, 24, 25, 26, 27, 28, 27, 28, 29, 30, 31, 0] + +s_box :: [[Word8]] -> Bits6 -> Bits4 +s_box s [a,b,c,d,e,f] = to_bool 4 $ (s !! row) !! col + where row = sum $ zipWith numericise [a,f] [1, 0] + col = sum $ zipWith numericise [b,c,d,e] [3, 2, 1, 0] + numericise = (\x y -> if x then 2^y else 0) + to_bool 0 _ = [] + to_bool n i = ((i .&. 8) == 8):to_bool (n-1) (shiftL i 1) + +s_box_1 :: Bits6 -> Bits4 +s_box_1 = s_box i + where i = [[14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7], + [ 0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8], + [ 4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0], + [15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13]] + +s_box_2 :: Bits6 -> Bits4 +s_box_2 = s_box i + where i = [[15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10], + [3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5], + [0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15], + [13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9]] + +s_box_3 :: Bits6 -> Bits4 +s_box_3 = s_box i + where i = [[10, 0, 9, 14 , 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8], + [13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1], + [13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7], + [1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12]] + +s_box_4 :: Bits6 -> Bits4 +s_box_4 = s_box i + where i = [[7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15], + [13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9], + [10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4], + [3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14]] + +s_box_5 :: Bits6 -> Bits4 +s_box_5 = s_box i + where i = [[2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9], + [14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6], + [4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14], + [11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3]] + +s_box_6 :: Bits6 -> Bits4 +s_box_6 = s_box i + where i = [[12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11], + [10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8], + [9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6], + [4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13]] + +s_box_7 :: Bits6 -> Bits4 +s_box_7 = s_box i + where i = [[4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1], + [13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6], + [1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2], + [6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12]] + +s_box_8 :: Bits6 -> Bits4 +s_box_8 = s_box i + where i = [[13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7], + [1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2], + [7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8], + [2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11]] + +p_box :: Bits32 -> Bits32 +p_box kb = map ((!!) kb) i + where i = [15, 6, 19, 20, 28, 11, 27, 16, 0, 14, 22, 25, 4, 17, 30, 9, + 1, 7, 23, 13, 31, 26, 2, 8, 18, 12, 29, 5, 21, 10, 3, 24] + +final_perm :: Bits64 -> Bits64 +final_perm kb = map ((!!) kb) i + where i = [39, 7, 47, 15, 55, 23, 63, 31, 38, 6, 46, 14, 54, 22, 62, 30, + 37, 5, 45, 13, 53, 21, 61, 29, 36, 4, 44, 12, 52, 20, 60, 28, + 35, 3, 43, 11, 51, 19, 59, 27, 34, 2, 42, 10, 50, 18, 58, 26, + 33, 1, 41, 9, 49, 17, 57, 25, 32, 0, 40 , 8, 48, 16, 56, 24] + +takeDrop :: Int -> [a] -> ([a], [a]) +takeDrop _ [] = ([], []) +takeDrop 0 xs = ([], xs) +takeDrop n (x:xs) = (x:ys, zs) + where (ys, zs) = takeDrop (n-1) xs + diff --git a/src/Codec/Encryption/Modes.hs b/src/Codec/Encryption/Modes.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/Modes.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.Modes +-- Copyright : (c) Dominic Steinitz 2001-2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +-- This module currently supports Cipher Block Chaining (CBC) mode. +-- See for further details. +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.Modes ( + -- * Function types + cbc, unCbc + ) where + +import Data.Word +import Data.Bits + +-- * CBC or Cipher Block Chaining Mode + +-- | In CBC or Cipher Block Chaining mode each block is XORed with +-- the previous enciphered block before encryption. For the first +-- block, start with an initialization vector. +-- Take an encryption function, an initialisation vector, a key and +-- a list of blocks and return the encrypted blocks using CBC. + +cbc :: Bits block => + (key -> block -> block) -> + block -> + key -> + [block] -> + [block] + +cbc e iv k ps = + ciphers where + ciphers = map (e k) feedIns + feedIns = zipWith xor (iv : ciphers) ps + +-- | To decipher in CBC or Cipher Block Chaining mode, decipher +-- each block, then XOR the result with the previous block of +-- plaintext result. Note that the initialization vector is treated as the +-- zeroth block of plaintext. +-- Take a decryption function, an initialisation vector, a key and a list +-- of encrypted blocks using CBC and return plaintext blocks. + +unCbc :: Bits block => + (key -> block -> block) -> + block -> + key -> + [block] -> + [block] + +unCbc d iv k ms = + outOfCbcs where + beforeXOrs = map (d k) ms + outOfCbcs = zipWith xor (iv : ms) beforeXOrs diff --git a/src/Codec/Encryption/Padding.hs b/src/Codec/Encryption/Padding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/Padding.hs @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.Padding +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +-- Padding algorithms for use with block ciphers. +-- +-- This module currently supports: +-- +-- * PKCS5 padding and unpadding. +-- +-- * Null padding and unpadding. +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.Padding ( + -- * Function types + pkcs5, unPkcs5, + padNulls, unPadNulls + ) where + +import Data.Word +import Data.Bits +import Data.List +import Codec.Utils + +-- | When the last block of plaintext is shorter than the block size then it +-- must be padded. PKCS5 specifies that the padding octets should each +-- contain the number of octets which must be stripped off. So, for example, +-- with a block size of 8, \"0a0b0c\" will be padded with \"05\" resulting in +-- \"0a0b0c0505050505\". If the final block is a full block of 8 octets +-- then a whole block of \"0808080808080808\" is appended. + +pkcs5 :: (Integral a, Bits a) => [Octet] -> [a] +pkcs5 s = pad p s where p n = replicate n (fromIntegral n) + +-- | When the last block of plaintext is shorter than the block size then it +-- must be padded. Nulls padding specifies that the padding octets should each +-- contain a null. So, for example, +-- with a block size of 8, \"0a0b0c\" will be padded to +-- \"0a0b0c0000000000\". If the final block is a full block of 8 octets +-- then a whole block of \"0000000000000000\" is appended. +-- NB this is only suitable for data which does not contain nulls, +-- for example, ASCII. + +padNulls :: (Integral a, Bits a) => [Octet] -> [a] +padNulls s = pad p s where p n = replicate n 0 + +testPad s = pad p s where p n = replicate (n-1) 0xff ++ [fromIntegral n] + +pad p s = + blocks where + octetSize = (bitSize $ head blocks) `div` 8 + blocks = map (fromOctets 256) (unfoldr h $ concat $ unfoldr g s) + g :: [Octet] -> Maybe ([Octet],[Octet]) + g x + | l == 0 = Nothing + | l < octetSize = Just (t ++ (p (octetSize-l)), []) + | d == [] = Just (t ++ (p octetSize), []) + | otherwise = Just (t, d) + where l = length t + t = take octetSize x + d = drop octetSize x + h :: [Octet] -> Maybe ([Octet],[Octet]) + h x + | x == [] = Nothing + | otherwise = Just (take octetSize x, drop octetSize x) + +-- | Take a list of blocks padded using the method described in PKCS5 +-- (see ) +-- and return the list of unpadded octets. NB this function does not +-- currently check that the padded block is correctly formed and should +-- only be used for blocks that have been padded correctly. + +unPkcs5 :: (Bits a, Integral a) => [a] -> [Octet] +unPkcs5 s = + unPad h s + where + h octetSize x = take (octetSize - (fromIntegral (last x))) x + +-- | Take a list of blocks padded with nulls +-- and return the list of unpadded octets. NB if the blocks contain +-- a null then the result is unpredictable. + +unPadNulls :: (Bits a, Integral a) => [a] -> [Octet] +unPadNulls s = + unPad h s + where + h _ x = takeWhile (/=0) x + +unPad p s = + concat $ unfoldr g s where + g :: (Integral a, Bits a) => [a] -> Maybe ([Octet],[a]) + g x + | t == [] = Nothing + | d == [] = Just (s, []) + | otherwise = Just (v, d) + where t = take 1 x + d = drop 1 x + u = head t + octetSize = (bitSize u) `div` 8 + v = i2osp octetSize u + s = p octetSize v diff --git a/src/Codec/Encryption/RSA.hs b/src/Codec/Encryption/RSA.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/RSA.hs @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Coded.Encryption.RSA +-- Copyright : (c) David J. Sankel 2003, Dominic Steinitz 2003 +-- License : GPL (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : non-portable +-- +-- A modified version of the RSA module supplied by David J. Sankel +-- (). +-- +-- As the original code is GPL, this has to be. +-- This code is free software; you can redistribute it and\/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This code is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this code; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111\-1307 USA +----------------------------------------------------------------------------- + +module Codec.Encryption.RSA( + -- * Function Types + encrypt, + decrypt + )where + +import Codec.Utils +import Codec.Encryption.RSA.NumberTheory + +rsaep :: (Integer , Integer) -> Integer -> Integer +rsaep (n,e) m + | m < 0 || m > n-1 = + error "Codec.Encryption.RSA.rsaep: message too long" + | otherwise = + expmod m e n + +-- | Take the modulus of the RSA key and the public exponent expressed +-- as lists of octets and the plaintext also expressed as a list of +-- octets and return the ciphertext as a list of octets. Of course, +-- these are all large integers but using lists of octets makes +-- everything easier. See +-- for more +-- details. + +encrypt :: ([Octet],[Octet]) -> [Octet] -> [Octet] +encrypt (n,e) m = + i2osp (length n) $ + rsaep (fromOctets 256 n, fromOctets 256 e) (fromOctets 256 m) + +rsadp :: (Integer , Integer) -> Integer -> Integer +rsadp (n,d) c + | c < 0 || c > n-1 = + error "Codec.Encryption.RSA.rsadp: decryption error" + | otherwise = + expmod c d n + +-- | Take the modulus of the RSA key and the private exponent expressed +-- as lists of octets and the ciphertext also expressed as a list of +-- octets and return the plaintext as a list of octets. + +decrypt :: ([Octet],[Octet]) -> [Octet] -> [Octet] +decrypt (n,e) m + | lc > lm = + error "Codec.Encryption.RSA.rsadp: decryption error" + | otherwise = + i2osp (length n) $ + rsadp (fromOctets 256 n, fromOctets 256 e) (fromOctets 256 m) + where + lc = length $ dropWhile (==0x00) m + lm = length $ dropWhile (==0x00) n diff --git a/src/Codec/Encryption/RSA/EMEOAEP.hs b/src/Codec/Encryption/RSA/EMEOAEP.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/RSA/EMEOAEP.hs @@ -0,0 +1,94 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Coded.Encryption.RSA.EMEOAEP +-- Copyright : (c) David J. Sankel 2003, Dominic Steinitz 2003 +-- License : GPL (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : non-portable +-- +-- A modified version of the EMEOAEP module supplied by David J. Sankel +-- (). +-- +-- As the original code is GPL, this has to be. +-- This code is free software; you can redistribute it and\/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This code is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this code; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111\-1307 USA +----------------------------------------------------------------------------- + +module Codec.Encryption.RSA.EMEOAEP( + -- * Function Types + encode, + decode + )where + +import Codec.Utils (Octet) +import Data.Bits + +xorOctets :: Bits a => [a] -> [a] -> [a] +xorOctets = zipWith xor + +-- | Take a mask generating function, a hash function, a label (which may be +-- null), a random seed, the modulus of the key and the message and returns +-- an encoded message. NB you could pass in the length of the modulus +-- but it seems safer to pass in the modulus itself and calculate the +-- length when required. See +-- for more +-- details. + +encode :: (([Octet] -> [Octet]) -> [Octet] -> Int -> [Octet]) -> + ([Octet] -> [Octet]) -> [Octet] -> [Octet] -> [Octet] -> [Octet] -> + [Octet] + +encode mgf hash p seed n m = + if length m > emLen - 2*hLen - 2 + then error "Codec.Encryption.EMEOAEP.encode: message too long" + else em + where + emLen = length n + mLen = length m + ps = take (emLen-mLen-2*hLen-2) $ repeat $ 0x00 + pHash = hash p + hLen = length pHash + db = pHash ++ ps ++ [0x01] ++ m + dbMask = mgf hash seed (length db) + maskedDB = db `xorOctets` dbMask + seedMask = mgf hash maskedDB hLen + maskedSeed = seed `xorOctets` seedMask + em = [0x00] ++ maskedSeed ++ maskedDB + +-- | Take a mask generating function, a hash function, a label (which may be +-- null) and the message and returns the decoded. + +decode :: (([Octet] -> [Octet]) -> [Octet] -> Int -> [Octet]) -> + ([Octet] -> [Octet]) -> [Octet] -> [Octet] -> [Octet] + +decode mgf hash p em = + if length em < 2*hLen + 1 || + one /= 0x01 || + pHash' /= pHash || + y /= [0x00] + then error "Codec.Encryption.EMEOAEP.decode: decryption error" + else m + where + (y,rest) = splitAt 1 em + pHash = hash p + hLen = length pHash + (maskedSeed,maskedDB) = splitAt hLen rest + seedMask = mgf hash maskedDB hLen + seed = maskedSeed `xorOctets` seedMask + emLen = length em + dbMask = mgf hash seed (emLen - hLen - 1) + db = maskedDB `xorOctets` dbMask + (pHash',rest') = splitAt hLen db + (one:m) = dropWhile (== 0x00) rest' diff --git a/src/Codec/Encryption/RSA/MGF.hs b/src/Codec/Encryption/RSA/MGF.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/RSA/MGF.hs @@ -0,0 +1,31 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.RSA.MGF +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Stability : experimental +-- Portability : portable +-- +-- Implements the mask generation function as specified in: +-- +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.RSA.MGF ( + -- * Function Types + mgf) where + +import Codec.Utils (Octet, i2osp) + +-- | Take a hash function, a seed and the intended length of the +-- the mask and deliver a mask of the requested length. + +mgf :: ([Octet] -> [Octet]) -> [Octet] -> Int -> [Octet] + +mgf hash z l = + take l $ concat $ hashes + where + hashes = map f [0..(l `div` hLen)] + hLen = length $ f 0 + f = hash . (z++) . (i2osp 4) diff --git a/src/Codec/Encryption/RSA/NumberTheory.hs b/src/Codec/Encryption/RSA/NumberTheory.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/RSA/NumberTheory.hs @@ -0,0 +1,203 @@ +--Copyright 2001, 2002, 2003 David J. Sankel +-- +--This file is part of rsa-haskell. +--rsa-haskell is free software; you can redistribute it and/or modify +--it under the terms of the GNU General Public License as published by +--the Free Software Foundation; either version 2 of the License, or +--(at your option) any later version. +-- +--rsa-haskell is distributed in the hope that it will be useful, +--but WITHOUT ANY WARRANTY; without even the implied warranty of +--MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +--GNU General Public License for more details. +-- +--You should have received a copy of the GNU General Public License +--along with rsa-haskell; if not, write to the Free Software +--Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +module Codec.Encryption.RSA.NumberTheory( +inverse, extEuclGcd, simplePrimalityTest, getPrime, pg, isPrime, +rabinMillerPrimalityTest, expmod, factor, testInverse, primes, (/|), +randomOctet +) where + + +import System.Random(getStdRandom,randomR) +--The following line is required for ghc optomized implementation +-- (see comments beginning with GHC): +-- import Bits(setBit) +import Data.List(elemIndex) +import Data.Maybe(fromJust) +import Data.Char(chr,ord) +import Data.Bits(xor) + +--Precondition: the integer is >= 0 +randomOctet :: Int -> IO( String ) +randomOctet n + | n < 0 = error "randomOctet argument doesn't meet preconditions" + | otherwise = (sequence $ take n $ repeat $ getStdRandom (randomR( 0,255) )) + >>= (return . (map chr) ) + +--Returns a list [r_1,r_2,r_3,r_4, . . ., r_n ] where +-- a = p_1^r_1 * p_2^r_2 * p_3^r_3 * . . . * p_n^r_n +factor :: Integer -> [Int] +factor = factor_1 + +--An implimentation of factor +factor_1 :: Integer -> [Int] +factor_1 a = reverse . dropWhile (== 0) . reverse + . map (\x -> largestPower x a) . takeWhile (<= a ) $ primes + +--Another implimentation of factor +factor_2 :: Integer -> [Integer] +factor_2 a = + let + p = map (fromIntegral) . reverse . dropWhile (== 0) + . reverse . map (\x -> largestPower x a) + . takeWhile (<= a `div` 2) $ primes + in + if (length p == 0) + then (take ((fromIntegral . fromJust $ elemIndex a primes)-1) (repeat 0)) + ++ [1] + else p + +--Find the inverse of x (mod n) +inverse :: Integer -> Integer -> Integer +inverse x n = (fst (extEuclGcd x n)) `mod` n + +testInverse :: Integer ->Integer -> Bool +testInverse a b = ((inverse a b)*a) `mod` b == 1 + +--Extended Eucildean algorithm +--Returns (x,y) where gcd(a,b) = xa + yb +extEuclGcd :: Integer -> Integer -> (Integer,Integer) +extEuclGcd a b = extEuclGcd_iter a b (1,0) (0,1) + +extEuclGcd_iter :: Integer -> Integer + -> (Integer,Integer) -> (Integer,Integer) -> (Integer,Integer) +extEuclGcd_iter a b (c1,c2) (d1,d2) + | (a > b) && (r1 == 0) = (d1,d2) + | (a > b) && (r1 /= 0) = extEuclGcd_iter + (a - (q1*b)) b (c1 - (q1*d1), c2 - (q1*d2)) (d1,d2) + | (a <= b) && (r2 == 0) = (c1,c2) + | (a <= b) && (r2 /= 0) = extEuclGcd_iter + a (b - (q2*a)) (c1,c2) ( d1 - (q2*c1), d2- (q2*c2)) + where + q1 = a `div` b + q2 = b `div` a + r1 = a `mod` b + r2 = b `mod` a + +-- This will return a random Integer of n bits. The highest order bit +-- will always be 1. + +-- GHC optomized implementation +-- getNumber :: Int -> IO Integer +-- getNumber n = do +-- i <- getStdRandom ( randomR (0, a-1 ) ) +-- return (setBit i (n-1)) +-- where +-- a = (2^n) ::Integer + +--This is the portable version +getNumber :: Int -> IO Integer +getNumber n = do + i <- getStdRandom ( randomR (0, a-1 ) ) + return (i+(2^(n-1))) + where + a = (2^(n-1)) ::Integer + +--Returns a probable prime number of nBits bits + +-- GHC optomized implementation +-- getPrime :: Int -> IO Integer +-- getPrime nBits = do +-- r <- getNumber nBits +-- let p = (setBit r 0) --Make it odd for speed +-- pIsPrime <- isPrime p +-- if( pIsPrime ) +-- then return p +-- else getPrime nBits + +--This is the portable version +getPrime :: Int -> IO Integer +getPrime nBits = do + r <- getNumber nBits + let p = if( 2 /| r ) then r else r+1 + pIsPrime <- isPrime p + if( pIsPrime ) + then return p + else getPrime nBits + +--Prime Generate: +--Generates a prime p | minimum <= p <= maximum and gcd p e == 1 +pg :: Integer -> Integer -> Integer -> IO(Integer) +pg minimum maximum e = do + p <- getStdRandom( randomR( minimum, maximum ) ) + pIsPrime <- isPrime p + if( pIsPrime && (gcd p e) == 1 ) + then return p + else pg minimum maximum e + +isPrime :: Integer -> IO Bool +isPrime a + | (a <= 1) = return False + | (a <= 2000) = return (simplePrimalityTest a) + | otherwise = if (simplePrimalityTest a) + then do --Do this 5 times for saftey + test <- mapM rabinMillerPrimalityTest $ take 5 $ repeat a + return (and test) + else return False + +simplePrimalityTest :: Integer -> Bool +simplePrimalityTest a = foldr (&&) True (map (/| a)(takeWhile ( Integer -> Int +largestPower x y = fromJust . elemIndex False + . map (\b -> (y `mod` x^b) == 0) $ [1..] + +rabinMillerPrimalityTest :: Integer -> IO Bool +rabinMillerPrimalityTest p = rabinMillerPrimalityTest_iter_1 p b m + where + b = fromIntegral $ largestPower 2 (p-1) + m = (p-1) `div` (2^b) + +--The ?prime? Number -> The amount of iterations -> b -> m +rabinMillerPrimalityTest_iter_1 :: Integer -> Integer -> Integer -> IO Bool +rabinMillerPrimalityTest_iter_1 p b m = + do + a <- getStdRandom ( randomR (0, 2000 ) ) + return (rabinMillerPrimalityTest_iter_2 p b 0 (expmod a m p)) + +rabinMillerPrimalityTest_iter_2 :: Integer -> Integer -> Integer -> Integer + -> Bool +rabinMillerPrimalityTest_iter_2 p b j z + | (z == 1) || (z == p-1) = True + | (j > 0) && (z == 1) = False + | (j+1 < b) && (z /= p-1) = + (rabinMillerPrimalityTest_iter_2 p b (j+1) ((z^2) `mod` p )) + | z == p - 1 = True + | (j+1 == b) && (z /= p-1) = False + +--a^x (mod m) +expmod :: Integer -> Integer -> Integer -> Integer +expmod a x m | x == 0 = 1 + | x == 1 = a `mod` m + | even x = let p = (expmod a (x `div` 2) m) `mod` m + in (p^2) `mod` m + | otherwise = (a * expmod a (x-1) m) `mod` m + +--Largest x where x^2 < i +intSqrt :: Integer -> Integer +intSqrt i = floor (sqrt (fromIntegral i ) ) + +--The doesn't divide function +(/|) :: Integer -> Integer -> Bool +a /| b = b `mod` a /= 0 + +--List of primes +primes :: [Integer] +primes = 2:[x | x <- [3,5..], foldr (&&) True + ( map ( /| x ) (takeWhile (<=(intSqrt x)) primes ) ) ] diff --git a/src/Codec/Encryption/TEA.hs b/src/Codec/Encryption/TEA.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/TEA.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.TEA +-- Copyright : (c) John Meacham 2008 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +-- Implementation of the TEA tiny encryption algorithm +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.TEA( + TEAKey(TEAKey), + encrypt, + decrypt + ) where + +import Data.Bits +import Data.Word + +-- We don't use LargeKey for both efficiency and practical reasons. + +data TEAKey = TEAKey {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 + + +delta :: Word32 +delta = 0x9e3779b9 + +rounds = 32 + +encrypt :: TEAKey -> Word64 -> Word64 +encrypt (TEAKey k0 k1 k2 k3) v = f rounds 0 v0 v1 where + v0,v1 :: Word32 + v0 = fromIntegral v + v1 = fromIntegral $ v `shiftR` 32 + f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined + f 0 _ v0 v1 = (fromIntegral v1 `shiftL` 32) .|. (fromIntegral v0 .&. 0xffffffff) + f n sum v0 v1 = f (n - 1) sum' v0' v1' where + sum' = sum + delta + v0' = (v0 + (((v1 `shiftL` 4) + k0) `xor` (v1 + sum') `xor` ((v1 `shiftR` 5) + k1))) + v1' = (v1 + (((v0' `shiftL` 4) + k2) `xor` (v0' + sum') `xor` ((v0' `shiftR` 5) + k3))) + + +decrypt :: TEAKey -> Word64 -> Word64 +decrypt (TEAKey k0 k1 k2 k3) v = f rounds 0xC6EF3720 v0 v1 where + v0,v1 :: Word32 + v0 = fromIntegral v + v1 = fromIntegral $ v `shiftR` 32 + f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined + f 0 _ v0 v1 = (fromIntegral v1 `shiftL` 32) .|. (fromIntegral v0 .&. 0xFFFFFFFF) + f n sum v0 v1 = f (n - 1) (sum - delta) v0' v1' where + v1' = (v1 - (((v0 `shiftL` 4) + k2) `xor` (v0 + sum) `xor` ((v0 `shiftR` 5) + k3))) + v0' = (v0 - (((v1' `shiftL` 4) + k0) `xor` (v1' + sum) `xor` ((v1' `shiftR` 5) + k1))) + + + +{- + void encrypt (unsigned long* v, unsigned long* k) { + unsigned long v0=v[0], v1=v[1], sum=0, i; /* set up */ + unsigned long delta=0x9e3779b9; /* a key schedule constant */ + unsigned long k0=k[0], k1=k[1], k2=k[2], k3=k[3]; /* cache key */ + for (i=0; i < 32; i++) { /* basic cycle start */ + sum += delta; + v0 += ((v1<<4) + k0) ^ (v1 + sum) ^ ((v1>>5) + k1); + v1 += ((v0<<4) + k2) ^ (v0 + sum) ^ ((v0>>5) + k3); /* end cycle */ + } + v[0]=v0; v[1]=v1; +} + +void decrypt (unsigned long* v, unsigned long* k) { + unsigned long v0=v[0], v1=v[1], sum=0xC6EF3720, i; /* set up */ + unsigned long delta=0x9e3779b9; /* a key schedule constant */ + unsigned long k0=k[0], k1=k[1], k2=k[2], k3=k[3]; /* cache key */ + for (i=0; i<32; i++) { /* basic cycle start */ + v1 -= ((v0<<4) + k2) ^ (v0 + sum) ^ ((v0>>5) + k3); + v0 -= ((v1<<4) + k0) ^ (v1 + sum) ^ ((v1>>5) + k1); + sum -= delta; /* end cycle */ + } + v[0]=v0; v[1]=v1; +} + +-} diff --git a/src/Codec/Text/Raw.hs b/src/Codec/Text/Raw.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Text/Raw.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Coded.Text.Raw +-- Copyright : (c) Dominic Steinitz 2006 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +----------------------------------------------------------------------------- + +module Codec.Text.Raw( + hexdump, + hexdumpBy, + ) where + +import Data.List +import Codec.Utils +import Numeric +import Text.PrettyPrint + +split :: Int -> [a] -> [[a]] +split n xs = unfoldr (g n) xs + +g :: Int -> [a] -> Maybe ([a],[a]) +g n [] = Nothing +g n y = Just (splitAt n y) + +sh x | x < 16 = '0':(showHex x "") + | otherwise = showHex x "" + +type OctetsPerLine = Int + +hexdump :: OctetsPerLine -> [Octet] -> Doc +hexdump n = + vcat . + map hcat . + map (intersperse colon) . + map (map (text . sh)) . + split n + +hexdumpBy :: String -> OctetsPerLine -> [Octet] -> Doc +hexdumpBy s n = + vcat . + map hcat . + map (intersperse (text s)) . + map (map (text . sh)) . + split n diff --git a/src/Codec/Utils.hs b/src/Codec/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Utils.hs @@ -0,0 +1,132 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Utils +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +-- Utilities for coding and decoding. +-- +----------------------------------------------------------------------------- + +module Codec.Utils ( + -- * Types and Constants + Octet, + msb, + -- * Octet Conversion Functions + fromTwosComp, toTwosComp, + toOctets, fromOctets, + listFromOctets, listToOctets, + i2osp + ) where + +import Data.Word +import Data.Bits + +powersOf n = 1 : (map (*n) (powersOf n)) + +toBase x = + map fromIntegral . + reverse . + map (flip mod x) . + takeWhile (/=0) . + iterate (flip div x) + +-- | Take a number @x@ convert it to base @n@ as a list of octets. +toOctets :: (Integral a, Integral b) => a -> b -> [Octet] +toOctets n x = (toBase n . fromIntegral) x + +-- | This is used to (approximately) get back to a starting word list. +-- For example, if you have a list of 3 Word8 and try to convert them to +-- a Word32, the Word32 will get null-padded, and without correction, you +-- will get 4 Word8s when converting back. This corrects it. +-- Unfortunately, it also means you will have errors if trying to convert +-- Word8 lists with nulls on the end. +trimNulls :: [Word8] -> [Word8] +trimNulls = reverse . (dropWhile (== 0)) . reverse + +-- | Converts a list of numbers into a list of octets. +-- The resultant list has nulls trimmed from the end to make this the dual +-- of listFromOctets (except when the original octet list ended with nulls; +-- see 'trimNulls'). +listToOctets :: (Bits a, Integral a) => [a] -> [Octet] +listToOctets x = trimNulls $ concat paddedOctets where + paddedOctets :: [[Octet]] + paddedOctets = map (padTo bytes) rawOctets + rawOctets :: [[Octet]] + rawOctets = map (reverse . toOctets 256) x + padTo :: Int -> [Octet] -> [Octet] + padTo x y = take x $ y ++ repeat 0 + bytes :: Int + bytes = bitSize (head x) `div` 8 + +-- | The basic 8-bit type for encoding and decoding. +type Octet = Word8 + +-- | The most significant bit of an 'Octet'. +msb :: Int +msb = bitSize (undefined::Octet) - 1 + +-- | Take a list of octets (a number expressed in base n) and convert it +-- to a number. +fromOctets :: (Integral a, Integral b) => a -> [Octet] -> b +fromOctets n x = + fromIntegral $ + sum $ + zipWith (*) (powersOf n) (reverse (map fromIntegral x)) + +-- | See 'listToOctets'. +listFromOctets :: (Integral a, Bits a) => [Octet] -> [a] +listFromOctets [] = [] +listFromOctets x = result where + result = first : rest + first = fromOctets 256 first' + first' = reverse $ take bytes x + rest = listFromOctets $ drop bytes x + bytes = bitSize first `div` 8 + +-- | Take the length of the required number of octets and convert the +-- number to base 256 padding it out to the required length. If the +-- required length is less than the number of octets of the converted +-- number then return the converted number. NB this is different from +-- the standard +-- but mimics how replicate behaves. +i2osp :: Integral a => Int -> a -> [Octet] +i2osp l y = + pad ++ z + where + pad = replicate (l - unPaddedLen) (0x00::Octet) + z = toOctets 256 y + unPaddedLen = length z + +-- | Convert from twos complement. + +fromTwosComp :: Integral a => [Octet] -> a +fromTwosComp x = conv x + where conv [] = 0 + conv w@(x:xs) = if (testBit x msb) + then neg w + else pos w + neg w@(x:xs) = let z=(clearBit x msb):xs in + fromIntegral((fromOctets 256 z)- + (128*(256^((length w)-1)))) + pos w = fromIntegral(fromOctets 256 w) + +toTwosComp :: Integral a => a -> [Octet] +toTwosComp x + | x < 0 = reverse . plusOne . reverse . (map complement) $ u + | x == 0 = [0x00] + | otherwise = u + where z@(y:ys) = toBase 256 (abs x) + u = if testBit y msb + then 0x00:z + else z + +plusOne :: [Octet] -> [Octet] +plusOne [] = [1] +plusOne (x:xs) = + if x == 0xff + then 0x00:(plusOne xs) + else (x+1):xs diff --git a/src/Data/Digest/MD5.hs b/src/Data/Digest/MD5.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digest/MD5.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.MD5 +-- Copyright : (c) Dominic Steinitz 2004 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +-- Takes the MD5 module supplied by Ian Lynagh and wraps it so it +-- takes [Octet] and returns [Octet] where the length of the result +-- is always 16. +-- See +-- and . +-- +----------------------------------------------------------------------------- + +module Data.Digest.MD5 ( + -- * Function Types + hash) where + +import Data.Digest.MD5Aux +import Codec.Utils +import Data.Char(chr) +import Data.List(unfoldr) +import Numeric(readHex) + +-- | Take [Octet] and return [Octet] according to the standard. +-- The length of the result is always 16 octets or 128 bits as required +-- by the standard. + +hash :: [Octet] -> [Octet] +hash xs = + unfoldr f $ md5s $ Str $ map (chr . fromIntegral) xs + where f :: String -> Maybe (Octet,String) + f [] = + Nothing + f (x:y:zs) = + Just (fromIntegral a,zs) + where [(a,_)] = readHex (x:y:[]) diff --git a/src/Data/Digest/MD5Aux.hs b/src/Data/Digest/MD5Aux.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digest/MD5Aux.hs @@ -0,0 +1,355 @@ +module Data.Digest.MD5Aux + (md5, md5s, md5i, + MD5(..), ABCD(..), + Zord64, Str(..), BoolList(..), WordList(..)) where + +import Data.Char +import Data.Bits +import Data.Word + +{- +Nasty kludge to create a type Zord64 which is really a Word64 but works +how we want in hugs ands nhc98 too... +Also need a rotate left function that actually works. + +#ifdef __GLASGOW_HASKELL__ +#define rotL rotateL +#include "Zord64_EASY.hs" +#else + +> import Zord64_HARD + +> rotL :: Word32 -> Rotation -> Word32 +> rotL a s = shiftL a s .|. shiftL a (s-32) + +#endif +-} + +rotL x = rotateL x +type Zord64 = Word64 + +-- ===================== TYPES AND CLASS DEFINTIONS ======================== + + +type XYZ = (Word32, Word32, Word32) +type Rotation = Int +newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) +newtype Str = Str String +newtype BoolList = BoolList [Bool] +newtype WordList = WordList ([Word32], Zord64) + +-- Anything we want to work out the MD5 of must be an instance of class MD5 + +class MD5 a where + get_next :: a -> ([Word32], Int, a) -- get the next blocks worth + -- \ \ \------ the rest of the input + -- \ \--------- the number of bits returned + -- \--------------- the bits returned in 32bit words + len_pad :: Zord64 -> a -> a -- append the padding and length + finished :: a -> Bool -- Have we run out of input yet? + + +-- Mainly exists because it's fairly easy to do MD5s on input where the +-- length is not a multiple of 8 + +instance MD5 BoolList where + get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) + where (ys, zs) = splitAt 512 s + len_pad l (BoolList bs) + = BoolList (bs ++ [True] + ++ replicate (fromIntegral $ (447 - l) .&. 511) False + ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] + ) + where mangle [] = [] + mangle xs = reverse ys ++ mangle zs + where (ys, zs) = splitAt 8 xs + finished (BoolList s) = s == [] + + +-- The string instance is fairly straightforward + +instance MD5 Str where + get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) + where (ys, zs) = splitAt 64 s + len_pad c64 (Str s) = Str (s ++ padding ++ l) + where padding = '\128':replicate (fromIntegral zeros) '\000' + zeros = shiftR ((440 - c64) .&. 511) 3 + l = length_to_chars 8 c64 + finished (Str s) = s == "" + + +-- YA instance that is believed will be useful + +instance MD5 WordList where + get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) + where (xs, ys) = splitAt 16 ws + taken = if l > 511 then 512 else l .&. 511 + len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) + where beginning = if length ws > 0 then start ++ lastone' else [] + start = init ws + lastone = last ws + offset = c64 .&. 31 + lastone' = [if offset > 0 then lastone + theone else lastone] + theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) + (fromIntegral $ offset .&. (31 - 7)) + nextish = if offset == 0 then [128] else [] + c64' = c64 + (32 - offset) + num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) + blanks = replicate num_blanks 0 + lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) + topsize = fromIntegral $ shiftR c64 32 + size = [lowsize, topsize] + newlen = l .&. (complement 511) + + if c64 .&. 511 >= 448 then 1024 else 512 + finished (WordList (_, z)) = z == 0 + + +instance Num ABCD where + ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + + +-- ===================== EXPORTED FUNCTIONS ======================== + + +-- The simplest function, gives you the MD5 of a string as 4-tuple of +-- 32bit words. + +md5 :: (MD5 a) => a -> ABCD +md5 m = md5_main False 0 magic_numbers m + + +-- Returns a hex number ala the md5sum program + +md5s :: (MD5 a) => a -> String +md5s = abcd_to_string . md5 + + +-- Returns an integer equivalent to the above hex number + +md5i :: (MD5 a) => a -> Integer +md5i = abcd_to_integer . md5 + + +-- ===================== THE CORE ALGORITHM ======================== + + +-- Decides what to do. The first argument indicates if padding has been +-- added. The second is the length mod 2^64 so far. Then we have the +-- starting state, the rest of the string and the final state. + +md5_main :: (MD5 a) => + Bool -- Have we added padding yet? + -> Zord64 -- The length so far mod 2^64 + -> ABCD -- The initial state + -> a -- The non-processed portion of the message + -> ABCD -- The resulting state +md5_main padded ilen abcd m + = if finished m && padded + then abcd + else md5_main padded' (ilen + 512) (abcd + abcd') m'' + where (m16, l, m') = get_next m + len' = ilen + fromIntegral l + ((m16', _, m''), padded') = if not padded && l < 512 + then (get_next $ len_pad len' m, True) + else ((m16, l, m'), padded) + abcd' = md5_do_block abcd m16' + + +-- md5_do_block processes a 512 bit block by calling md5_round 4 times to +-- apply each round with the correct constants and permutations of the +-- block + +md5_do_block :: ABCD -- Initial state + -> [Word32] -- The block to be processed - 16 32bit words + -> ABCD -- Resulting state +md5_do_block abcd0 w = abcd4 + where (r1, r2, r3, r4) = rounds + {- + map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] + -- [(5 * x + 1) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] + -- [(3 * x + 5) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] + -- [(7 * x) `mod` 16 | x <- [0..15]] + -} + perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] + perm5 _ = error "broke at perm5" + perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] + perm3 _ = error "broke at perm3" + perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] + perm7 _ = error "broke at perm7" + abcd1 = md5_round md5_f abcd0 w r1 + abcd2 = md5_round md5_g abcd1 (perm5 w) r2 + abcd3 = md5_round md5_h abcd2 (perm3 w) r3 + abcd4 = md5_round md5_i abcd3 (perm7 w) r4 + + +-- md5_round does one of the rounds. It takes an auxiliary function and foldls +-- (md5_inner_function f) to repeatedly apply it to the initial state with the +-- correct constants + +md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I + -- for those of you with a copy of + -- the prayer book^W^WRFC) + -> ABCD -- Initial state + -> [Word32] -- The 16 32bit words of input + -> [(Rotation, Word32)] -- The list of 16 rotations and + -- additive constants + -> ABCD -- Resulting state +md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' + where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns + + +-- Apply one of the functions md5_[fghi] and put the new ABCD together + +md5_inner_function :: (XYZ -> Word32) -- Auxiliary function + -> ABCD -- Initial state + -> (Rotation, Word32) -- The rotation and additive + -- constant (X[i] + T[j]) + -> ABCD -- Resulting state +md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) + where mid_a = a + f(b,c,d) + ki + rot_a = rotL mid_a s + a' = b + rot_a + + +-- The 4 auxiliary functions + +md5_f :: XYZ -> Word32 +md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) +{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} + +md5_g :: XYZ -> Word32 +md5_g (x, y, z) = md5_f (z, x, y) +{- was: (x .&. z) .|. (y .&. (complement z)) -} + +md5_h :: XYZ -> Word32 +md5_h (x, y, z) = x `xor` y `xor` z + +md5_i :: XYZ -> Word32 +md5_i (x, y, z) = y `xor` (x .|. (complement z)) + + +-- The magic numbers from the RFC. + +magic_numbers :: ABCD +magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) + + +-- The 4 lists of (rotation, additive constant) tuples, one for each round + +rounds :: ([(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)]) +rounds = (r1, r2, r3, r4) + where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), + (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), + (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), + (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), + (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), + (s14, 0x49b40821)] + r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), + (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), + (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), + (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), + (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), + (s24, 0x8d2a4c8a)] + r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), + (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), + (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), + (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), + (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), + (s34, 0xc4ac5665)] + r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), + (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), + (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), + (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), + (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), + (s44, 0xeb86d391)] + s11 = 7 + s12 = 12 + s13 = 17 + s14 = 22 + s21 = 5 + s22 = 9 + s23 = 14 + s24 = 20 + s31 = 4 + s32 = 11 + s33 = 16 + s34 = 23 + s41 = 6 + s42 = 10 + s43 = 15 + s44 = 21 + + +-- ===================== CONVERSION FUNCTIONS ======================== + + +-- Turn the 4 32 bit words into a string representing the hex number they +-- represent. + +abcd_to_string :: ABCD -> String +abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] + + +-- Split the 32 bit word up, swap the chunks over and convert the numbers +-- to their hex equivalents. + +display_32bits_as_hex :: Word32 -> String +display_32bits_as_hex w = swap_pairs cs + where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] + getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) + swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs + swap_pairs _ = [] + +-- Convert to an integer, performing endianness magic as we go + +abcd_to_integer :: ABCD -> Integer +abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) + + rev_num b * 2^(64 :: Int) + + rev_num c * 2^(32 :: Int) + + rev_num d + +rev_num :: Word32 -> Integer +rev_num i = toInteger j `mod` (2^(32 :: Int)) + -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ + where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) + 0 [0,8,16,24] + +-- Used to convert a 64 byte string to 16 32bit words + +string_to_word32s :: String -> [Word32] +string_to_word32s "" = [] +string_to_word32s ss = this:string_to_word32s ss' + where (s, ss') = splitAt 4 ss + this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s + + +-- Used to convert a list of 512 bools to 16 32bit words + +bools_to_word32s :: [Bool] -> [Word32] +bools_to_word32s [] = [] +bools_to_word32s bs = this:bools_to_word32s rest + where (bs1, bs1') = splitAt 8 bs + (bs2, bs2') = splitAt 8 bs1' + (bs3, bs3') = splitAt 8 bs2' + (bs4, rest) = splitAt 8 bs3' + this = boolss_to_word32 [bs1, bs2, bs3, bs4] + bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 + boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 + + +-- Convert the size into a list of characters used by the len_pad function +-- for strings + +length_to_chars :: Int -> Zord64 -> String +length_to_chars 0 _ = [] +length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) + where this = chr $ fromIntegral $ n .&. 255 + diff --git a/src/Data/Digest/SHA1.hs b/src/Data/Digest/SHA1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digest/SHA1.hs @@ -0,0 +1,136 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.SHA1 +-- Copyright : (c) Dominic Steinitz 2007 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +-- Take [Word8] and return Word160. +-- See for the specification. +-- +----------------------------------------------------------------------------- + +module Data.Digest.SHA1( + Word160(Word160), + hash, + lift2, + toInteger + ) where + +import Data.Bits +import Data.List +import Data.Word +import Data.Array (Array, array, elems, (!)) +import Codec.Utils (i2osp) +import Prelude hiding (toInteger) + +rotL :: Bits b => Int -> b -> b +rotL = flip rotateL + +data Word160 = Word160 {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + deriving (Eq, Show) + +toInteger :: Word160 -> Integer +toInteger (Word160 a b c d e) = let n = fromIntegral e + + (fromIntegral d `shiftL` 32) + + (fromIntegral c `shiftL` 64) + + (fromIntegral b `shiftL` 96) + + (fromIntegral a `shiftL` 128) + in n `seq` n + +lift2 :: (Word32 -> Word32 -> Word32) -> Word160 -> Word160 -> Word160 +lift2 f a@(Word160 x1 x2 x3 x4 x5) b@(Word160 y1 y2 y3 y4 y5) = + Word160 (f x1 y1) (f x2 y2) (f x3 y3) (f x4 y4) (f x5 y5) + +-- 'f' as defined in FIPS 180-4 section 4.1.1 "SHA-1 Functions" +f :: Int -> Word32 -> Word32 -> Word32 -> Word32 +f n x y z + | n <= 19 = (x .&. y) .|. ((complement x) .&. z) + | n <= 39 = x `xor` y `xor` z + | n <= 59 = (x .&. y) .|. (x .&. z) .|. (y .&. z) + | n <= 79 = x `xor` y `xor` z + +-- 'k' as defined in FIPS 180-4 section 4.2.1 "SHA-1 Constants" +k :: Int -> Word32 +k n + | n <= 19 = 0x5a827999 + | n <= 39 = 0x6ed9eba1 + | n <= 59 = 0x8f1bbcdc + | n <= 79 = 0xca62c1d6 + +data AccAndWord160 = AccAndWord160 !Int !Word160 + +-- FIPS-180-4 section 6.1.2 "SHA-1 Hash Computation" +oneBlock :: Word160 -> [Word32] {- Word512 -} -> Word160 +oneBlock ss xs = tt + where + -- message schedule $W_t$ + w :: Array Int Word32 + w = array (0,79) $ zip [0..15] xs ++ [(i, rotL 1 (xxor i)) | i <- [16..79] ] + where + xxor i = w ! (i-3) `xor` w ! (i-8) `xor` w ! (i-14) `xor` w ! (i-16) + + -- step 3 + g (AccAndWord160 n (Word160 a b c d e)) w = + AccAndWord160 (n+1) $ Word160 {- a' = -} ((rotL 5 a) + (f n b c d) + e + w + (k n)) + {- b' = -} a + {- c' = -} (rotL 30 b) + {- d' = -} c + {- e' = -} d + + (AccAndWord160 _ tt) = foldl' g (AccAndWord160 0 ss) (elems w) + +-- initial hash value $H^{(0)}$ as defined in FIPS-180-4 section 5.3.1 +ss :: Word160 +ss = Word160 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 + +-- FIPS-180-4 section 5.1.1 +pad :: [Word8] -> [Word8] +pad = pad' 0 + where pad' l [] = [0x80] ++ ps ++ lb + where pl = (64-(l+9)) `mod` 64 + ps = replicate pl 0x00 + lb = i2osp 8 (8*l) + pad' l (x:xs) = x : (pad' $! l+1) xs -- otherwise (l+1) it will be deferred until replicate + +blockWord8sIn512 :: [Word8] -> [[Word8]] +blockWord8sIn512 = + unfoldr g + where + g [] = Nothing + g xs = Just (splitAt 64 xs) + +fromBytes :: (Num a, Bits a) => [a] -> a +fromBytes input = + let dofb accum [] = accum + dofb accum (x:xs) = dofb ((shiftL accum 8) .|. x) xs + in + dofb 0 input + +blockWord8sIn32 :: [Word8] -> [[Word8]] +blockWord8sIn32 = + unfoldr g + where + g [] = Nothing + g xs = Just (splitAt 4 xs) + +getWord32s :: [Word8] -> [Word32] +getWord32s = + map fromBytes . map (map fromIntegral) . blockWord8sIn32 + +blockWord32sIn512 :: [Word8] -> [[Word32]] +blockWord32sIn512 = (map getWord32s) . blockWord8sIn512 . pad + +-- step 4 of FIPS-180-4 section 6.1.2 SHA-1 Hash Computation +hashOnce :: Word160 -> [Word32] -> Word160 +hashOnce ss a = lift2 (+) ss (oneBlock ss a) + +hash :: [Word8] -> Word160 +hash = foldl' hashOnce ss . blockWord32sIn512 diff --git a/src/Data/Digest/SHA2.hs b/src/Data/Digest/SHA2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digest/SHA2.hs @@ -0,0 +1,252 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.SHA2 +-- Copyright : (c) Russell O'Connor 2006 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Implements SHA-256, SHA-384, SHA-512, and SHA-224 as defined in FIPS 180-2 +-- . +-- +----------------------------------------------------------------------------- + +module Data.Digest.SHA2 + ( -- * SHA-224 + sha224, sha224Ascii, Hash224 + -- * SHA-256 + , sha256, sha256Ascii, Hash256 + -- * SHA-384 + , sha384, sha384Ascii, Hash384 + -- * SHA-512 + , sha512, sha512Ascii, Hash512 + -- * Utilities + , toOctets + ) where + +import Data.Word +import Data.Bits +import Data.List +import Numeric + +ch :: Bits a => a -> a -> a -> a +ch x y z = (x .&. y) `xor` (complement x .&. z) + +maj :: Bits a => a -> a -> a -> a +maj x y z = (x .&. y) `xor` (x .&. z) `xor` (y .&. z) + +class (Num w, Bits w) => ShaData w where + bigSigma0 :: w -> w + bigSigma1 :: w -> w + smallSigma0 :: w -> w + smallSigma1 :: w -> w + ks :: [w] + +instance ShaData Word32 where + bigSigma0 x = rotateR x 2 `xor` rotateR x 13 `xor` rotateR x 22 + bigSigma1 x = rotateR x 6 `xor` rotateR x 11 `xor` rotateR x 25 + smallSigma0 x = rotateR x 7 `xor` rotateR x 18 `xor` shiftR x 3 + smallSigma1 x = rotateR x 17 `xor` rotateR x 19 `xor` shiftR x 10 + ks = + [0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5 + ,0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174 + ,0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da + ,0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967 + ,0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85 + ,0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070 + ,0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3 + ,0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2] + +instance ShaData Word64 where + bigSigma0 x = rotateR x 28 `xor` rotateR x 34 `xor` rotateR x 39 + bigSigma1 x = rotateR x 14 `xor` rotateR x 18 `xor` rotateR x 41 + smallSigma0 x = rotateR x 1 `xor` rotateR x 8 `xor` shiftR x 7 + smallSigma1 x = rotateR x 19 `xor` rotateR x 61 `xor` shiftR x 6 + ks = + [0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f, 0xe9b5dba58189dbbc + ,0x3956c25bf348b538, 0x59f111f1b605d019, 0x923f82a4af194f9b, 0xab1c5ed5da6d8118 + ,0xd807aa98a3030242, 0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2 + ,0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235, 0xc19bf174cf692694 + ,0xe49b69c19ef14ad2, 0xefbe4786384f25e3, 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65 + ,0x2de92c6f592b0275, 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5 + ,0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f, 0xbf597fc7beef0ee4 + ,0xc6e00bf33da88fc2, 0xd5a79147930aa725, 0x06ca6351e003826f, 0x142929670a0e6e70 + ,0x27b70a8546d22ffc, 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df + ,0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6, 0x92722c851482353b + ,0xa2bfe8a14cf10364, 0xa81a664bbc423001, 0xc24b8b70d0f89791, 0xc76c51a30654be30 + ,0xd192e819d6ef5218, 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8 + ,0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99, 0x34b0bcb5e19b48a8 + ,0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb, 0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3 + ,0x748f82ee5defb2fc, 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec + ,0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915, 0xc67178f2e372532b + ,0xca273eceea26619c, 0xd186b8c721c0c207, 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178 + ,0x06f067aa72176fba, 0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b + ,0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc, 0x431d67c49c100d4c + ,0x4cc5d4becb3e42b6, 0x597f299cfc657e2a, 0x5fcb6fab3ad6faec, 0x6c44198c4a475817] + +blockSize = 16 + +----------------------------------------------------------------------------- +-- | 'padding' currently requires that the 'bitSize' of @a@ divide the 'bitSize' +-- of @w@ +----------------------------------------------------------------------------- +padding :: (ShaData w, Bits a, Integral a) => [a] -> [[w]] +padding x = unfoldr block $ paddingHelper x 0 (0::Int) (0::Integer) + where + block [] = Nothing + block x = Just $ splitAt blockSize x + paddingHelper x o on n | on == (bitSize o) = o:paddingHelper x 0 0 n + paddingHelper (x:xs) o on n | on < (bitSize o) = + paddingHelper xs ((shiftL o bs) .|. (fromIntegral x)) (on+bs) $! (n+fromIntegral bs) + where + bs = bitSize x + paddingHelper [] o on n = (shiftL (shiftL o 1 .|. 1) (bso-on-1)): + (zeros ((-(fromIntegral n-on+3*bso)) `mod` (blockSize*bso))) + [fromIntegral (shiftR n bso), fromIntegral n] + where + bso = bitSize o + zeros 0 = id + zeros n | 0 < n = let z=0 in (z:) . (zeros (n-bitSize z)) + +data Hash8 w = Hash8 !w !w !w !w !w !w !w !w deriving (Eq, Ord) + +type Hash256 = Hash8 Word32 +type Hash512 = Hash8 Word64 + +data Hash384 = Hash384 !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 deriving (Eq, Ord) +data Hash224 = Hash224 !Word32 !Word32 !Word32 !Word32 !Word32 !Word32 !Word32 deriving (Eq, Ord) + +instance (Integral a, Show a) => Show (Hash8 a) where + showsPrec _ (Hash8 a b c d e f g h) = + (showHex a) . (' ':) . + (showHex b) . (' ':) . + (showHex c) . (' ':) . + (showHex d) . (' ':) . + (showHex e) . (' ':) . + (showHex f) . (' ':) . + (showHex g) . (' ':) . + (showHex h) + +instance Show Hash384 where + showsPrec _ (Hash384 a b c d e f) = + (showHex a) . (' ':) . + (showHex b) . (' ':) . + (showHex c) . (' ':) . + (showHex d) . (' ':) . + (showHex e) . (' ':) . + (showHex f) + +instance Show Hash224 where + showsPrec _ (Hash224 a b c d e f g) = + (showHex a) . (' ':) . + (showHex b) . (' ':) . + (showHex c) . (' ':) . + (showHex d) . (' ':) . + (showHex e) . (' ':) . + (showHex f) . (' ':) . + (showHex g) + +class (Eq h, Ord h, Show h) => Hash h where + toOctets :: h -> [Word8] + +bitsToOctets x = helper (bitSize x) x [] + where + helper s x r | s <= 0 = r + | otherwise = helper (s-bs) (shiftR x bs) ((fromIntegral x):r) + where + bs = bitSize (head r) + +instance (Integral h, Bits h, Show h) => Hash (Hash8 h) where + toOctets (Hash8 x0 x1 x2 x3 x4 x5 x6 x7) = bitsToOctets =<< [x0, x1, x2, x3, x4, x5, x6, x7] + +instance Hash Hash384 where + toOctets (Hash384 x0 x1 x2 x3 x4 x5) = bitsToOctets =<< [x0, x1, x2, x3, x4, x5] + +instance Hash Hash224 where + toOctets (Hash224 x0 x1 x2 x3 x4 x5 x6) = bitsToOctets =<< [x0, x1, x2, x3, x4, x5, x6] + +shaStep :: (ShaData w) => Hash8 w -> [w] -> Hash8 w +shaStep h m = (foldl' (flip id) h (zipWith mkStep3 ks ws)) `plus` h + where + ws = m++zipWith4 smallSigma (drop (blockSize-2) ws) (drop (blockSize-7) ws) + (drop (blockSize-15) ws) (drop (blockSize-16) ws) + where + smallSigma a b c d = smallSigma1 a + b + smallSigma0 c + d + mkStep3 k w (Hash8 a b c d e f g h) = Hash8 (t1+t2) a b c (d+t1) e f g + where + t1 = h + bigSigma1 e + ch e f g + k + w + t2 = bigSigma0 a + maj a b c + (Hash8 x0 x1 x2 x3 x4 x5 x6 x7) `plus` (Hash8 y0 y1 y2 y3 y4 y5 y6 y7) = + Hash8 (x0+y0) (x1+y1) (x2+y2) (x3+y3) (x4+y4) (x5+y5) (x6+y6) (x7+y7) + +----------------------------------------------------------------------------- +-- | Due to the limitations of 'padding', 'sha' currently requires that the +-- bitSize of @a@ divide the 'bitSize' of @w@ +----------------------------------------------------------------------------- +sha :: (ShaData w, Bits a, Integral a) => Hash8 w -> [a] -> Hash8 w +sha h0 x = foldl' shaStep h0 $ padding x + +stringToOctets :: String -> [Word8] +stringToOctets = map (fromIntegral . fromEnum) + +----------------------------------------------------------------------------- +-- | 'sha256' currently requires that the 'bitSize' of @a@ divide 32 +----------------------------------------------------------------------------- +sha256 :: (Bits a, Integral a) => [a] -> Hash256 +sha256 = sha $ + Hash8 0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a 0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19 + +----------------------------------------------------------------------------- +-- | 'sha384' currently requires that the 'bitSize' of @a@ divide 64 +----------------------------------------------------------------------------- +sha384 :: (Bits a, Integral a) => [a] -> Hash384 +sha384 x = Hash384 x0 x1 x2 x3 x4 x5 + where + Hash8 x0 x1 x2 x3 x4 x5 x6 x7 = flip sha x $ + Hash8 0xcbbb9d5dc1059ed8 0x629a292a367cd507 0x9159015a3070dd17 0x152fecd8f70e5939 + 0x67332667ffc00b31 0x8eb44a8768581511 0xdb0c2e0d64f98fa7 0x47b5481dbefa4fa4 + +----------------------------------------------------------------------------- +-- | 'sha384' currently requires that the 'bitSize' of @a@ divide 64 +----------------------------------------------------------------------------- +sha512 :: (Bits a, Integral a) => [a] -> Hash512 +sha512 = sha $ + Hash8 0x6a09e667f3bcc908 0xbb67ae8584caa73b 0x3c6ef372fe94f82b 0xa54ff53a5f1d36f1 + 0x510e527fade682d1 0x9b05688c2b3e6c1f 0x1f83d9abfb41bd6b 0x5be0cd19137e2179 + +----------------------------------------------------------------------------- +-- | 'sha224' currently requires that the 'bitSize' of @a@ divide 32 +----------------------------------------------------------------------------- +sha224 :: (Bits a, Integral a) => [a] -> Hash224 +sha224 x = Hash224 x0 x1 x2 x3 x4 x5 x6 + where + Hash8 x0 x1 x2 x3 x4 x5 x6 x7 = flip sha x $ + Hash8 0xc1059ed8 0x367cd507 0x3070dd17 0xf70e5939 0xffc00b31 0x68581511 0x64f98fa7 0xbefa4fa4 + +----------------------------------------------------------------------------- +-- | 'sha256Ascii' assumes that all characters of the strings are +-- ISO-latin-1 characters. ie. each characters fits in one octet. +----------------------------------------------------------------------------- +sha256Ascii :: String -> Hash256 +sha256Ascii = sha256 . stringToOctets + +----------------------------------------------------------------------------- +-- | 'sha384Ascii' assumes that all characters of the strings are +-- ISO-latin-1 characters. ie. each characters fits in one octet. +----------------------------------------------------------------------------- +sha384Ascii :: String -> Hash384 +sha384Ascii = sha384 . stringToOctets + +----------------------------------------------------------------------------- +-- | 'sha512Ascii' assumes that all characters of the strings are +-- ISO-latin-1 characters. ie. each characters fits in one octet. +----------------------------------------------------------------------------- +sha512Ascii :: String -> Hash512 +sha512Ascii = sha512 . stringToOctets + +----------------------------------------------------------------------------- +-- | 'sha224Ascii' assumes that all characters of the strings are +-- ISO-latin-1 characters. ie. each characters fits in one octet. +----------------------------------------------------------------------------- +sha224Ascii :: String -> Hash224 +sha224Ascii = sha224 . stringToOctets diff --git a/src/Data/Digest/SHA224.hs b/src/Data/Digest/SHA224.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digest/SHA224.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.SHA224 +-- Copyright : (c) Russell O'Connor 2006 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Takes the SHA2 module supplied and wraps it so it +-- takes [Octet] and returns [Octet] where the length of the result +-- is always 28. +-- and . +-- +----------------------------------------------------------------------------- + +module Data.Digest.SHA224 ( + -- * Function Types + hash) where + +import Data.Digest.SHA2 as SHA2 +import Codec.Utils + +-- | Take [Octet] and return [Octet] according to the standard. +-- The length of the result is always 28 octets or 224 bits as required +-- by the standard. + +hash :: [Octet] -> [Octet] +hash = SHA2.toOctets . SHA2.sha224 diff --git a/src/Data/Digest/SHA256.hs b/src/Data/Digest/SHA256.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digest/SHA256.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.SHA256 +-- Copyright : (c) Russell O'Connor 2006 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Takes the SHA2 module supplied and wraps it so it +-- takes [Octet] and returns [Octet] where the length of the result +-- is always 32. +-- and . +-- +----------------------------------------------------------------------------- + +module Data.Digest.SHA256 ( + -- * Function Types + hash) where + +import Data.Digest.SHA2 as SHA2 +import Codec.Utils + +-- | Take [Octet] and return [Octet] according to the standard. +-- The length of the result is always 32 octets or 256 bits as required +-- by the standard. + +hash :: [Octet] -> [Octet] +hash = SHA2.toOctets . SHA2.sha256 diff --git a/src/Data/Digest/SHA384.hs b/src/Data/Digest/SHA384.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digest/SHA384.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.SHA384 +-- Copyright : (c) Russell O'Connor 2006 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Takes the SHA2 module supplied and wraps it so it +-- takes [Octet] and returns [Octet] where the length of the result +-- is always 48. +-- and . +-- +----------------------------------------------------------------------------- + +module Data.Digest.SHA384 ( + -- * Function Types + hash) where + +import Data.Digest.SHA2 as SHA2 +import Codec.Utils + +-- | Take [Octet] and return [Octet] according to the standard. +-- The length of the result is always 48 octets or 384 bits as required +-- by the standard. + +hash :: [Octet] -> [Octet] +hash = SHA2.toOctets . SHA2.sha384 diff --git a/src/Data/Digest/SHA512.hs b/src/Data/Digest/SHA512.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digest/SHA512.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.SHA512 +-- Copyright : (c) Russell O'Connor 2006 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Takes the SHA2 module supplied and wraps it so it +-- takes [Octet] and returns [Octet] where the length of the result +-- is always 64. +-- and . +-- +----------------------------------------------------------------------------- + +module Data.Digest.SHA512 ( + -- * Function Types + hash) where + +import Data.Digest.SHA2 as SHA2 +import Codec.Utils + +-- | Take [Octet] and return [Octet] according to the standard. +-- The length of the result is always 64 octets or 512 bits as required +-- by the standard. + +hash :: [Octet] -> [Octet] +hash = SHA2.toOctets . SHA2.sha512 diff --git a/src/Data/HMAC.hs b/src/Data/HMAC.hs new file mode 100644 --- /dev/null +++ b/src/Data/HMAC.hs @@ -0,0 +1,118 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.HMAC +-- Copyright : (c) Greg Heartsfield 2007 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Implements HMAC (hashed message authentication code) as defined in FIPS 198 +-- . +-- +----------------------------------------------------------------------------- + +module Data.HMAC( + -- * Function Types + hmac, hmac_sha1, hmac_md5, + -- * Data Types + HashMethod(HashMethod, digest, input_blocksize), + ) where + +import Data.Digest.SHA1 as SHA1 +import Data.Digest.MD5 as MD5 +import Data.Word (Word32) +import Data.Bits (shiftR, xor, bitSize, Bits) +import Codec.Utils (Octet) + +-- | HMAC works over any hash function, which is represented by +-- HashMethod. A hash function and input block size must +-- be specified. + +data HashMethod = + HashMethod { -- | An arbitrary hash function + digest :: [Octet] -> [Octet], + -- | Bit size of an input block to the hash function + input_blocksize :: Int} + +-- Some useful digest functions for use with HMAC. + +sha1_hm = HashMethod (w160_to_w8s . SHA1.hash) 512 +md5_hm = HashMethod MD5.hash 512 + +-- | Compute an HMAC using SHA-1 as the underlying hash function. + +hmac_sha1 :: [Octet] -- ^ Secret key + -> [Octet] -- ^ Message text + -> [Octet] -- ^ Resulting HMAC-SHA1 value +hmac_sha1 = hmac sha1_hm + +-- | Compute an HMAC using MD5 as the underlying hash function. + +hmac_md5 :: [Octet] -- ^ Secret key + -> [Octet] -- ^ Message text + -> [Octet] -- ^ Resulting HMAC-MD5 value +hmac_md5 = hmac md5_hm + +w160_to_w8s :: Word160 -> [Octet] +w160_to_w8s w = concat $ map w32_to_w8s (w160_to_w32s w) + +w160_to_w32s :: Word160 -> [Word32] +w160_to_w32s (Word160 a b c d e) = a : b : c : d : e : [] + +w32_to_w8s :: Word32 -> [Octet] +w32_to_w8s a = (fromIntegral (shiftR a 24)) : + (fromIntegral (shiftR a 16)) : + (fromIntegral (shiftR a 8)) : + (fromIntegral a) : [] + +-- | Generalized function for creating HMACs on a specified +-- hash function. + +hmac :: HashMethod -- ^ Hash function and associated block size + -> [Octet] -- ^ Secret key + -> [Octet] -- ^ Message text + -> [Octet] -- ^ Resulting HMAC value +hmac h uk m = hash (opad ++ (hash (ipad ++ m))) + where hash = digest h + (opad, ipad) = process_pads key + (make_start_pad bs opad_pattern) + (make_start_pad bs ipad_pattern) + bs = input_blocksize h + key = key_from_user h uk + +-- Create a key of the proper size from the user-supplied key. +-- Keys greater than blocksize get hashed and padded with zeroes. +-- Keys same as blocksize are used as is. +-- Keys shorter than blocksize are padding with zeroes. + +key_from_user :: HashMethod -> [Octet] -> [Octet] +key_from_user h uk = + case (compare (bitcount uk) (input_blocksize h)) of + GT -> fill_key ((digest h) uk) + LT -> fill_key uk + EQ -> uk + where fill_key kd = + kd ++ (take (((input_blocksize h) - (bitcount kd)) `div` 8) + (repeat 0x0)) + +-- Create the inner/outer pad values by XOR'ing with the key. + +process_pads :: [Octet] -- Key + -> [Octet] -- opad + -> [Octet] -- ipad + -> ([Octet], [Octet]) -- new opad, new ipad +process_pads ks os is = + unzip $ zipWith3 (\k o i -> (k `xor` o, k `xor` i)) ks os is + +-- Create padding values for a hash of a given bit size. + +make_start_pad :: Int -> Octet -> [Octet] +make_start_pad size pad = take (size `div` (bitSize pad)) $ repeat pad + +-- Padding constants, per the spec. + +opad_pattern = 0x5c :: Octet +ipad_pattern = 0x36 :: Octet + +-- Bit count of byte array. + +bitcount :: [Octet] -> Int +bitcount k = (length k) * (bitSize (head k)) diff --git a/src/Data/LargeWord.hs b/src/Data/LargeWord.hs new file mode 100644 --- /dev/null +++ b/src/Data/LargeWord.hs @@ -0,0 +1,146 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.LargeWord +-- Copyright : (c) Dominic Steinitz 2004 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Stability : experimental +-- Portability : portable +-- +-- Provides Word128, Word192 and Word256 and a way of producing other +-- large words if required. +-- +----------------------------------------------------------------------------- + +module Data.LargeWord + (LargeKey,Word96,Word128,Word160,Word192,Word224,Word256) where + +import Data.Word +import Data.Bits +import Numeric +import Data.Char + +-- Keys have certain capabilities. + +class (Num a) => LargeWord a where + largeWordToInteger :: a -> Integer + integerToLargeWord :: Integer -> a + largeWordPlus :: a -> a -> a + largeWordAnd :: a -> a -> a + largeWordOr :: a -> a -> a + largeWordShift :: a -> Int -> a + largeWordXor :: a -> a -> a + largeBitSize :: a -> Int + +-- Word32 is a key in the obvious way. + +instance LargeWord Word32 where + largeWordToInteger = toInteger + integerToLargeWord = fromInteger + largeWordPlus = (+) + largeWordAnd = (.&.) + largeWordOr = (.|.) + largeWordShift = shift + largeWordXor = xor + largeBitSize = bitSize + +-- Word64 is a key in the obvious way. + +instance LargeWord Word64 where + largeWordToInteger = toInteger + integerToLargeWord = fromInteger + largeWordPlus = (+) + largeWordAnd = (.&.) + largeWordOr = (.|.) + largeWordShift = shift + largeWordXor = xor + largeBitSize = bitSize + +-- Define larger keys from smaller ones. + +data LargeKey a b = LargeKey a b + deriving (Eq, Ord) + +instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => + LargeWord (LargeKey a b) where + largeWordToInteger (LargeKey lo hi) = + largeWordToInteger lo + (2^(bitSize lo)) * largeWordToInteger hi + integerToLargeWord x = + let (h,l) = x `quotRem` (2^(bitSize lo)) + (lo,hi) = (integerToLargeWord l, integerToLargeWord h) in + LargeKey lo hi + largeWordPlus (LargeKey alo ahi) (LargeKey blo bhi) = + LargeKey lo' hi' where + lo' = alo + blo + hi' = ahi + bhi + if lo' < alo then 1 else 0 + largeWordAnd (LargeKey alo ahi) (LargeKey blo bhi) = + LargeKey lo' hi' where + lo' = alo .&. blo + hi' = ahi .&. bhi + largeWordOr (LargeKey alo ahi) (LargeKey blo bhi) = + LargeKey lo' hi' where + lo' = alo .|. blo + hi' = ahi .|. bhi + largeWordXor (LargeKey alo ahi) (LargeKey blo bhi) = + LargeKey lo' hi' where + lo' = alo `xor` blo + hi' = ahi `xor` bhi + largeWordShift w 0 = w + largeWordShift (LargeKey lo hi) x = + if bitSize lo < bitSize hi + then LargeKey (shift lo x) + (shift hi x .|. (shift (conv lo) (x - (bitSize lo)))) + else LargeKey (shift lo x) + (shift hi x .|. (conv $ shift lo (x - (bitSize lo)))) + where conv = integerToLargeWord . largeWordToInteger + largeBitSize ~(LargeKey lo hi) = largeBitSize lo + largeBitSize hi + +instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => Show (LargeKey a b) where + showsPrec p = showInt . largeWordToInteger + +instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => + Num (LargeKey a b) where + (+) = largeWordPlus + fromInteger = integerToLargeWord + +-- Larger keys are instances of Bits provided their constituents are keys. + +instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => + Bits (LargeKey a b) where + (.&.) = largeWordAnd + (.|.) = largeWordOr + xor = largeWordXor + shift = largeWordShift + bitSize = largeBitSize + +instance (Ord a, Bits a, Bounded a, Integral a, LargeWord a, + Bits b, Bounded b, Integral b, LargeWord b) => + Bounded (LargeKey a b) where + minBound = 0 + maxBound = + result where + result = + fromIntegral $ + (1 + fromIntegral (maxBound `asTypeOf` (boflk result)))* + (1 + fromIntegral (maxBound `asTypeOf` (aoflk result))) - 1 + +aoflk :: (LargeKey a b) -> a +aoflk = undefined +boflk :: (LargeKey a b) -> b +boflk = undefined + +instance (Ord a, Bits a, LargeWord a, Ord b, Bits b, LargeWord b) => + Integral (LargeKey a b) where + toInteger = largeWordToInteger + +instance (Ord a, Bits a, LargeWord a, Ord b, Bits b, LargeWord b) => + Real (LargeKey a b) + +instance Enum (LargeKey a b) + +type Word96 = LargeKey Word32 Word64 +type Word128 = LargeKey Word64 Word64 +type Word160 = LargeKey Word32 Word128 +type Word192 = LargeKey Word64 Word128 +type Word224 = LargeKey Word32 Word192 +type Word256 = LargeKey Word64 Word192