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