module Codec.Encryption.OpenPGP.SecretKey (
decryptPrivateKey
, encryptPrivateKey
, encryptPrivateKeyIO
, reencryptSecretKeyIO
) where
import Codec.Encryption.OpenPGP.Internal.HOBlockCipher
import Codec.Encryption.OpenPGP.Types
import Codec.Encryption.OpenPGP.BlockCipher (withSymmetricCipher, keySize)
import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce)
import Codec.Encryption.OpenPGP.Serialize (getSecretKey)
import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key)
import qualified Crypto.Hash as CH
import Crypto.Number.ModArithmetic (inverse)
import Crypto.Random.EntropyPool (createEntropyPool, getEntropyFrom)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Binary (put)
import Data.Binary.Get (getRemainingLazyByteString, getWord16be, runGetOrFail)
import Data.Binary.Put (runPut)
import Data.Bifunctor (bimap)
import qualified Crypto.PubKey.RSA as R
saBlockSize :: SymmetricAlgorithm -> Int
saBlockSize sa = either (const 0) id (withSymmetricCipher sa B.empty (Right . blockSize))
decryptPrivateKey :: (PKPayload, SKAddendum) -> BL.ByteString -> SKAddendum
decryptPrivateKey (pkp, ska@SUS16bit{}) pp = either (error "could not decrypt SUS16bit") id (decryptSKA (pkp, ska) pp)
decryptPrivateKey (pkp, ska@SUSSHA1{}) pp = either (error "could not decrypt SUSSHA1") id (decryptSKA (pkp, ska) pp)
decryptPrivateKey (_, SUSym{}) _ = error "SUSym key decryption not implemented"
decryptPrivateKey (_, ska@SUUnencrypted{}) _ = ska
decryptSKA :: (PKPayload, SKAddendum) -> BL.ByteString -> Either String SKAddendum
decryptSKA (pkp, SUS16bit sa s2k iv payload) pp = do
let key = skesk2Key (SKESK 4 sa s2k Nothing) pp
p <- decryptNoNonce sa iv (BL.toStrict payload) key
(s, cksum) <- getSecretKeyAndChecksum p
let checksum = cksum
return $ SUUnencrypted s checksum
where
getSecretKeyAndChecksum p = bimap (\(_,_,x) -> x) (\(_,_,x) -> x) (runGetOrFail (getSecretKey pkp >>= \sk -> getWord16be >>= \csum -> return (sk, csum)) (BL.fromStrict p))
decryptSKA (pkp, SUSSHA1 sa s2k iv payload) pp = do
let key = skesk2Key (SKESK 4 sa s2k Nothing) pp
p <- decryptNoNonce sa iv (BL.toStrict payload) key
(s, cksum) <- getSecretKeyAndChecksum p
let checksum = sum . map fromIntegral . B.unpack . B.take (B.length p - 20) $ p
return $ SUUnencrypted s checksum
where
getSecretKeyAndChecksum p = bimap (\(_,_,x) -> x) (\(_,_,x) -> x) (runGetOrFail (getSecretKey pkp >>= \sk -> getRemainingLazyByteString >>= \csum -> return (sk, csum)) (BL.fromStrict p))
decryptSKA _ _ = Left "Unexpected codepath"
encryptPrivateKeyIO :: SKAddendum -> BL.ByteString -> IO SKAddendum
encryptPrivateKeyIO ska pp = saltiv >>= \(s,i) -> return (encryptPrivateKey s (IV i) ska pp)
where
saltiv = do
ep <- createEntropyPool
bb <- getEntropyFrom ep (8 + saBlockSize AES256)
return $ B.splitAt 8 bb
encryptPrivateKey :: B.ByteString -> IV -> SKAddendum -> BL.ByteString -> SKAddendum
encryptPrivateKey _ _ ska@SUS16bit{} _ = ska
encryptPrivateKey _ _ ska@SUSSHA1{} _ = ska
encryptPrivateKey _ _ ska@SUSym{} _ = ska
encryptPrivateKey salt iv (SUUnencrypted skey _) pp = SUSSHA1 AES256 s2k iv (BL.fromStrict (encryptSKey skey s2k iv pp))
where
s2k = IteratedSalted SHA512 (Salt salt) 12058624
encryptSKey :: SKey -> S2K -> IV -> BL.ByteString -> B.ByteString
encryptSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) s2k iv pp = either error id (encryptNoNonce AES256 s2k iv (BL.toStrict payload) key)
where
key = string2Key s2k (keySize AES256) pp
algospecific = runPut $ put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)
cksum = CH.hashlazy algospecific :: CH.Digest CH.SHA1
payload = algospecific `BL.append` BL.fromStrict (BA.convert cksum)
Just u = inverse p q
encryptSKey _ _ _ _ = error "Non-RSA keytypes not handled yet"
reencryptSecretKeyIO :: SecretKey -> BL.ByteString -> IO SecretKey
reencryptSecretKeyIO sk pp = encryptPrivateKeyIO (_secretKeySKAddendum sk) pp >>= \n -> return sk { _secretKeySKAddendum = n }