    -- 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 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 -- FIXME: check the 16bit hash
      let checksum = cksum
      return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum?
      where
        getSecretKeyAndChecksum p =
          bimap
            (\(_, _, x) -> x)
            (\(_, _, x) -> x)
            (runGetOrFail
               (getSecretKey pkp >>= \sk ->
                  getWord16be >>= \csum -> return (sk, csum))
               (BL.fromStrict p)) -- FIXME: check the 16bit hash
    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 -- FIXME: check the SHA1 hash
      let checksum =
            sum . map fromIntegral . B.unpack . B.take (B.length p - 20) $ p
      return $ SUUnencrypted s checksum -- FIXME: is this the correct 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"

    -- |generates pseudo-random salt and IV
    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

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

    reencryptSecretKeyIO :: SecretKey -> BL.ByteString -> IO SecretKey
    reencryptSecretKeyIO sk pp =
      encryptPrivateKeyIO (_secretKeySKAddendum sk) pp >>= \n ->
        return sk {_secretKeySKAddendum = n}