module Codec.Encryption.OpenPGP.SecretKey (
decryptPrivateKey
, encryptPrivateKey
, encryptPrivateKeyIO
, reencryptSecretKeyIO
) where
import Codec.Encryption.OpenPGP.Types
import Codec.Encryption.OpenPGP.BlockCipher (saBlockSize, keySize)
import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce)
import Codec.Encryption.OpenPGP.Serialize (getSecretKey)
import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key)
import Control.Monad ((>=>))
import qualified Crypto.Hash.SHA1 as SHA1
import Crypto.Random (createEntropyPool, cprgCreate, cprgGenerateWithEntropy, SystemRNG)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Serialize (runGet, runPut, put)
import Data.Serialize.Get (getBytes, remaining, getWord16be)
import qualified Crypto.PubKey.RSA as R
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 payload key
(s, cksum) <- runGet (getSecretKey pkp >>= \sk -> getWord16be >>= \csum -> return (sk, csum)) p
let checksum = cksum
return $ SUUnencrypted s checksum
decryptSKA (pkp, SUSSHA1 sa s2k iv payload) pp = do
let key = skesk2Key (SKESK 4 sa s2k Nothing) pp
p <- decryptNoNonce sa iv payload key
(s, cksum) <- runGet (getSecretKey pkp >>= \sk -> remaining >>= (getBytes >=> \csum -> return (sk, csum))) p
let checksum = sum . map fromIntegral . B.unpack . B.take (B.length p 20) $ p
return $ SUUnencrypted s checksum
decryptSKA _ _ = fail "Unexpected codepath"
encryptPrivateKeyIO :: SKAddendum -> BL.ByteString -> IO SKAddendum
encryptPrivateKeyIO ska pp = saltiv >>= \(s,i) -> return (encryptPrivateKey s i ska pp)
where
saltiv = do
ep <- createEntropyPool
let gen = cprgCreate ep :: SystemRNG
bb = fst (cprgGenerateWithEntropy (8 + saBlockSize AES256) gen)
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 (encryptSKey skey s2k iv pp)
where
s2k = IteratedSalted SHA512 salt 12058624
encryptSKey :: SKey -> S2K -> IV -> BL.ByteString -> B.ByteString
encryptSKey (RSAPrivateKey (R.PrivateKey _ d p q _ _ _)) s2k iv pp = either error id (encryptNoNonce AES256 s2k iv payload key)
where
key = string2Key s2k (keySize AES256) pp
algospecific = runPut $ put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)
cksum = SHA1.hash algospecific
payload = algospecific `B.append` cksum
u = inverse q p
encryptSKey _ _ _ _ = error "Non-RSA keytypes not handled yet"
inverse :: Integral a => a -> a -> a
inverse _ 1 = 1
inverse q p = (n * q + 1) `div` p
where n = p inverse p (q `mod` p)
reencryptSecretKeyIO :: SecretKey -> BL.ByteString -> IO SecretKey
reencryptSecretKeyIO sk pp = encryptPrivateKeyIO (_secretKeySKAddendum sk) pp >>= \n -> return sk { _secretKeySKAddendum = n }