An implementation of Heys' Cipher.

HeysCipher.hs

module HeysCipher ( crypt, decrypt, Key ) where

import Data.Word
import Data.Bits
import Test.QuickCheck hiding ( (.&.) )
import Prelude hiding (round)

-- | Represents the key for a cipher, 80-bits.
type Key = (Word16, Word32, Word32)

-- | Encrypt a ByteString with an 80 bit key.
crypt :: Key -> Word16 -> Word16 
crypt key = xor subKey5
            . finalRound subKey4
            . round subKey3 
            . round subKey2 
            . round subKey1 
    where
    (subKey1, subKey2, subKey3, subKey4, subKey5) = subKeys key


-- | Decrypt a ByteString under an 80 bit key.
decrypt :: Key -> Word16 -> Word16
decrypt key = roundInverse subKey1
              . roundInverse subKey2
              . roundInverse subKey3
              . finalRoundInverse subKey4
              . xor subKey5 
    where
    (subKey1, subKey2, subKey3, subKey4, subKey5) = subKeys key
    
roundInverse :: Word16 -> Word16 -> Word16
roundInverse keyBits =
    xor keyBits . runSBoxes sBoxInverse . permutation

round :: Word16 -> Word16 -> Word16
round keyBits = 
    permutation . runSBoxes sBox . xor keyBits


finalRoundInverse :: Word16 -> Word16 -> Word16
finalRoundInverse subKey = xor subKey . runSBoxes sBoxInverse

-- The final round has no permutation on it, to ensure it's bijective.
finalRound :: Word16 -> Word16 -> Word16
finalRound subKey = runSBoxes sBox . xor subKey 

runSBoxes inputBox = joinNibbles . sBoxes . breakNibbles
    where
    sBoxes (s1,s2,s3,s4) = ( inputBox s1, inputBox s2, inputBox s3, inputBox s4 ) 

-- | Maps a 4-bit value non-linearly to another 4-bit value.
sBox :: Word8 -> Word8
sBox 0x0 = 0xE 
sBox 0x1 = 0x4 
sBox 0x2 = 0xD
sBox 0x3 = 0x1
sBox 0x4 = 0x2
sBox 0x5 = 0xF
sBox 0x6 = 0xB
sBox 0x7 = 0x8
sBox 0x8 = 0x3
sBox 0x9 = 0xA
sBox 0xA = 0x6
sBox 0xB = 0xC
sBox 0xC = 0x5
sBox 0xD = 0x9
sBox 0xE = 0x0
sBox 0xF = 0x7

sBoxInverse :: Word8 -> Word8
sBoxInverse  0x0 = 0xE 
sBoxInverse  0x1 = 0x3 
sBoxInverse  0x2 = 0x4
sBoxInverse  0x3 = 0x8
sBoxInverse  0x4 = 0x1
sBoxInverse  0x5 = 0xC
sBoxInverse  0x6 = 0xA
sBoxInverse 0x7 = 0xF
sBoxInverse 0x8 = 0x7
sBoxInverse 0x9 = 0xD
sBoxInverse 0xA = 0x9
sBoxInverse 0xB = 0x6
sBoxInverse 0xC = 0xB
sBoxInverse 0xD = 0x2
sBoxInverse 0xE = 0x0
sBoxInverse 0xF = 0x5

permutation :: Word16 -> Word16
permutation = fromBoolList . permute . toBoolList

fromBoolList :: [Bool] -> Word16
fromBoolList bools =
    foldr (.|.) 0 $ zipWith (\b index -> if b then bit index else 0) bools [15,14..0]

toBoolList :: Word16 -> [Bool]
toBoolList word = map (testBit word) [15,14..0]
               
permute :: [Bool] -> [Bool]
permute [b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15,b16] =
    [b1,b5,b9,b13,b2,b6,b10,b14,b3,b7,b11,b15,b4,b8,b12,b16]

-- This splits a Word16 up into 4 Word8s, each of which only have their 4 LSBs set.
breakNibbles :: Word16 -> (Word8, Word8, Word8, Word8)
breakNibbles bits = ( (fromIntegral :: Word16 -> Word8) $ bits `shiftR` 12
                    , (fromIntegral :: Word16 -> Word8) $ (bits `shiftR` 8) .&. 0xf
                    , (fromIntegral :: Word16 -> Word8) $ (bits `shiftR` 4) .&. 0xf
                    , (fromIntegral :: Word16 -> Word8) $ bits .&. 0xf
                    )

joinNibbles :: (Word8, Word8, Word8, Word8) -> Word16
joinNibbles (a,b,c,d) = (fromIntegral :: Word8 -> Word16) a `shiftL` 12
                    .|. (fromIntegral :: Word8 -> Word16) b `shiftL` 8
                    .|. (fromIntegral :: Word8 -> Word16) c `shiftL` 4
                    .|. (fromIntegral :: Word8 -> Word16) d

-- | Given a key, find the subKeys used for each round.
subKeys :: Key -> (Word16, Word16, Word16, Word16, Word16)
subKeys (sk1, sk2, sk3) = (sk1
                          , fst $ split sk2
                          , snd $ split sk2
                          , fst $ split sk3
                          , snd $ split sk3
                          )
                        where 
                            split :: Word32 -> (Word16, Word16)
                            split ks = ( (fromIntegral :: Word32 -> Word16) $ ks `shiftR` 16 
                                       , (fromIntegral :: Word32 -> Word16) $ ks .&. 0xffff)

-- | Tests.
-- This checks that the cipher decrypts the same as it encrypts.
prop_consistent :: Key -> Word16 -> Bool 
prop_consistent key input = (decrypt key . crypt key) input == input

prop_from_to_bools :: Key -> Word16 -> Bool
prop_from_to_bools _ input = (fromBoolList . toBoolList) input == input

prop_sBox :: Key -> Word16 -> Bool
prop_sBox _ input = sBox i /= i
    where
    i = (fromIntegral :: Word16 -> Word8) input `shiftR` 4

prop_sBox_bijective :: Key -> Word16 -> Bool
prop_sBox_bijective _ input = (sBoxInverse . sBox) i == i
    where
    i = (fromIntegral :: Word16 -> Word8) input .&. 0xf

prop_join_break_nibbles :: Key -> Word16 -> Bool
prop_join_break_nibbles _ i = (joinNibbles . breakNibbles) i == i

prop_permutation_bitsize :: Key -> Word16 -> Bool
prop_permutation_bitsize _ i = bitSize i == bitSize (permutation i)

prop_permutation :: Key -> Word16 -> Bool
prop_permutation _ i = (permutation . permutation $ i) == i 

prop_key_schedule :: Key -> Word16 -> Bool
prop_key_schedule (k1,k2,k3) input = all id [ k1 == pk1
                                            , k2 == pk2
                                            , k3 == pk3 
                                            ]
                                where
                                pk1 = s1
                                pk2 = ((fromIntegral :: Word16 -> Word32) s2 `shiftL` 16) .|. 
                                        (fromIntegral :: Word16 -> Word32) s3
                                pk3 = ((fromIntegral :: Word16 -> Word32) s4 `shiftL` 16) .|. 
                                        (fromIntegral :: Word16 -> Word32) s5
                                (s1,s2,s3,s4,s5) = subKeys (k1,k2,k3)


args = Args { replay = Nothing
            , maxSuccess = 1000
            , maxDiscard = 1
            , maxSize = 10000
            , chatty = True
            }


main = mapM_ (quickCheckWith args) 
        [ prop_consistent 
        , prop_from_to_bools
        , prop_permutation
        , prop_sBox
        , prop_join_break_nibbles
        , prop_key_schedule
        , prop_permutation_bitsize
        , prop_sBox_bijective
        ];