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