    -- SecretKey.hs: OpenPGP (RFC4880) secret key encryption/decryption
    -- Copyright © 2013-2018  Clint Adams
    -- This software is released under the terms of the Expat license.
    -- (See the LICENSE file).
    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
      p <- SymmetricAlgorithm
    -> IV -> ByteString -> ByteString -> Either String ByteString
    decryptNoNonce SymmetricAlgorithm
    sa IV
    iv (ByteString -> ByteString
    BL.toStrict ByteString
    payload) ByteString
    key
      (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the 16bit hash
      let checksum = Word16
    cksum
      return $ SUUnencrypted s checksum -- FIXME: is this the correct 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 a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
    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 a b. Get a -> (a -> Get b) -> Get b
    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 a b. Get a -> (a -> Get b) -> Get b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Word16
    csum -> (SKey, Word16) -> Get (SKey, Word16)
    forall a. a -> Get a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SKey
    sk, Word16
    csum))
               (ByteString -> ByteString
    BL.fromStrict ByteString
    p)) -- FIXME: check the 16bit hash
    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
      p <- SymmetricAlgorithm
    -> IV -> ByteString -> ByteString -> Either String ByteString
    decryptNoNonce SymmetricAlgorithm
    sa IV
    iv (ByteString -> ByteString
    BL.toStrict ByteString
    payload) ByteString
    key
      (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the SHA1 hash
      let checksum =
            [Word16] -> Word16
    forall a. Num a => [a] -> a
    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
      return $ SUUnencrypted s checksum -- FIXME: is this the correct 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 a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
    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 a b. Get a -> (a -> Get b) -> Get b
    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 a b. Get a -> (a -> Get b) -> Get b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \ByteString
    csum -> (SKey, ByteString) -> Get (SKey, ByteString)
    forall a. a -> Get a
    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"

    -- |generates pseudo-random salt and IV
    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 a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \(ByteString
    s, ByteString
    i) -> SKAddendum -> IO SKAddendum
    forall a. a -> IO a
    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
          ep <- IO EntropyPool
    createEntropyPool
          bb <- getEntropyFrom ep (8 + saBlockSize AES256)
          return $ B.splitAt 8 bb

    -- |8-octet salt, IV must be length of cipher blocksize
    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 a b. PutM a -> PutM b -> PutM b
    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 a b. PutM a -> PutM b -> PutM b
    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 a b. PutM a -> PutM b -> PutM b
    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" -- FIXME: do DSA and ElGamal

    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 a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \SKAddendum
    n ->
        SecretKey -> IO SecretKey
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return SecretKey
    sk {_secretKeySKAddendum = n}