1-- | 2-- Module : Crypto.Cipher.Blowfish.Primitive 3-- License : BSD-style 4-- Stability : experimental 5-- Portability : Good 6 7-- Rewritten by Vincent Hanquez (c) 2015 8-- Lars Petersen (c) 2018 9-- 10-- Original code: 11-- Crypto.Cipher.Blowfish.Primitive, copyright (c) 2012 Stijn van Drongelen 12-- based on: BlowfishAux.hs (C) 2002 HardCore SoftWare, Doug Hoyte 13-- (as found in Crypto-4.2.4) 14{-# LANGUAGE BangPatterns #-} 15module Crypto.Cipher.Blowfish.Primitive 16 ( Context 17 , initBlowfish 18 , encrypt 19 , decrypt 20 , KeySchedule 21 , createKeySchedule 22 , freezeKeySchedule 23 , expandKey 24 , expandKeyWithSalt 25 , cipherBlockMutable 26 ) where 27 28import Control.Monad (when) 29import Data.Bits 30import Data.Memory.Endian 31import Data.Word 32 33import Crypto.Cipher.Blowfish.Box 34import Crypto.Error 35import Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess) 36import qualified Crypto.Internal.ByteArray as B 37import Crypto.Internal.Compat 38import Crypto.Internal.Imports 39import Crypto.Internal.WordArray 40 41newtype Context = Context Array32 42 43instance NFData Context where 44 rnf a = a `seq` () 45 46-- | Initialize a new Blowfish context from a key. 47-- 48-- key needs to be between 0 and 448 bits. 49initBlowfish :: ByteArrayAccess key => key -> CryptoFailable Context 50initBlowfish key 51 | B.length key > (448 `div` 8) = CryptoFailed CryptoError_KeySizeInvalid 52 | otherwise = CryptoPassed $ unsafeDoIO $ do 53 ks <- createKeySchedule 54 expandKey ks key 55 freezeKeySchedule ks 56 57-- | Get an immutable Blowfish context by freezing a mutable key schedule. 58freezeKeySchedule :: KeySchedule -> IO Context 59freezeKeySchedule (KeySchedule ma) = Context `fmap` mutableArray32Freeze ma 60 61expandKey :: (ByteArrayAccess key) => KeySchedule -> key -> IO () 62expandKey ks@(KeySchedule ma) key = do 63 when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do 64 mutableArrayWriteXor32 ma i l 65 mutableArrayWriteXor32 ma (i + 1) r 66 when (i + 2 < 18) (cont a0 a1) 67 loop 0 0 0 68 where 69 loop i l r = do 70 n <- cipherBlockMutable ks (fromIntegral l `shiftL` 32 .|. fromIntegral r) 71 let nl = fromIntegral (n `shiftR` 32) 72 nr = fromIntegral (n .&. 0xffffffff) 73 mutableArrayWrite32 ma i nl 74 mutableArrayWrite32 ma (i + 1) nr 75 when (i < 18 + 1024) (loop (i + 2) nl nr) 76 77expandKeyWithSalt :: (ByteArrayAccess key, ByteArrayAccess salt) 78 => KeySchedule 79 -> key 80 -> salt 81 -> IO () 82expandKeyWithSalt ks key salt 83 | B.length salt == 16 = expandKeyWithSalt128 ks key (fromBE $ B.toW64BE salt 0) (fromBE $ B.toW64BE salt 8) 84 | otherwise = expandKeyWithSaltAny ks key salt 85 86expandKeyWithSaltAny :: (ByteArrayAccess key, ByteArrayAccess salt) 87 => KeySchedule -- ^ The key schedule 88 -> key -- ^ The key 89 -> salt -- ^ The salt 90 -> IO () 91expandKeyWithSaltAny ks@(KeySchedule ma) key salt = do 92 when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do 93 mutableArrayWriteXor32 ma i l 94 mutableArrayWriteXor32 ma (i + 1) r 95 when (i + 2 < 18) (cont a0 a1) 96 -- Go through the entire key schedule overwriting the P-Array and S-Boxes 97 when (B.length salt > 0) $ iterKeyStream salt 0 0 $ \i l r a0 a1 cont-> do 98 let l' = xor l a0 99 let r' = xor r a1 100 n <- cipherBlockMutable ks (fromIntegral l' `shiftL` 32 .|. fromIntegral r') 101 let nl = fromIntegral (n `shiftR` 32) 102 nr = fromIntegral (n .&. 0xffffffff) 103 mutableArrayWrite32 ma i nl 104 mutableArrayWrite32 ma (i + 1) nr 105 when (i + 2 < 18 + 1024) (cont nl nr) 106 107expandKeyWithSalt128 :: ByteArrayAccess ba 108 => KeySchedule -- ^ The key schedule 109 -> ba -- ^ The key 110 -> Word64 -- ^ First word of the salt 111 -> Word64 -- ^ Second word of the salt 112 -> IO () 113expandKeyWithSalt128 ks@(KeySchedule ma) key salt1 salt2 = do 114 when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do 115 mutableArrayWriteXor32 ma i l 116 mutableArrayWriteXor32 ma (i + 1) r 117 when (i + 2 < 18) (cont a0 a1) 118 -- Go through the entire key schedule overwriting the P-Array and S-Boxes 119 loop 0 salt1 salt1 salt2 120 where 121 loop i input slt1 slt2 122 | i == 1042 = return () 123 | otherwise = do 124 n <- cipherBlockMutable ks input 125 let nl = fromIntegral (n `shiftR` 32) 126 nr = fromIntegral (n .&. 0xffffffff) 127 mutableArrayWrite32 ma i nl 128 mutableArrayWrite32 ma (i+1) nr 129 loop (i+2) (n `xor` slt2) slt2 slt1 130 131-- | Encrypt blocks 132-- 133-- Input need to be a multiple of 8 bytes 134encrypt :: ByteArray ba => Context -> ba -> ba 135encrypt ctx ba 136 | B.length ba == 0 = B.empty 137 | B.length ba `mod` 8 /= 0 = error "invalid data length" 138 | otherwise = B.mapAsWord64 (cipherBlock ctx False) ba 139 140-- | Decrypt blocks 141-- 142-- Input need to be a multiple of 8 bytes 143decrypt :: ByteArray ba => Context -> ba -> ba 144decrypt ctx ba 145 | B.length ba == 0 = B.empty 146 | B.length ba `mod` 8 /= 0 = error "invalid data length" 147 | otherwise = B.mapAsWord64 (cipherBlock ctx True) ba 148 149-- | Encrypt or decrypt a single block of 64 bits. 150-- 151-- The inverse argument decides whether to encrypt or decrypt. 152cipherBlock :: Context -> Bool -> Word64 -> Word64 153cipherBlock (Context ar) inverse input = doRound input 0 154 where 155 -- | Transform the input over 16 rounds 156 doRound :: Word64 -> Int -> Word64 157 doRound !i roundIndex 158 | roundIndex == 16 = 159 let final = (fromIntegral (p 16) `shiftL` 32) .|. fromIntegral (p 17) 160 in rotateL (i `xor` final) 32 161 | otherwise = 162 let newr = fromIntegral (i `shiftR` 32) `xor` p roundIndex 163 newi = ((i `shiftL` 32) `xor` f newr) .|. fromIntegral newr 164 in doRound newi (roundIndex+1) 165 166 -- | The Blowfish Feistel function F 167 f :: Word32 -> Word64 168 f t = let a = s0 (0xff .&. (t `shiftR` 24)) 169 b = s1 (0xff .&. (t `shiftR` 16)) 170 c = s2 (0xff .&. (t `shiftR` 8)) 171 d = s3 (0xff .&. t) 172 in fromIntegral (((a + b) `xor` c) + d) `shiftL` 32 173 174 -- | S-Box arrays, each containing 256 32-bit words 175 -- The first 18 words contain the P-Array of subkeys 176 s0, s1, s2, s3 :: Word32 -> Word32 177 s0 i = arrayRead32 ar (fromIntegral i + 18) 178 s1 i = arrayRead32 ar (fromIntegral i + 274) 179 s2 i = arrayRead32 ar (fromIntegral i + 530) 180 s3 i = arrayRead32 ar (fromIntegral i + 786) 181 p :: Int -> Word32 182 p i | inverse = arrayRead32 ar (17 - i) 183 | otherwise = arrayRead32 ar i 184 185-- | Blowfish encrypt a Word using the current state of the key schedule 186cipherBlockMutable :: KeySchedule -> Word64 -> IO Word64 187cipherBlockMutable (KeySchedule ma) input = doRound input 0 188 where 189 -- | Transform the input over 16 rounds 190 doRound !i roundIndex 191 | roundIndex == 16 = do 192 pVal1 <- mutableArrayRead32 ma 16 193 pVal2 <- mutableArrayRead32 ma 17 194 let final = (fromIntegral pVal1 `shiftL` 32) .|. fromIntegral pVal2 195 return $ rotateL (i `xor` final) 32 196 | otherwise = do 197 pVal <- mutableArrayRead32 ma roundIndex 198 let newr = fromIntegral (i `shiftR` 32) `xor` pVal 199 newr' <- f newr 200 let newi = ((i `shiftL` 32) `xor` newr') .|. fromIntegral newr 201 doRound newi (roundIndex+1) 202 203 -- | The Blowfish Feistel function F 204 f :: Word32 -> IO Word64 205 f t = do 206 a <- s0 (0xff .&. (t `shiftR` 24)) 207 b <- s1 (0xff .&. (t `shiftR` 16)) 208 c <- s2 (0xff .&. (t `shiftR` 8)) 209 d <- s3 (0xff .&. t) 210 return (fromIntegral (((a + b) `xor` c) + d) `shiftL` 32) 211 212 -- | S-Box arrays, each containing 256 32-bit words 213 -- The first 18 words contain the P-Array of subkeys 214 s0, s1, s2, s3 :: Word32 -> IO Word32 215 s0 i = mutableArrayRead32 ma (fromIntegral i + 18) 216 s1 i = mutableArrayRead32 ma (fromIntegral i + 274) 217 s2 i = mutableArrayRead32 ma (fromIntegral i + 530) 218 s3 i = mutableArrayRead32 ma (fromIntegral i + 786) 219 220iterKeyStream :: (ByteArrayAccess x) 221 => x 222 -> Word32 223 -> Word32 224 -> (Int -> Word32 -> Word32 -> Word32 -> Word32 -> (Word32 -> Word32 -> IO ()) -> IO ()) 225 -> IO () 226iterKeyStream x a0 a1 g = f 0 0 a0 a1 227 where 228 len = B.length x 229 -- Avoiding the modulo operation when interating over the ring 230 -- buffer is assumed to be more efficient here. All other 231 -- implementations do this, too. The branch prediction shall prefer 232 -- the branch with the increment. 233 n j = if j + 1 >= len then 0 else j + 1 234 f i j0 b0 b1 = g i l r b0 b1 (f (i + 2) j8) 235 where 236 j1 = n j0 237 j2 = n j1 238 j3 = n j2 239 j4 = n j3 240 j5 = n j4 241 j6 = n j5 242 j7 = n j6 243 j8 = n j7 244 x0 = fromIntegral (B.index x j0) 245 x1 = fromIntegral (B.index x j1) 246 x2 = fromIntegral (B.index x j2) 247 x3 = fromIntegral (B.index x j3) 248 x4 = fromIntegral (B.index x j4) 249 x5 = fromIntegral (B.index x j5) 250 x6 = fromIntegral (B.index x j6) 251 x7 = fromIntegral (B.index x j7) 252 l = shiftL x0 24 .|. shiftL x1 16 .|. shiftL x2 8 .|. x3 253 r = shiftL x4 24 .|. shiftL x5 16 .|. shiftL x6 8 .|. x7 254{-# INLINE iterKeyStream #-} 255-- Benchmarking shows that GHC considers this function too big to inline 256-- although forcing inlining causes an actual improvement. 257-- It is assumed that all function calls (especially the continuation) 258-- collapse into a tight loop after inlining. 259