{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE BangPatterns               #-}

module Data.KeyStore.KS
    ( keyStoreBytes
    , keyStoreFromBytes
    , settingsFromBytes
    , createRSAKeyPairKS
    , encryptWithRSAKeyKS
    , encryptWithRSAKeyKS_
    , decryptWithRSAKeyKS
    , decryptWithRSAKeyKS_
    , signWithRSAKeyKS
    , verifyWithRSAKeyKS
    , encryptWithKeysKS
    , decryptWithKeysKS
    , createKeyKS
    , backupKeysKS
    , rememberKeyKS
    , secureKeyKS
    , getKeysKS
    , listKS
    , keyInfoKS
    , loadKeyKS
    , loadEncryptionKeyKS
    , module Data.KeyStore.KS.Crypto
    , module Data.KeyStore.KS.KS
    , module Data.KeyStore.KS.Opt
    , module Data.KeyStore.KS.Configuration
    , module Data.KeyStore.KS.CPRNG
    ) where

import           Data.KeyStore.KS.Packet
import           Data.KeyStore.KS.Crypto
import           Data.KeyStore.KS.KS
import           Data.KeyStore.KS.Opt
import           Data.KeyStore.KS.Configuration
import           Data.KeyStore.KS.CPRNG
import           Data.KeyStore.Types
import           Data.KeyStore.Types.AesonCompat
import           Data.API.JSON
import qualified Data.ByteString.Lazy           as LBS
import qualified Data.Map                       as Map
import qualified Data.Text                      as T
import           Data.Maybe
import           Data.List
import           Data.Time
import           Text.Printf
import qualified Control.Lens                   as L
import           Control.Monad


-------------------------------------------------------------------------------
-- | Encode a key store as a JSON ByteString (discarding any cached cleartext
-- copies of secrets it may have)
keyStoreBytes :: KeyStore -> LBS.ByteString
keyStoreBytes :: KeyStore -> ByteString
keyStoreBytes = KeyStore -> ByteString
forall a. ToJSON a => a -> ByteString
encode (KeyStore -> ByteString)
-> (KeyStore -> KeyStore) -> KeyStore -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyStore -> KeyStore
cln
  where
    cln :: KeyStore -> KeyStore
cln KeyStore
ks =
        KeyStore
ks  { _ks_keymap :: KeyMap
_ks_keymap = KeyMap -> KeyMap
cleanKeyMap (KeyMap -> KeyMap) -> KeyMap -> KeyMap
forall a b. (a -> b) -> a -> b
$ KeyStore -> KeyMap
_ks_keymap KeyStore
ks
            }


-------------------------------------------------------------------------------
-- Parse a key store from a JSON ByteString.
keyStoreFromBytes :: LBS.ByteString -> E KeyStore
keyStoreFromBytes :: ByteString -> E KeyStore
keyStoreFromBytes = Maybe KeyStore -> E KeyStore
forall a b. Error a => Maybe b -> Either a b
chk (Maybe KeyStore -> E KeyStore)
-> (ByteString -> Maybe KeyStore) -> ByteString -> E KeyStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(JSONError, Position)] -> Maybe KeyStore)
-> (KeyStore -> Maybe KeyStore)
-> Either [(JSONError, Position)] KeyStore
-> Maybe KeyStore
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe KeyStore -> [(JSONError, Position)] -> Maybe KeyStore
forall a b. a -> b -> a
const Maybe KeyStore
forall a. Maybe a
Nothing) KeyStore -> Maybe KeyStore
forall a. a -> Maybe a
Just (Either [(JSONError, Position)] KeyStore -> Maybe KeyStore)
-> (ByteString -> Either [(JSONError, Position)] KeyStore)
-> ByteString
-> Maybe KeyStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [(JSONError, Position)] KeyStore
forall a.
FromJSONWithErrs a =>
ByteString -> Either [(JSONError, Position)] a
decodeWithErrs
  where
    chk :: Maybe b -> Either a b
chk Maybe b
Nothing   = a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> a -> Either a b
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. Error a => String -> a
strMsg String
"failed to decode keystore file"
    chk (Just b
ks) = b -> Either a b
forall a b. b -> Either a b
Right b
ks


-------------------------------------------------------------------------------
-- Parse key store settings from a JSON ByteString.
settingsFromBytes :: LBS.ByteString -> E Settings
settingsFromBytes :: ByteString -> E Settings
settingsFromBytes = Maybe Value -> E Settings
forall a. Error a => Maybe Value -> Either a Settings
chk (Maybe Value -> E Settings)
-> (ByteString -> Maybe Value) -> ByteString -> E Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(JSONError, Position)] -> Maybe Value)
-> (Value -> Maybe Value)
-> Either [(JSONError, Position)] Value
-> Maybe Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Value -> [(JSONError, Position)] -> Maybe Value
forall a b. a -> b -> a
const Maybe Value
forall a. Maybe a
Nothing) Value -> Maybe Value
forall a. a -> Maybe a
Just (Either [(JSONError, Position)] Value -> Maybe Value)
-> (ByteString -> Either [(JSONError, Position)] Value)
-> ByteString
-> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [(JSONError, Position)] Value
forall a.
FromJSONWithErrs a =>
ByteString -> Either [(JSONError, Position)] a
decodeWithErrs
  where
    chk :: Maybe Value -> Either a Settings
chk (Just(Object Object
fm)) = Settings -> Either a Settings
forall a b. b -> Either a b
Right (Settings -> Either a Settings) -> Settings -> Either a Settings
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> Settings
Settings (HashMap Text Value -> Settings) -> HashMap Text Value -> Settings
forall a b. (a -> b) -> a -> b
$ Object -> HashMap Text Value
forall a. KM a -> HashMap Text a
fromKM Object
fm
    chk Maybe Value
_                 = a -> Either a Settings
forall a b. a -> Either a b
Left  (a -> Either a Settings) -> a -> Either a Settings
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. Error a => String -> a
strMsg String
"failed to decode JSON settings"


-------------------------------------------------------------------------------
-- Create a random RSA key pair under a name in the key store,
-- safeguarding it zero, one or more times.
createRSAKeyPairKS :: Name -> Comment -> Identity -> [Safeguard] -> KS ()
createRSAKeyPairKS :: Name -> Comment -> Identity -> [Safeguard] -> KS ()
createRSAKeyPairKS Name
nm Comment
cmt Identity
ide [Safeguard]
nmz =
 do ()
_ <- Name
-> Comment -> Identity -> Maybe EnvVar -> Maybe ClearText -> KS ()
createKeyKS Name
nm Comment
cmt Identity
ide Maybe EnvVar
forall a. Maybe a
Nothing Maybe ClearText
forall a. Maybe a
Nothing
    (PublicKey
puk,PrivateKey
prk) <- KS (PublicKey, PrivateKey)
generateKeysKS
    Name -> (Key -> Key) -> KS ()
adjustKeyKS Name
nm (PublicKey -> Key -> Key
add_puk PublicKey
puk)
    Name -> ClearText -> KS ()
rememberKeyKS Name
nm (ClearText -> KS ()) -> ClearText -> KS ()
forall a b. (a -> b) -> a -> b
$ PrivateKey -> ClearText
encodePrivateKeyDER PrivateKey
prk
    (Safeguard -> KS ()) -> [Safeguard] -> KS ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name -> Safeguard -> KS ()
secureKeyKS Name
nm) [Safeguard]
nmz
  where
    add_puk :: PublicKey -> Key -> Key
add_puk PublicKey
puk Key
key = Key
key { _key_public :: Maybe PublicKey
_key_public = PublicKey -> Maybe PublicKey
forall a. a -> Maybe a
Just PublicKey
puk }


-------------------------------------------------------------------------------
-- | Encrypt a clear text message with a name RSA key pair.
encryptWithRSAKeyKS :: Name -> ClearText -> KS EncryptionPacket
encryptWithRSAKeyKS :: Name -> ClearText -> KS EncryptionPacket
encryptWithRSAKeyKS Name
nm ClearText
ct =
    Safeguard -> RSASecretBytes -> EncryptionPacket
encocdeEncryptionPacket ([Name] -> Safeguard
safeguard [Name
nm]) (RSASecretBytes -> EncryptionPacket)
-> (RSASecretData -> RSASecretBytes)
-> RSASecretData
-> EncryptionPacket
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                RSASecretData -> RSASecretBytes
encodeRSASecretData (RSASecretData -> EncryptionPacket)
-> KS RSASecretData -> KS EncryptionPacket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> ClearText -> KS RSASecretData
encryptWithRSAKeyKS_ Name
nm ClearText
ct

encryptWithRSAKeyKS_ :: Name -> ClearText -> KS RSASecretData
encryptWithRSAKeyKS_ :: Name -> ClearText -> KS RSASecretData
encryptWithRSAKeyKS_ Name
nm ClearText
ct =
 do EncrypedCopyData
scd <- EncrypedCopy -> EncrypedCopyData
_ec_secret_data (EncrypedCopy -> EncrypedCopyData)
-> KS EncrypedCopy -> KS EncrypedCopyData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Safeguard -> ClearText -> KS EncrypedCopy
encryptWithKeysKS ([Name] -> Safeguard
safeguard [Name
nm]) ClearText
ct
    case EncrypedCopyData
scd of
      ECD_rsa RSASecretData
rsd -> RSASecretData -> KS RSASecretData
forall (m :: * -> *) a. Monad m => a -> m a
return RSASecretData
rsd
      EncrypedCopyData
_           -> String -> KS RSASecretData
forall a. String -> KS a
errorKS String
"RSA key expected"


-------------------------------------------------------------------------------
-- | Decrypt an RSA-encrypted message (the RSA secret key named in the message
-- must be available.)
decryptWithRSAKeyKS :: EncryptionPacket -> KS ClearText
decryptWithRSAKeyKS :: EncryptionPacket -> KS ClearText
decryptWithRSAKeyKS EncryptionPacket
ep =
 do (Safeguard
sg,RSASecretBytes
rsb) <- E (Safeguard, RSASecretBytes) -> KS (Safeguard, RSASecretBytes)
forall a. E a -> KS a
e2ks (E (Safeguard, RSASecretBytes) -> KS (Safeguard, RSASecretBytes))
-> E (Safeguard, RSASecretBytes) -> KS (Safeguard, RSASecretBytes)
forall a b. (a -> b) -> a -> b
$ EncryptionPacket -> E (Safeguard, RSASecretBytes)
decocdeEncryptionPacketE EncryptionPacket
ep
    Name
nm  <- case Safeguard -> [Name]
safeguardKeys Safeguard
sg of
             [Name
nm] -> Name -> KS Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
             [Name]
_    -> String -> KS Name
forall a. String -> KS a
errorKS String
"expected a single (RSA) key in the safeguard"
    RSASecretData
rsd <- RSASecretBytes -> KS RSASecretData
decodeRSASecretData RSASecretBytes
rsb
    Name -> RSASecretData -> KS ClearText
decryptWithRSAKeyKS_ Name
nm RSASecretData
rsd

decryptWithRSAKeyKS_ :: Name -> RSASecretData -> KS ClearText
decryptWithRSAKeyKS_ :: Name -> RSASecretData -> KS ClearText
decryptWithRSAKeyKS_ Name
nm RSASecretData
rsd =
 do Key
key <- Name -> KS Key
loadKeyKS Name
nm
    case Key -> Maybe PrivateKey
_key_clear_private Key
key of
      Maybe PrivateKey
Nothing  -> String -> KS ClearText
forall a. String -> KS a
errorKS String
"could not load private key"
      Just PrivateKey
prk -> PrivateKey -> RSASecretData -> KS ClearText
decryptKS PrivateKey
prk RSASecretData
rsd


-------------------------------------------------------------------------------
-- | Sign a message with a named RSA secret key (which must be available).
signWithRSAKeyKS :: Name -> ClearText -> KS SignaturePacket
signWithRSAKeyKS :: Name -> ClearText -> KS SignaturePacket
signWithRSAKeyKS Name
nm ClearText
ct =
 do Key
key <- Name -> KS Key
loadKeyKS Name
nm
    case Key -> Maybe PrivateKey
_key_clear_private Key
key of
      Maybe PrivateKey
Nothing  -> String -> KS SignaturePacket
forall a. String -> KS a
errorKS String
"could not load private key"
      Just PrivateKey
prk -> Safeguard -> RSASignature -> SignaturePacket
encocdeSignaturePacket ([Name] -> Safeguard
safeguard [Name
nm]) (RSASignature -> SignaturePacket)
-> KS RSASignature -> KS SignaturePacket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrivateKey -> ClearText -> KS RSASignature
signKS PrivateKey
prk ClearText
ct


-------------------------------------------------------------------------------
-- | Verify that an RSA signature of a message is correct.
verifyWithRSAKeyKS :: ClearText -> SignaturePacket -> KS Bool
verifyWithRSAKeyKS :: ClearText -> SignaturePacket -> KS Bool
verifyWithRSAKeyKS ClearText
ct SignaturePacket
sp =
 do (Safeguard
sg,RSASignature
rs) <- E (Safeguard, RSASignature) -> KS (Safeguard, RSASignature)
forall a. E a -> KS a
e2ks (E (Safeguard, RSASignature) -> KS (Safeguard, RSASignature))
-> E (Safeguard, RSASignature) -> KS (Safeguard, RSASignature)
forall a b. (a -> b) -> a -> b
$ SignaturePacket -> E (Safeguard, RSASignature)
decocdeSignaturePacketE SignaturePacket
sp
    Name
nm  <- case Safeguard -> [Name]
safeguardKeys Safeguard
sg of
             [Name
nm] -> Name -> KS Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
             [Name]
_    -> String -> KS Name
forall a. String -> KS a
errorKS String
"expected a single (RSA) key in the safeguard"
    Key
key <- Name -> KS Key
lookupKey Name
nm
    case Key -> Maybe PublicKey
_key_public Key
key of
      Maybe PublicKey
Nothing  -> String -> KS Bool
forall a. String -> KS a
errorKS String
"not an RSA key pair"
      Just PublicKey
puk -> Bool -> KS Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> KS Bool) -> Bool -> KS Bool
forall a b. (a -> b) -> a -> b
$ PublicKey -> ClearText -> RSASignature -> Bool
verifyKS PublicKey
puk ClearText
ct RSASignature
rs


-------------------------------------------------------------------------------
-- | Symetrically encrypt a message with a Safeguard (list of names private
-- keys).
encryptWithKeysKS :: Safeguard -> ClearText -> KS EncrypedCopy
encryptWithKeysKS :: Safeguard -> ClearText -> KS EncrypedCopy
encryptWithKeysKS Safeguard
nms ClearText
ct =
 do EncrypedCopy
ec  <- Safeguard -> KS EncrypedCopy
defaultEncryptedCopyKS Safeguard
nms
    Maybe EncryptionKey
mb  <- Dirctn -> EncrypedCopy -> KS (Maybe EncryptionKey)
loadEncryptionKeyKS Dirctn
Encrypting EncrypedCopy
ec
    EncryptionKey
ek  <- case Maybe EncryptionKey
mb of
             Maybe EncryptionKey
Nothing -> String -> KS EncryptionKey
forall a. String -> KS a
errorKS String
"could not load keys"
             Just EncryptionKey
ek -> EncryptionKey -> KS EncryptionKey
forall (m :: * -> *) a. Monad m => a -> m a
return EncryptionKey
ek
    EncrypedCopyData
ecd <- EncryptionKey -> ClearText -> KS EncrypedCopyData
saveKS EncryptionKey
ek ClearText
ct
    EncrypedCopy -> KS EncrypedCopy
forall (m :: * -> *) a. Monad m => a -> m a
return EncrypedCopy
ec { _ec_secret_data :: EncrypedCopyData
_ec_secret_data = EncrypedCopyData
ecd }


-------------------------------------------------------------------------------
-- | Symetrically encrypt a message with a Safeguard (list of names private
-- keys).
decryptWithKeysKS :: EncrypedCopy -> KS ClearText
decryptWithKeysKS :: EncrypedCopy -> KS ClearText
decryptWithKeysKS EncrypedCopy
ec =
 do Maybe EncryptionKey
mb <- Dirctn -> EncrypedCopy -> KS (Maybe EncryptionKey)
loadEncryptionKeyKS Dirctn
Decrypting EncrypedCopy
ec
    EncryptionKey
ek <- case Maybe EncryptionKey
mb of
            Maybe EncryptionKey
Nothing -> String -> KS EncryptionKey
forall a. String -> KS a
errorKS String
"could not load keys"
            Just EncryptionKey
ek -> EncryptionKey -> KS EncryptionKey
forall (m :: * -> *) a. Monad m => a -> m a
return EncryptionKey
ek
    EncrypedCopyData -> EncryptionKey -> KS ClearText
restoreKS (EncrypedCopy -> EncrypedCopyData
_ec_secret_data EncrypedCopy
ec) EncryptionKey
ek


-------------------------------------------------------------------------------
-- | Create a private key.
createKeyKS :: Name             -- ^ (unique) name of the new key
          -> Comment          -- ^ the comment string
          -> Identity         -- ^ the identity string
          -> Maybe EnvVar     -- ^ the environment variable used to hold a clear text copy
          -> Maybe ClearText  -- ^ (optionally) the clear test copy
          -> KS ()
createKeyKS :: Name
-> Comment -> Identity -> Maybe EnvVar -> Maybe ClearText -> KS ()
createKeyKS Name
nm Comment
cmt Identity
ide Maybe EnvVar
mb_ev Maybe ClearText
mb_ct = Name -> KS () -> KS ()
forall a. Name -> KS a -> KS a
withKey Name
nm (KS () -> KS ()) -> KS () -> KS ()
forall a b. (a -> b) -> a -> b
$
 do UTCTime
now <- KS UTCTime
currentTime
    Key -> KS ()
insertNewKey
        Key :: Name
-> Comment
-> Identity
-> Bool
-> Maybe EnvVar
-> Maybe Hash
-> Maybe PublicKey
-> EncrypedCopyMap
-> Maybe ClearText
-> Maybe PrivateKey
-> UTCTime
-> Key
Key
            { _key_name :: Name
_key_name          = Name
nm
            , _key_comment :: Comment
_key_comment       = Comment
cmt
            , _key_identity :: Identity
_key_identity      = Identity
ide
            , _key_is_binary :: Bool
_key_is_binary     = Bool
False
            , _key_env_var :: Maybe EnvVar
_key_env_var       = Maybe EnvVar
mb_ev
            , _key_hash :: Maybe Hash
_key_hash          = Maybe Hash
forall a. Maybe a
Nothing
            , _key_public :: Maybe PublicKey
_key_public        = Maybe PublicKey
forall a. Maybe a
Nothing
            , _key_secret_copies :: EncrypedCopyMap
_key_secret_copies = EncrypedCopyMap
forall k a. Map k a
Map.empty
            , _key_clear_text :: Maybe ClearText
_key_clear_text    = Maybe ClearText
forall a. Maybe a
Nothing
            , _key_clear_private :: Maybe PrivateKey
_key_clear_private = Maybe PrivateKey
forall a. Maybe a
Nothing
            , _key_created_at :: UTCTime
_key_created_at    = UTCTime
now
            }
    KS () -> (ClearText -> KS ()) -> Maybe ClearText -> KS ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> KS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Name -> ClearText -> KS ()
rememberKeyKS Name
nm) Maybe ClearText
mb_ct


-------------------------------------------------------------------------------
-- | Remember the secret text for a key -- will record the hash and encrypt
-- it with the configured safeguards, generating an error if any of the
-- safeguards are not available.
rememberKeyKS :: Name -> ClearText -> KS ()
rememberKeyKS :: Name -> ClearText -> KS ()
rememberKeyKS Name
nm ClearText
ct =
 do String -> KS ()
btw (String -> KS ()) -> String -> KS ()
forall a b. (a -> b) -> a -> b
$ String
"remembering " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
    Key
key0 <- Name -> KS Key
lookupKey Name
nm
    let key1 :: Key
key1 = Key
key0 { _key_clear_text :: Maybe ClearText
_key_clear_text = ClearText -> Maybe ClearText
forall a. a -> Maybe a
Just ClearText
ct }
    Bool
vfy  <- Opt Bool -> KS Bool
forall a. Show a => Opt a -> KS a
lookupOpt Opt Bool
opt__verify_enabled
    Key
key2 <- case Bool
vfy of
      Bool
True  -> Key -> ClearText -> KS Key
verify_key Key
key1 ClearText
ct
      Bool
False -> Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key1
    Key
key  <-
        case Key -> Maybe Hash
_key_hash Key
key2 of
          Maybe Hash
Nothing  | Maybe PublicKey -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe PublicKey -> Bool) -> Maybe PublicKey -> Bool
forall a b. (a -> b) -> a -> b
$ Key -> Maybe PublicKey
_key_public Key
key2 -> Key -> Hash -> Key
upd Key
key2 (Hash -> Key) -> KS Hash -> KS Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClearText -> KS Hash
hashKS ClearText
ct
          Maybe Hash
_                                       -> Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key2
    Key -> KS ()
insertKey Key
key
    Name -> KS ()
backupKeyKS Name
nm
  where
    upd :: Key -> Hash -> Key
upd Key
key Hash
hsh =
        Key
key { _key_hash :: Maybe Hash
_key_hash = Hash -> Maybe Hash
forall a. a -> Maybe a
Just Hash
hsh
            }


-------------------------------------------------------------------------------
-- | Backup all of the keys in the store with their configured backup keys.
backupKeysKS :: KS ()
backupKeysKS :: KS ()
backupKeysKS = KS [Key]
getKeysKS KS [Key] -> ([Key] -> KS ()) -> KS ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Key -> KS ()) -> [Key] -> KS ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name -> KS ()
backupKeyKS (Name -> KS ()) -> (Key -> Name) -> Key -> KS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Name
_key_name)


-------------------------------------------------------------------------------
-- | Backup a named key with its configured backup key.
backupKeyKS :: Name -> KS ()
backupKeyKS :: Name -> KS ()
backupKeyKS Name
nm = Name -> KS () -> KS ()
forall a. Name -> KS a -> KS a
withKey Name
nm (KS () -> KS ()) -> KS () -> KS ()
forall a b. (a -> b) -> a -> b
$
 do [Name]
nms <- Opt [Name] -> KS [Name]
forall a. Show a => Opt a -> KS a
lookupOpt Opt [Name]
opt__backup_keys
    (Name -> KS ()) -> [Name] -> KS ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> KS ()
backup [Name]
nms
  where
    backup :: Name -> KS ()
backup Name
nm' = Name -> Safeguard -> KS ()
secure_key Name
nm (Safeguard -> KS ()) -> Safeguard -> KS ()
forall a b. (a -> b) -> a -> b
$ [Name] -> Safeguard
safeguard [Name
nm']


-------------------------------------------------------------------------------
-- | Primitive to make a cryptographic copy (i.e., a safeguard) of the
-- secret text of a key, storing it in the key (and doing nothing if the
-- that safeguard is already present).
secureKeyKS :: Name -> Safeguard -> KS ()
secureKeyKS :: Name -> Safeguard -> KS ()
secureKeyKS Name
nm Safeguard
sg = Name -> KS () -> KS ()
forall a. Name -> KS a -> KS a
withKey Name
nm (KS () -> KS ()) -> KS () -> KS ()
forall a b. (a -> b) -> a -> b
$ Name -> Safeguard -> KS ()
secure_key Name
nm Safeguard
sg

secure_key :: Name -> Safeguard -> KS ()
secure_key :: Name -> Safeguard -> KS ()
secure_key Name
nm Safeguard
sg =
 do String -> KS ()
btw (String -> KS ()) -> String -> KS ()
forall a b. (a -> b) -> a -> b
$ String
"securing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Safeguard -> String
forall a. Show a => a -> String
show Safeguard
sg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
    Key
key <- Name -> KS Key
loadKeyKS Name
nm
    Bool -> KS () -> KS ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe EncrypedCopy -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe EncrypedCopy -> Bool) -> Maybe EncrypedCopy -> Bool
forall a b. (a -> b) -> a -> b
$ Safeguard -> EncrypedCopyMap -> Maybe EncrypedCopy
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Safeguard
sg (EncrypedCopyMap -> Maybe EncrypedCopy)
-> EncrypedCopyMap -> Maybe EncrypedCopy
forall a b. (a -> b) -> a -> b
$ Key -> EncrypedCopyMap
_key_secret_copies Key
key) (KS () -> KS ()) -> KS () -> KS ()
forall a b. (a -> b) -> a -> b
$
     do ClearText
ct  <- case Key -> Maybe ClearText
_key_clear_text Key
key of
                 Maybe ClearText
Nothing -> String -> KS ClearText
forall a. String -> KS a
errorKS (String -> KS ClearText) -> String -> KS ClearText
forall a b. (a -> b) -> a -> b
$ Name -> String
_name Name
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": cannot load key"
                 Just ClearText
ct -> ClearText -> KS ClearText
forall (m :: * -> *) a. Monad m => a -> m a
return ClearText
ct
        EncrypedCopy
ec0 <- Safeguard -> KS EncrypedCopy
defaultEncryptedCopyKS Safeguard
sg
        Maybe EncryptionKey
mbk <- Dirctn -> EncrypedCopy -> KS (Maybe EncryptionKey)
loadEncryptionKeyKS Dirctn
Encrypting EncrypedCopy
ec0
        EncryptionKey
ek  <- case Maybe EncryptionKey
mbk of
                 Maybe EncryptionKey
Nothing -> String -> KS EncryptionKey
forall a. String -> KS a
errorKS (String -> KS EncryptionKey) -> String -> KS EncryptionKey
forall a b. (a -> b) -> a -> b
$
                            Safeguard -> String
printSafeguard Safeguard
sg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": cannot load encryption keys"
                 Just EncryptionKey
ek -> EncryptionKey -> KS EncryptionKey
forall (m :: * -> *) a. Monad m => a -> m a
return EncryptionKey
ek
        EncrypedCopyData
ecd <- EncryptionKey -> ClearText -> KS EncrypedCopyData
saveKS EncryptionKey
ek ClearText
ct
        let ec :: EncrypedCopy
ec = EncrypedCopy
ec0 { _ec_secret_data :: EncrypedCopyData
_ec_secret_data = EncrypedCopyData
ecd }
        Key -> KS ()
insertKey (Key -> KS ()) -> Key -> KS ()
forall a b. (a -> b) -> a -> b
$ ASetter Key Key EncrypedCopyMap EncrypedCopyMap
-> (EncrypedCopyMap -> EncrypedCopyMap) -> Key -> Key
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
L.over ASetter Key Key EncrypedCopyMap EncrypedCopyMap
Lens' Key EncrypedCopyMap
key_secret_copies (Safeguard -> EncrypedCopy -> EncrypedCopyMap -> EncrypedCopyMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Safeguard
sg EncrypedCopy
ec) Key
key


-------------------------------------------------------------------------------
-- | List all of the keys in the store, one per line, on the output.
listKS :: KS ()
listKS :: KS ()
listKS =
 do [Name]
nms <- (Key -> Name) -> [Key] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Name
_key_name ([Key] -> [Name]) -> KS [Key] -> KS [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KS [Key]
getKeysKS
    [Key]
keys <- (Name -> KS Key) -> [Name] -> KS [Key]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> KS Key
loadKeyKS ([Name] -> KS [Key]) -> [Name] -> KS [Key]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. Ord a => [a] -> [a]
sort [Name]
nms
    String -> KS ()
putStrKS (String -> KS ()) -> String -> KS ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Key -> String
list_key Bool
False) [Key]
keys

-- | Print out the information of a particular key.
keyInfoKS :: Name -> KS ()
keyInfoKS :: Name -> KS ()
keyInfoKS Name
nm =
 do Key
key <- Name -> KS Key
loadKeyKS Name
nm
    String -> KS ()
putStrKS (String -> KS ()) -> String -> KS ()
forall a b. (a -> b) -> a -> b
$ Bool -> Key -> String
list_key Bool
True Key
key

data Line
    = LnHeader        String
    | LnDate          UTCTime
    | LnHash          String
    | LnCopiesHeader
    | LnCopy          String
    deriving Int -> Line -> String -> String
[Line] -> String -> String
Line -> String
(Int -> Line -> String -> String)
-> (Line -> String) -> ([Line] -> String -> String) -> Show Line
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Line] -> String -> String
$cshowList :: [Line] -> String -> String
show :: Line -> String
$cshow :: Line -> String
showsPrec :: Int -> Line -> String -> String
$cshowsPrec :: Int -> Line -> String -> String
Show

list_key :: Bool -> Key -> String
list_key :: Bool -> Key -> String
list_key Bool
True  key :: Key
key@Key{Bool
Maybe PublicKey
Maybe PrivateKey
Maybe ClearText
Maybe EnvVar
Maybe Hash
UTCTime
EncrypedCopyMap
Name
Comment
Identity
_key_created_at :: UTCTime
_key_clear_private :: Maybe PrivateKey
_key_clear_text :: Maybe ClearText
_key_secret_copies :: EncrypedCopyMap
_key_public :: Maybe PublicKey
_key_hash :: Maybe Hash
_key_env_var :: Maybe EnvVar
_key_is_binary :: Bool
_key_identity :: Identity
_key_comment :: Comment
_key_name :: Name
_key_created_at :: Key -> UTCTime
_key_clear_text :: Key -> Maybe ClearText
_key_secret_copies :: Key -> EncrypedCopyMap
_key_hash :: Key -> Maybe Hash
_key_env_var :: Key -> Maybe EnvVar
_key_is_binary :: Key -> Bool
_key_identity :: Key -> Identity
_key_comment :: Key -> Comment
_key_name :: Key -> Name
_key_clear_private :: Key -> Maybe PrivateKey
_key_public :: Key -> Maybe PublicKey
..} =
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Line -> String) -> [Line] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Line -> String
fmt ([Line] -> [String]) -> [Line] -> [String]
forall a b. (a -> b) -> a -> b
$
        [ String -> Line
LnHeader String
hdr                                     ] [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++
        [ UTCTime -> Line
LnDate   UTCTime
_key_created_at                         ] [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++
        [ String -> Line
LnHash   String
hsh             | Just String
hsh<-[Maybe String
mb_hsh]    ] [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++
        [ Line
LnCopiesHeader                                   ] [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++
        [ String -> Line
LnCopy (String -> Line) -> String -> Line
forall a b. (a -> b) -> a -> b
$ EncrypedCopy -> String
forall t. PrintfType t => EncrypedCopy -> t
fmt_ec EncrypedCopy
ec       | EncrypedCopy
ec<-EncrypedCopyMap -> [EncrypedCopy]
forall k a. Map k a -> [a]
Map.elems (EncrypedCopyMap -> [EncrypedCopy])
-> EncrypedCopyMap -> [EncrypedCopy]
forall a b. (a -> b) -> a -> b
$ EncrypedCopyMap
_key_secret_copies ]
  where
    fmt :: Line -> String
fmt Line
ln =
        case Line
ln of
          LnHeader             String
s -> String
s
          LnDate               UTCTime
u -> Int -> String -> String -> String
forall t t. (PrintfArg t, PrintfArg t) => Int -> t -> t -> String
fmt_ln  Int
2 String
"Date:"   (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
u
          LnHash               String
s -> Int -> String -> String -> String
forall t t. (PrintfArg t, PrintfArg t) => Int -> t -> t -> String
fmt_ln  Int
2 String
"Hash:"          String
s
          Line
LnCopiesHeader         -> Int -> String -> String -> String
forall t t. (PrintfArg t, PrintfArg t) => Int -> t -> t -> String
fmt_ln  Int
2 String
"Copies:"        String
""
          LnCopy               String
s -> Int -> String -> String
fmt_ln_ Int
4                  String
s

    hdr :: String
hdr     = String -> String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s: %s%s -- %s" String
nm String
sts String
ev String
cmt
        where
          nm :: String
nm    = Name -> String
_name                                           Name
_key_name
          sts :: String
sts   = Key -> String
status Key
key
          ev :: String
ev    = String -> (EnvVar -> String) -> Maybe EnvVar -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> String -> String
forall r. PrintfType r => String -> r
printf String
" ($%s)" (String -> String) -> (EnvVar -> String) -> EnvVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (EnvVar -> Text) -> EnvVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvVar -> Text
_EnvVar) Maybe EnvVar
_key_env_var
          cmt :: String
cmt   = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Comment -> Text
_Comment                             Comment
_key_comment
    mb_hsh :: Maybe String
mb_hsh  = Hash -> String
forall t. PrintfType t => Hash -> t
fmt_hsh (Hash -> String) -> Maybe Hash -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Hash
_key_hash

    fmt_ec :: EncrypedCopy -> t
fmt_ec EncrypedCopy{Safeguard
Salt
Iterations
HashPRF
Cipher
EncrypedCopyData
_ec_salt :: EncrypedCopy -> Salt
_ec_iterations :: EncrypedCopy -> Iterations
_ec_prf :: EncrypedCopy -> HashPRF
_ec_cipher :: EncrypedCopy -> Cipher
_ec_safeguard :: EncrypedCopy -> Safeguard
_ec_secret_data :: EncrypedCopyData
_ec_salt :: Salt
_ec_iterations :: Iterations
_ec_prf :: HashPRF
_ec_cipher :: Cipher
_ec_safeguard :: Safeguard
_ec_secret_data :: EncrypedCopy -> EncrypedCopyData
..} = String -> String -> Int -> String -> String -> t
forall r. PrintfType r => String -> r
printf String
"%s(%d*%s[%s])" String
ci Int
is String
pf String
sg
        where
          ci :: String
ci            = Cipher -> String
forall a. Show a => a -> String
show Cipher
_ec_cipher
          Iterations Int
is = Iterations
_ec_iterations
          pf :: String
pf            = HashPRF -> String
forall a. Show a => a -> String
show HashPRF
_ec_prf
          sg :: String
sg            = Safeguard -> String
printSafeguard Safeguard
_ec_safeguard

    fmt_hsh :: Hash -> t
fmt_hsh Hash{_hash_description :: Hash -> HashDescription
_hash_description=HashDescription{Salt
Comment
Octets
Iterations
HashPRF
_hashd_salt :: HashDescription -> Salt
_hashd_salt_octets :: HashDescription -> Octets
_hashd_width_octets :: HashDescription -> Octets
_hashd_iterations :: HashDescription -> Iterations
_hashd_prf :: HashDescription -> HashPRF
_hashd_comment :: HashDescription -> Comment
_hashd_salt :: Salt
_hashd_salt_octets :: Octets
_hashd_width_octets :: Octets
_hashd_iterations :: Iterations
_hashd_prf :: HashPRF
_hashd_comment :: Comment
..}} = String -> Int -> String -> Int -> Int -> t
forall r. PrintfType r => String -> r
printf String
"%d*%s(%d):%d" Int
is String
pf Int
sw Int
wd
        where
          Iterations Int
is = Iterations
_hashd_iterations
          pf :: String
pf            = HashPRF -> String
forall a. Show a => a -> String
show HashPRF
_hashd_prf
          Octets Int
sw     = Octets
_hashd_salt_octets
          Octets Int
wd     = Octets
_hashd_width_octets

    fmt_ln :: Int -> t -> t -> String
fmt_ln  Int
i t
s t
s'   = Int -> String -> String
fmt_ln_ Int
i (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> t -> t -> String
forall r. PrintfType r => String -> r
printf String
"%-8s %s" t
s t
s'
    fmt_ln_ :: Int -> String -> String
fmt_ln_ Int
i String
s      = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
i Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
list_key Bool
False key :: Key
key@Key{Bool
Maybe PublicKey
Maybe PrivateKey
Maybe ClearText
Maybe EnvVar
Maybe Hash
UTCTime
EncrypedCopyMap
Name
Comment
Identity
_key_created_at :: UTCTime
_key_clear_private :: Maybe PrivateKey
_key_clear_text :: Maybe ClearText
_key_secret_copies :: EncrypedCopyMap
_key_public :: Maybe PublicKey
_key_hash :: Maybe Hash
_key_env_var :: Maybe EnvVar
_key_is_binary :: Bool
_key_identity :: Identity
_key_comment :: Comment
_key_name :: Name
_key_created_at :: Key -> UTCTime
_key_clear_text :: Key -> Maybe ClearText
_key_secret_copies :: Key -> EncrypedCopyMap
_key_hash :: Key -> Maybe Hash
_key_env_var :: Key -> Maybe EnvVar
_key_is_binary :: Key -> Bool
_key_identity :: Key -> Identity
_key_comment :: Key -> Comment
_key_name :: Key -> Name
_key_clear_private :: Key -> Maybe PrivateKey
_key_public :: Key -> Maybe PublicKey
..} = String -> String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%-40s : %s%s (%s)\n" String
nm String
sts String
ev String
ecs
  where
    nm :: String
nm  = Name -> String
_name  Name
_key_name
    sts :: String
sts = Key -> String
status Key
key
    ev :: String
ev  = String -> (EnvVar -> String) -> Maybe EnvVar -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> String -> String
forall r. PrintfType r => String -> r
printf String
" ($%s)" (String -> String) -> (EnvVar -> String) -> EnvVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (EnvVar -> Text) -> EnvVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvVar -> Text
_EnvVar) Maybe EnvVar
_key_env_var
    ecs :: String
ecs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (EncrypedCopy -> String) -> [EncrypedCopy] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Safeguard -> String
printSafeguard (Safeguard -> String)
-> (EncrypedCopy -> Safeguard) -> EncrypedCopy -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncrypedCopy -> Safeguard
_ec_safeguard) ([EncrypedCopy] -> [String]) -> [EncrypedCopy] -> [String]
forall a b. (a -> b) -> a -> b
$
                                                  EncrypedCopyMap -> [EncrypedCopy]
forall k a. Map k a -> [a]
Map.elems EncrypedCopyMap
_key_secret_copies

status :: Key -> String
status :: Key -> String
status Key{Bool
Maybe PublicKey
Maybe PrivateKey
Maybe ClearText
Maybe EnvVar
Maybe Hash
UTCTime
EncrypedCopyMap
Name
Comment
Identity
_key_created_at :: UTCTime
_key_clear_private :: Maybe PrivateKey
_key_clear_text :: Maybe ClearText
_key_secret_copies :: EncrypedCopyMap
_key_public :: Maybe PublicKey
_key_hash :: Maybe Hash
_key_env_var :: Maybe EnvVar
_key_is_binary :: Bool
_key_identity :: Identity
_key_comment :: Comment
_key_name :: Name
_key_created_at :: Key -> UTCTime
_key_clear_text :: Key -> Maybe ClearText
_key_secret_copies :: Key -> EncrypedCopyMap
_key_hash :: Key -> Maybe Hash
_key_env_var :: Key -> Maybe EnvVar
_key_is_binary :: Key -> Bool
_key_identity :: Key -> Identity
_key_comment :: Key -> Comment
_key_name :: Key -> Name
_key_clear_private :: Key -> Maybe PrivateKey
_key_public :: Key -> Maybe PublicKey
..} = [Char
sts_t,Char
sts_p]
  where
    sts_t :: Char
sts_t = Char -> (ClearText -> Char) -> Maybe ClearText -> Char
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Char
'-' (Char -> ClearText -> Char
forall a b. a -> b -> a
const Char
'T')                Maybe ClearText
_key_clear_text
    sts_p :: Char
sts_p = Char -> (PublicKey -> Char) -> Maybe PublicKey -> Char
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Char
'-' (Char -> PublicKey -> Char
forall a b. a -> b -> a
const Char
'P')                Maybe PublicKey
_key_public


-------------------------------------------------------------------------------
-- | Return all of the keys in the keystore.
getKeysKS :: KS [Key]
getKeysKS :: KS [Key]
getKeysKS = KeyMap -> [Key]
forall k a. Map k a -> [a]
Map.elems (KeyMap -> [Key]) -> KS KeyMap -> KS [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KS KeyMap
getKeymap


-------------------------------------------------------------------------------
-- | Try to load the secret copy into the key and return it. (No error is
-- raised if it failed to recover the secret.)
loadKeyKS :: Name -> KS Key
loadKeyKS :: Name -> KS Key
loadKeyKS = [Name] -> Name -> KS Key
load_key []

load_key :: [Name] -> Name -> KS Key
load_key :: [Name] -> Name -> KS Key
load_key [Name]
nm_s Name
nm =
 do Key
key <- Name -> KS Key
lookupKey Name
nm
    KS Key -> (ClearText -> KS Key) -> Maybe ClearText -> KS Key
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Name] -> Name -> KS Key
load_key' [Name]
nm_s Name
nm) (KS Key -> ClearText -> KS Key
forall a b. a -> b -> a
const (KS Key -> ClearText -> KS Key) -> KS Key -> ClearText -> KS Key
forall a b. (a -> b) -> a -> b
$ Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key) (Maybe ClearText -> KS Key) -> Maybe ClearText -> KS Key
forall a b. (a -> b) -> a -> b
$ Key -> Maybe ClearText
_key_clear_text Key
key

load_key' :: [Name] -> Name -> KS Key
load_key' :: [Name] -> Name -> KS Key
load_key' [Name]
nm_s Name
nm =
 do Key
key0 <- Name -> KS Key
lookupKey Name
nm
    let ld :: [EncrypedCopy] -> KS Key
ld []        = Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key0
        ld (EncrypedCopy
sc:[EncrypedCopy]
scs)  =
             do Key
key <- [Name] -> Name -> Key -> EncrypedCopy -> KS Key
load_key'' [Name]
nm_s Name
nm Key
key0 EncrypedCopy
sc
                case Key -> Maybe ClearText
_key_clear_text Key
key of
                  Maybe ClearText
Nothing -> [EncrypedCopy] -> KS Key
ld [EncrypedCopy]
scs
                  Just ClearText
_  -> Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key
    [EncrypedCopy] -> KS Key
ld ([EncrypedCopy] -> KS Key) -> [EncrypedCopy] -> KS Key
forall a b. (a -> b) -> a -> b
$ EncrypedCopyMap -> [EncrypedCopy]
forall k a. Map k a -> [a]
Map.elems (EncrypedCopyMap -> [EncrypedCopy])
-> EncrypedCopyMap -> [EncrypedCopy]
forall a b. (a -> b) -> a -> b
$ Key -> EncrypedCopyMap
_key_secret_copies Key
key0

load_key'' :: [Name]
           -> Name
           -> Key
           -> EncrypedCopy
           -> KS Key
load_key'' :: [Name] -> Name -> Key -> EncrypedCopy -> KS Key
load_key'' [Name]
nm_s Name
nm Key
key EncrypedCopy
ec =
    case Name
nm Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
nm_s of
      Bool
True  -> Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key
      Bool
False ->
         do Maybe EncryptionKey
mbk <- Dirctn -> [Name] -> EncrypedCopy -> KS (Maybe EncryptionKey)
loadEncryptionKeyKS_ Dirctn
Decrypting (Name
nmName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
nm_s) EncrypedCopy
ec
            case Maybe EncryptionKey
mbk of
              Maybe EncryptionKey
Nothing -> Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key
              Just EncryptionKey
ek ->
                 do ClearText
ct <- EncrypedCopyData -> EncryptionKey -> KS ClearText
restoreKS (EncrypedCopy -> EncrypedCopyData
_ec_secret_data EncrypedCopy
ec) EncryptionKey
ek
                    Name -> ClearText -> KS ()
rememberKeyKS Name
nm ClearText
ct
                    Name -> KS Key
lookupKey Name
nm


-------------------------------------------------------------------------------
-- | Try to load an encryption or decryption key for an encrypted message.
loadEncryptionKeyKS :: Dirctn -> EncrypedCopy -> KS (Maybe EncryptionKey)
loadEncryptionKeyKS :: Dirctn -> EncrypedCopy -> KS (Maybe EncryptionKey)
loadEncryptionKeyKS Dirctn
dir EncrypedCopy
sc = Dirctn -> [Name] -> EncrypedCopy -> KS (Maybe EncryptionKey)
loadEncryptionKeyKS_ Dirctn
dir [] EncrypedCopy
sc

loadEncryptionKeyKS_ :: Dirctn -> [Name] -> EncrypedCopy -> KS (Maybe EncryptionKey)
loadEncryptionKeyKS_ :: Dirctn -> [Name] -> EncrypedCopy -> KS (Maybe EncryptionKey)
loadEncryptionKeyKS_ Dirctn
dir [Name]
nms_s EncrypedCopy
sc =
    case [Name]
nms of
      []   -> Maybe EncryptionKey -> KS (Maybe EncryptionKey)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe EncryptionKey -> KS (Maybe EncryptionKey))
-> Maybe EncryptionKey -> KS (Maybe EncryptionKey)
forall a b. (a -> b) -> a -> b
$ EncryptionKey -> Maybe EncryptionKey
forall a. a -> Maybe a
Just (EncryptionKey -> Maybe EncryptionKey)
-> EncryptionKey -> Maybe EncryptionKey
forall a b. (a -> b) -> a -> b
$ Void -> EncryptionKey
EK_none Void
void_
      [Name
nm] ->
         do Key
key <- Name -> KS Key
lookupKey Name
nm
            KS (Maybe EncryptionKey)
-> (PublicKey -> KS (Maybe EncryptionKey))
-> Maybe PublicKey
-> KS (Maybe EncryptionKey)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe KS (Maybe EncryptionKey)
sym (Dirctn -> Name -> PublicKey -> KS (Maybe EncryptionKey)
asm Dirctn
dir Name
nm) (Maybe PublicKey -> KS (Maybe EncryptionKey))
-> Maybe PublicKey -> KS (Maybe EncryptionKey)
forall a b. (a -> b) -> a -> b
$ Key -> Maybe PublicKey
_key_public Key
key
      [Name]
_    -> KS (Maybe EncryptionKey)
sym
  where
    sym :: KS (Maybe EncryptionKey)
sym =
     do [Key]
keys <- (Name -> KS Key) -> [Name] -> KS [Key]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> Name -> KS Key
load_key [Name]
nms_s) [Name]
nms
        case (Key -> Bool) -> [Key] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe ClearText -> Bool
forall a. Maybe a -> Bool
isJust(Maybe ClearText -> Bool)
-> (Key -> Maybe ClearText) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Key -> Maybe ClearText
_key_clear_text) [Key]
keys of
          Bool
True  -> EncryptionKey -> Maybe EncryptionKey
forall a. a -> Maybe a
Just (EncryptionKey -> Maybe EncryptionKey)
-> (AESKey -> EncryptionKey) -> AESKey -> Maybe EncryptionKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AESKey -> EncryptionKey
EK_symmetric (AESKey -> Maybe EncryptionKey)
-> KS AESKey -> KS (Maybe EncryptionKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            (EncrypedCopy -> [ClearText] -> KS AESKey
mkAESKeyKS EncrypedCopy
sc ([ClearText] -> KS AESKey) -> [ClearText] -> KS AESKey
forall a b. (a -> b) -> a -> b
$ [Maybe ClearText] -> [ClearText]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ClearText] -> [ClearText])
-> [Maybe ClearText] -> [ClearText]
forall a b. (a -> b) -> a -> b
$ (Key -> Maybe ClearText) -> [Key] -> [Maybe ClearText]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Maybe ClearText
_key_clear_text [Key]
keys)
          Bool
False -> Maybe EncryptionKey -> KS (Maybe EncryptionKey)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EncryptionKey
forall a. Maybe a
Nothing

    asm :: Dirctn -> Name -> PublicKey -> KS (Maybe EncryptionKey)
asm Dirctn
Encrypting Name
_  PublicKey
puk = Maybe EncryptionKey -> KS (Maybe EncryptionKey)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe EncryptionKey -> KS (Maybe EncryptionKey))
-> Maybe EncryptionKey -> KS (Maybe EncryptionKey)
forall a b. (a -> b) -> a -> b
$ EncryptionKey -> Maybe EncryptionKey
forall a. a -> Maybe a
Just (EncryptionKey -> Maybe EncryptionKey)
-> EncryptionKey -> Maybe EncryptionKey
forall a b. (a -> b) -> a -> b
$ PublicKey -> EncryptionKey
EK_public PublicKey
puk
    asm Dirctn
Decrypting Name
nm PublicKey
_   =
     do Key
key <- [Name] -> Name -> KS Key
load_key [Name]
nms_s Name
nm
        case Key -> Maybe PrivateKey
_key_clear_private Key
key of
          Maybe PrivateKey
Nothing  -> Maybe EncryptionKey -> KS (Maybe EncryptionKey)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EncryptionKey
forall a. Maybe a
Nothing
          Just PrivateKey
prk -> Maybe EncryptionKey -> KS (Maybe EncryptionKey)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe EncryptionKey -> KS (Maybe EncryptionKey))
-> Maybe EncryptionKey -> KS (Maybe EncryptionKey)
forall a b. (a -> b) -> a -> b
$ EncryptionKey -> Maybe EncryptionKey
forall a. a -> Maybe a
Just (EncryptionKey -> Maybe EncryptionKey)
-> EncryptionKey -> Maybe EncryptionKey
forall a b. (a -> b) -> a -> b
$ PrivateKey -> EncryptionKey
EK_private PrivateKey
prk

    nms :: [Name]
nms = Safeguard -> [Name]
safeguardKeys (Safeguard -> [Name]) -> Safeguard -> [Name]
forall a b. (a -> b) -> a -> b
$ EncrypedCopy -> Safeguard
_ec_safeguard EncrypedCopy
sc


-------------------------------------------------------------------------------
verify_key :: Key -> ClearText -> KS Key
verify_key :: Key -> ClearText -> KS Key
verify_key key :: Key
key@Key{Bool
Maybe PublicKey
Maybe PrivateKey
Maybe ClearText
Maybe EnvVar
Maybe Hash
UTCTime
EncrypedCopyMap
Name
Comment
Identity
_key_created_at :: UTCTime
_key_clear_private :: Maybe PrivateKey
_key_clear_text :: Maybe ClearText
_key_secret_copies :: EncrypedCopyMap
_key_public :: Maybe PublicKey
_key_hash :: Maybe Hash
_key_env_var :: Maybe EnvVar
_key_is_binary :: Bool
_key_identity :: Identity
_key_comment :: Comment
_key_name :: Name
_key_created_at :: Key -> UTCTime
_key_clear_text :: Key -> Maybe ClearText
_key_secret_copies :: Key -> EncrypedCopyMap
_key_hash :: Key -> Maybe Hash
_key_env_var :: Key -> Maybe EnvVar
_key_is_binary :: Key -> Bool
_key_identity :: Key -> Identity
_key_comment :: Key -> Comment
_key_name :: Key -> Name
_key_clear_private :: Key -> Maybe PrivateKey
_key_public :: Key -> Maybe PublicKey
..} ClearText
ct =
    case (Maybe Hash
_key_hash,Maybe PublicKey
_key_public) of
      (Just Hash
hsh,Maybe PublicKey
_       ) ->
        case Hash -> ClearText -> Bool
verify_key_ Hash
hsh ClearText
ct of
          Bool
True  -> Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key { _key_clear_text :: Maybe ClearText
_key_clear_text = ClearText -> Maybe ClearText
forall a. a -> Maybe a
Just ClearText
ct }
          Bool
False -> String -> KS Key
forall a. String -> KS a
errorKS String
"key failed to match hash"
      (Maybe Hash
Nothing ,Just PublicKey
puk) ->
         do PrivateKey
prk <- E PrivateKey -> KS PrivateKey
forall a. E a -> KS a
e2ks (E PrivateKey -> KS PrivateKey) -> E PrivateKey -> KS PrivateKey
forall a b. (a -> b) -> a -> b
$ PublicKey -> ClearText -> E PrivateKey
verify_private_key_ PublicKey
puk ClearText
ct
            Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return
                Key
key { _key_clear_text :: Maybe ClearText
_key_clear_text    = ClearText -> Maybe ClearText
forall a. a -> Maybe a
Just ClearText
ct
                    , _key_clear_private :: Maybe PrivateKey
_key_clear_private = PrivateKey -> Maybe PrivateKey
forall a. a -> Maybe a
Just PrivateKey
prk
                    }
      (Maybe Hash, Maybe PublicKey)
_ -> Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return
                Key
key { _key_clear_text :: Maybe ClearText
_key_clear_text    = ClearText -> Maybe ClearText
forall a. a -> Maybe a
Just ClearText
ct
                    }

verify_key_ :: Hash -> ClearText -> Bool
verify_key_ :: Hash -> ClearText -> Bool
verify_key_ Hash
hsh ClearText
ct =
            Hash -> HashData
_hash_hash(HashDescription -> ClearText -> Hash
hashKS_ (Hash -> HashDescription
_hash_description Hash
hsh) ClearText
ct) HashData -> HashData -> Bool
forall a. Eq a => a -> a -> Bool
== Hash -> HashData
_hash_hash Hash
hsh

verify_private_key_ :: PublicKey -> ClearText -> E PrivateKey
verify_private_key_ :: PublicKey -> ClearText -> E PrivateKey
verify_private_key_ PublicKey
puk ClearText
ct =
 do PrivateKey
prk <- ClearText -> E PrivateKey
decodePrivateKeyDERE ClearText
ct
    case PublicKey
pukPublicKey -> PublicKey -> Bool
forall a. Eq a => a -> a -> Bool
==PrivateKey -> PublicKey
private_pub PrivateKey
prk of
      Bool
True  -> PrivateKey -> E PrivateKey
forall (m :: * -> *) a. Monad m => a -> m a
return PrivateKey
prk
      Bool
False -> Reason -> E PrivateKey
forall a b. a -> Either a b
Left (Reason -> E PrivateKey) -> Reason -> E PrivateKey
forall a b. (a -> b) -> a -> b
$ String -> Reason
forall a. Error a => String -> a
strMsg String
"private key mismatches public key"


-------------------------------------------------------------------------------
cleanKeyMap :: KeyMap -> KeyMap
cleanKeyMap :: KeyMap -> KeyMap
cleanKeyMap KeyMap
mp = (Key -> Key) -> KeyMap -> KeyMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Key -> Key
cln KeyMap
mp
  where
    cln :: Key -> Key
cln Key
key =
        Key
key { _key_clear_text :: Maybe ClearText
_key_clear_text    = Maybe ClearText
forall a. Maybe a
Nothing
            , _key_clear_private :: Maybe PrivateKey
_key_clear_private = Maybe PrivateKey
forall a. Maybe a
Nothing
            }