{-# 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
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
}
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
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"
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 }
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"
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
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
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
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 }
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
createKeyKS :: Name
-> Comment
-> Identity
-> Maybe EnvVar
-> Maybe ClearText
-> 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
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
}
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)
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']
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
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
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
= String
| LnDate UTCTime
| LnHash String
|
| 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
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
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
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
}