1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE RecordWildCards #-}
module Crypto.Cipher.AES128
( -- * Key types with crypto-api instances
AESKey128, AESKey192, AESKey256
, BlockCipher(..), buildKeyIO, zeroIV
-- * GCM Operations
, makeGCMCtx, aesKeyToGCM, GCMCtx, AuthTag(..), AES_GCM
, Crypto.Cipher.AES128.encryptGCM
, Crypto.Cipher.AES128.decryptGCM
) where
import Crypto.Cipher.AES128.Internal as I
import Crypto.Classes
import Data.Function (on)
import Control.Monad (when)
import Data.Serialize
import Data.Tagged
import Data.Word (Word8)
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc as F
import System.IO.Unsafe
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Unsafe as B
instance Serialize AESKey128 where
put k = do
let RKey128 l h = (rawKey128 k)
putWord64be h
putWord64be l
get = do
b <- getByteString 16
case buildKey b of
Nothing -> fail "Invalid key on 'get'"
Just k -> return k
instance Serialize AESKey192 where
put k = do
let RKey192 a b c = (rawKey192 k)
putWord64be c
putWord64be b
putWord64be a
get = do
b <- getByteString 24
case buildKey b of
Nothing -> fail "Invalid key on 'get'"
Just k -> return k
instance Serialize AESKey256 where
put k = do
let RKey256 a b c d = (rawKey256 k)
putWord64be d
putWord64be c
putWord64be b
putWord64be a
get = do
b <- getByteString 32
case buildKey b of
Nothing -> fail "Invalid key on 'get'"
Just k -> return k
instance BlockCipher AESKey128 where
blockSize = Tagged 128
keyLength = Tagged 128
buildKey bs
| B.length bs >= 16 = unsafePerformIO $
B.unsafeUseAsCString bs (\p -> generateKey128 (castPtr p))
| otherwise = Nothing
encryptBlock k b = unsafePerformIO $ do
B.unsafeUseAsCStringLen b $ \(inP,len) -> do
B.create (B.length b) $ \outP -> do
encryptECB k (castPtr outP) (castPtr inP) (len`div`blkSize)
decryptBlock k b = unsafePerformIO $ do
B.unsafeUseAsCStringLen b $ \(inP,len) -> do
B.create (B.length b) $ \outP -> do
decryptECB k (castPtr outP) (castPtr inP) (len`div`blkSize)
ecb = encryptBlock
unEcb = decryptBlock
ctr k (IV bs) pt = unsafePerformIO $ do
B.unsafeUseAsCStringLen pt $ \(inP, len) -> do
B.unsafeUseAsCStringLen bs $ \(ivP, ivLen) -> do
when (ivLen /= (blockSizeBytes .::. k))
(error "Cipher-AES128: IV wrong length! They type system would have/should have caught this if you didn't use the IV constructor...")
newIVFP <- B.mallocByteString ivLen
ct <- B.create len $ \outP -> withForeignPtr newIVFP $ \newIVP -> do
encryptCTR k (castPtr ivP) (castPtr newIVP) (castPtr outP) (castPtr inP) len
let newIV = B.fromForeignPtr newIVFP 0 ivLen
return (ct,IV newIV)
{-# INLINE ctr #-}
unCtr = ctr
blkSize :: Int
blkSize = 16
instance BlockCipher AESKey192 where
blockSize = Tagged 128
keyLength = Tagged 192
buildKey bs
| B.length bs >= 16 = unsafePerformIO $
B.unsafeUseAsCString bs (\p -> generateKey192 (castPtr p))
| otherwise = Nothing
encryptBlock k b = unsafePerformIO $ do
B.unsafeUseAsCStringLen b $ \(inP,len) -> do
B.create (B.length b) $ \outP -> do
encryptECB k (castPtr outP) (castPtr inP) (len`div`blkSize)
decryptBlock k b = unsafePerformIO $ do
B.unsafeUseAsCStringLen b $ \(inP,len) -> do
B.create (B.length b) $ \outP -> do
decryptECB k (castPtr outP) (castPtr inP) (len`div`blkSize)
ecb = encryptBlock
unEcb = decryptBlock
ctr k (IV bs) pt = unsafePerformIO $ do
B.unsafeUseAsCStringLen pt $ \(inP, len) -> do
B.unsafeUseAsCStringLen bs $ \(ivP, ivLen) -> do
when (ivLen /= (blockSizeBytes .::. k))
(error "Cipher-AES128: IV wrong length! They type system would have/should have caught this if you didn't use the IV constructor...")
newIVFP <- B.mallocByteString ivLen
ct <- B.create len $ \outP -> withForeignPtr newIVFP $ \newIVP -> do
encryptCTR k (castPtr ivP) (castPtr newIVP) (castPtr outP) (castPtr inP) len
let newIV = B.fromForeignPtr newIVFP 0 ivLen
return (ct,IV newIV)
{-# INLINE ctr #-}
unCtr = ctr
instance BlockCipher AESKey256 where
blockSize = Tagged 128
keyLength = Tagged 256
buildKey bs
| B.length bs >= 16 = unsafePerformIO $
B.unsafeUseAsCString bs (\p -> generateKey256 (castPtr p))
| otherwise = Nothing
encryptBlock k b = unsafePerformIO $ do
B.unsafeUseAsCStringLen b $ \(inP,len) -> do
B.create (B.length b) $ \outP -> do
encryptECB k (castPtr outP) (castPtr inP) (len`div`blkSize)
decryptBlock k b = unsafePerformIO $ do
B.unsafeUseAsCStringLen b $ \(inP,len) -> do
B.create (B.length b) $ \outP -> do
decryptECB k (castPtr outP) (castPtr inP) (len`div`blkSize)
ecb = encryptBlock
unEcb = decryptBlock
ctr k (IV bs) pt = unsafePerformIO $ do
B.unsafeUseAsCStringLen pt $ \(inP, len) -> do
B.unsafeUseAsCStringLen bs $ \(ivP, ivLen) -> do
when (ivLen /= (blockSizeBytes .::. k))
(error "Cipher-AES128: IV wrong length! They type system would have/should have caught this if you didn't use the IV constructor...")
newIVFP <- B.mallocByteString ivLen
ct <- B.create len $ \outP -> withForeignPtr newIVFP $ \newIVP -> do
encryptCTR k (castPtr ivP) (castPtr newIVP) (castPtr outP) (castPtr inP) len
let newIV = B.fromForeignPtr newIVFP 0 ivLen
return (ct,IV newIV)
{-# INLINE ctr #-}
unCtr = ctr
-- GCM Routines
maxTagLen :: Int
maxTagLen = 16
data AuthTag = AuthTag { unAuthTag :: ByteString }
-- | A tuple of key and precomputed data for use by GCM
data GCMCtx k = GCMCtx { gcmkey :: k
, gcmpc :: GCMpc
}
instance Eq AuthTag where
(==) = constTimeEq `on` unAuthTag
-- A super-class indicating which keys can be used with GCMCtx.
class (BlockCipher k, GetExpanded k) => AES_GCM k where
instance AES_GCM AESKey128
instance AES_GCM AESKey192
instance AES_GCM AESKey256
-- | Given key material produce a context useful for GCM operations
makeGCMCtx :: AES_GCM k => ByteString -> Maybe (GCMCtx k)
makeGCMCtx = fmap aesKeyToGCM . buildKey
-- | Given an AESKey produce a GCM Context.
aesKeyToGCM :: AES_GCM k => k -> GCMCtx k
aesKeyToGCM k = GCMCtx k (I.precomputeGCMdata k)
-- |Encrypts multiple-of-block-sized input, returning a bytestring and tag.
encryptGCM :: AES_GCM k
=> GCMCtx k
-> ByteString -- ^ IV
-> ByteString -- ^ Plaintext
-> ByteString -- ^ AAD
-> (ByteString, AuthTag)
encryptGCM key iv pt aad = unsafePerformIO $ do
B.unsafeUseAsCString pt $ \ptPtr -> do
B.unsafeUseAsCString iv $ \ivPtr -> do
B.unsafeUseAsCString aad $ \aadPtr -> do
ctPtr <- F.mallocBytes (B.length pt)
tagPtr <- F.mallocBytes maxTagLen
encryptGCMPtr key
(castPtr ivPtr) (B.length iv)
(castPtr ptPtr) (B.length pt)
(castPtr aadPtr) (B.length aad)
(castPtr ctPtr)
(castPtr tagPtr)
ctBS <- B.unsafePackMallocCStringLen (castPtr ctPtr, B.length pt)
tagBS <- B.unsafePackMallocCStringLen (castPtr tagPtr, maxTagLen)
return (ctBS, AuthTag tagBS)
-- Encrypts multiple-of-block-sized input, filling a pointer with the
-- result of [ctr, ct, tag].
encryptGCMPtr :: AES_GCM k
=> GCMCtx k
-> Ptr Word8 -- ^ IV
-> Int -- ^ IV Length
-> Ptr Word8 -- ^ Plaintext buffer
-> Int -- ^ Plaintext length
-> Ptr Word8 -- ^ AAD buffer
-> Int -- ^ AAD Length
-> Ptr Word8 -- ^ ciphertext buffer (at least encBytes large)
-> Ptr Word8 -- ^ Tag buffer (always allocated to max length)
-> IO ()
encryptGCMPtr (GCMCtx {..}) ivPtr ivLen
ptPtr ptLen
aadPtr aadLen
ctPtr
tagPtr =
do I.encryptGCM gcmkey gcmpc
(castPtr ivPtr) (fromIntegral ivLen)
(castPtr aadPtr) (fromIntegral aadLen)
(castPtr ptPtr) (fromIntegral ptLen)
(castPtr ctPtr)
(castPtr tagPtr)
-- | Decrypts multiple-of-block-sized input, returing a bytestring of the
-- [ctr, ct, tag].
decryptGCM :: AES_GCM k
=> GCMCtx k
-> ByteString -- ^ IV
-> ByteString -- ^ Ciphertext
-> ByteString -- ^ AAD
-> (ByteString, AuthTag)
-- ^ Plaintext and incremented context (or an error)
decryptGCM gcmdata iv ct aad = unsafePerformIO $ do
let ivLen = B.length iv
tagLen = maxTagLen
ctLen = B.length ct
B.unsafeUseAsCString iv $ \ivPtr -> do
B.unsafeUseAsCString ct $ \ctPtr -> do
B.unsafeUseAsCString aad $ \aadPtr -> do
tagPtr <- F.mallocBytes tagLen
ptPtr <- F.mallocBytes ctLen
decryptGCM_ptr gcmdata
(castPtr ivPtr) ivLen
(castPtr ctPtr) ctLen
(castPtr aadPtr) (B.length aad)
(castPtr ptPtr)
(castPtr tagPtr)
tagBS <- B.unsafePackMallocCStringLen (castPtr tagPtr,tagLen)
ptBS <- B.unsafePackMallocCStringLen (castPtr ptPtr, ctLen)
return (ptBS, AuthTag tagBS)
decryptGCM_ptr :: AES_GCM k
=> GCMCtx k
-> Ptr Word8 -> Int -- IV
-> Ptr Word8 -> Int -- CT
-> Ptr Word8 -> Int -- AAD
-> Ptr Word8 -- Plaintext
-> Ptr Word8 -- Tag
-> IO ()
decryptGCM_ptr (GCMCtx {..})
ivPtr ivLen
ctPtr ctLen
aadPtr aadLen
ptPtr
tagPtr =
I.decryptGCM gcmkey gcmpc
ivPtr (fromIntegral ivLen)
aadPtr (fromIntegral aadLen)
ctPtr (fromIntegral ctLen)
ptPtr
tagPtr
|