{-# 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 = forall a. ToJSON a => a -> ByteString
encode 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 forall a b. (a -> b) -> a -> b
$ KeyStore -> KeyMap
_ks_keymap KeyStore
ks
}
keyStoreFromBytes :: LBS.ByteString -> E KeyStore
keyStoreFromBytes :: ByteString -> E KeyStore
keyStoreFromBytes = forall {b}. Maybe b -> Either Reason b
chk forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
FromJSONWithErrs a =>
ByteString -> Either [(JSONError, Position)] a
decodeWithErrs
where
chk :: Maybe b -> Either Reason b
chk Maybe b
Nothing = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Reason
strMsg String
"failed to decode keystore file"
chk (Just b
ks) = forall a b. b -> Either a b
Right b
ks
settingsFromBytes :: LBS.ByteString -> E Settings
settingsFromBytes :: ByteString -> E Settings
settingsFromBytes = Maybe Value -> E Settings
chk forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
FromJSONWithErrs a =>
ByteString -> Either [(JSONError, Position)] a
decodeWithErrs
where
chk :: Maybe Value -> E Settings
chk (Just(Object Object
fm)) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> Settings
Settings forall a b. (a -> b) -> a -> b
$ forall a. KM a -> HashMap Text a
fromKM Object
fm
chk Maybe Value
_ = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Reason
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 forall a. Maybe a
Nothing 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 forall a b. (a -> b) -> a -> b
$ PrivateKey -> ClearText
encodePrivateKeyDER PrivateKey
prk
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 = 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]) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
RSASecretData -> RSASecretBytes
encodeRSASecretData 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 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return RSASecretData
rsd
EncrypedCopyData
_ -> 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) <- forall a. E a -> KS a
e2ks 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] -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
[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 -> 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 -> forall a. String -> KS a
errorKS String
"could not load private key"
Just PrivateKey
prk -> Safeguard -> RSASignature -> SignaturePacket
encocdeSignaturePacket ([Name] -> Safeguard
safeguard [Name
nm]) 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) <- forall a. E a -> KS a
e2ks 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] -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
[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 -> forall a. String -> KS a
errorKS String
"not an RSA key pair"
Just PublicKey
puk -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> forall a. String -> KS a
errorKS String
"could not load keys"
Just EncryptionKey
ek -> forall (m :: * -> *) a. Monad m => a -> m a
return EncryptionKey
ek
EncrypedCopyData
ecd <- EncryptionKey -> ClearText -> KS EncrypedCopyData
saveKS EncryptionKey
ek ClearText
ct
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 -> forall a. String -> KS a
errorKS String
"could not load keys"
Just EncryptionKey
ek -> 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 = forall a. Name -> KS a -> KS a
withKey Name
nm forall a b. (a -> b) -> a -> b
$
do UTCTime
now <- KS UTCTime
currentTime
Key -> KS ()
insertNewKey
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 = forall a. Maybe a
Nothing
, _key_public :: Maybe PublicKey
_key_public = forall a. Maybe a
Nothing
, _key_secret_copies :: EncrypedCopyMap
_key_secret_copies = forall k a. Map k a
Map.empty
, _key_clear_text :: Maybe ClearText
_key_clear_text = forall a. Maybe a
Nothing
, _key_clear_private :: Maybe PrivateKey
_key_clear_private = forall a. Maybe a
Nothing
, _key_created_at :: UTCTime
_key_created_at = UTCTime
now
}
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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 forall a b. (a -> b) -> a -> b
$ String
"remembering " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
nm 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 = forall a. a -> Maybe a
Just ClearText
ct }
Bool
vfy <- 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 -> 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 | forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Key -> Maybe PublicKey
_key_public Key
key2 -> Key -> Hash -> Key
upd Key
key2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClearText -> KS Hash
hashKS ClearText
ct
Maybe Hash
_ -> 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 = forall a. a -> Maybe a
Just Hash
hsh
}
backupKeysKS :: KS ()
backupKeysKS :: KS ()
backupKeysKS = KS [Key]
getKeysKS forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name -> KS ()
backupKeyKS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Name
_key_name)
backupKeyKS :: Name -> KS ()
backupKeyKS :: Name -> KS ()
backupKeyKS Name
nm = forall a. Name -> KS a -> KS a
withKey Name
nm forall a b. (a -> b) -> a -> b
$
do [Name]
nms <- forall a. Show a => Opt a -> KS a
lookupOpt Opt [Name]
opt__backup_keys
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 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 = forall a. Name -> KS a -> KS a
withKey Name
nm 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 forall a b. (a -> b) -> a -> b
$ String
"securing " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
nm forall a. [a] -> [a] -> [a]
++ String
" with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Safeguard
sg forall a. [a] -> [a] -> [a]
++ String
"\n"
Key
key <- Name -> KS Key
loadKeyKS Name
nm
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Safeguard
sg forall a b. (a -> b) -> a -> b
$ Key -> EncrypedCopyMap
_key_secret_copies Key
key) forall a b. (a -> b) -> a -> b
$
do ClearText
ct <- case Key -> Maybe ClearText
_key_clear_text Key
key of
Maybe ClearText
Nothing -> forall a. String -> KS a
errorKS forall a b. (a -> b) -> a -> b
$ Name -> String
_name Name
nm forall a. [a] -> [a] -> [a]
++ String
": cannot load key"
Just ClearText
ct -> 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 -> forall a. String -> KS a
errorKS forall a b. (a -> b) -> a -> b
$
Safeguard -> String
printSafeguard Safeguard
sg forall a. [a] -> [a] -> [a]
++ String
": cannot load encryption keys"
Just EncryptionKey
ek -> 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 forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
L.over Lens' Key EncrypedCopyMap
key_secret_copies (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 <- forall a b. (a -> b) -> [a] -> [b]
map Key -> Name
_key_name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KS [Key]
getKeysKS
[Key]
keys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> KS Key
loadKeyKS forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [Name]
nms
String -> KS ()
putStrKS forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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 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
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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Line -> String
fmt forall a b. (a -> b) -> a -> b
$
[ String -> Line
LnHeader String
hdr ] forall a. [a] -> [a] -> [a]
++
[ UTCTime -> Line
LnDate UTCTime
_key_created_at ] forall a. [a] -> [a] -> [a]
++
[ String -> Line
LnHash String
hsh | Just String
hsh<-[Maybe String
mb_hsh] ] forall a. [a] -> [a] -> [a]
++
[ Line
LnCopiesHeader ] forall a. [a] -> [a] -> [a]
++
[ String -> Line
LnCopy forall a b. (a -> b) -> a -> b
$ forall {t}. PrintfType t => EncrypedCopy -> t
fmt_ec EncrypedCopy
ec | EncrypedCopy
ec<-forall k a. Map k a -> [a]
Map.elems 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 -> forall {t} {t}.
(PrintfArg t, PrintfArg t) =>
Int -> t -> t -> String
fmt_ln Int
2 String
"Date:" forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UTCTime
u
LnHash String
s -> forall {t} {t}.
(PrintfArg t, PrintfArg t) =>
Int -> t -> t -> String
fmt_ln Int
2 String
"Hash:" String
s
Line
LnCopiesHeader -> 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 = 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (forall r. PrintfType r => String -> r
printf String
" ($%s)" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack 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 forall a b. (a -> b) -> a -> b
$ Comment -> Text
_Comment Comment
_key_comment
mb_hsh :: Maybe String
mb_hsh = forall {t}. PrintfType t => Hash -> t
fmt_hsh 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
..} = forall r. PrintfType r => String -> r
printf String
"%s(%d*%s[%s])" String
ci Int
is String
pf String
sg
where
ci :: String
ci = forall a. Show a => a -> String
show Cipher
_ec_cipher
Iterations Int
is = Iterations
_ec_iterations
pf :: String
pf = 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
..}} = 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 = 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 forall a b. (a -> b) -> a -> b
$ 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 = forall a. Int -> a -> [a]
replicate Int
i Char
' ' 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
..} = 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (forall r. PrintfType r => String -> r
printf String
" ($%s)" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvVar -> Text
_EnvVar) Maybe EnvVar
_key_env_var
ecs :: String
ecs = forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Safeguard -> String
printSafeguard forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncrypedCopy -> Safeguard
_ec_safeguard) forall a b. (a -> b) -> a -> b
$
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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Char
'-' (forall a b. a -> b -> a
const Char
'T') Maybe ClearText
_key_clear_text
sts_p :: Char
sts_p = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Char
'-' (forall a b. a -> b -> a
const Char
'P') Maybe PublicKey
_key_public
getKeysKS :: KS [Key]
getKeysKS :: KS [Key]
getKeysKS = forall k a. Map k a -> [a]
Map.elems 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
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Name] -> Name -> KS Key
load_key' [Name]
nm_s Name
nm) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Key
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 [] = 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Key
key
[EncrypedCopy] -> KS Key
ld forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
nm_s of
Bool
True -> 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
nmforall a. a -> [a] -> [a]
:[Name]
nm_s) EncrypedCopy
ec
case Maybe EncryptionKey
mbk of
Maybe EncryptionKey
Nothing -> 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
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Void -> EncryptionKey
EK_none Void
void_
[Name
nm] ->
do Key
key <- Name -> KS Key
lookupKey Name
nm
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) 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 <- 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Maybe a -> Bool
isJustforall b c a. (b -> c) -> (a -> b) -> a -> c
.Key -> Maybe ClearText
_key_clear_text) [Key]
keys of
Bool
True -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. AESKey -> EncryptionKey
EK_symmetric forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(EncrypedCopy -> [ClearText] -> KS AESKey
mkAESKeyKS EncrypedCopy
sc forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Key -> Maybe ClearText
_key_clear_text [Key]
keys)
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
asm :: Dirctn -> Name -> PublicKey -> KS (Maybe EncryptionKey)
asm Dirctn
Encrypting Name
_ PublicKey
puk = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just PrivateKey
prk -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PrivateKey -> EncryptionKey
EK_private PrivateKey
prk
nms :: [Name]
nms = Safeguard -> [Name]
safeguardKeys 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Key
key { _key_clear_text :: Maybe ClearText
_key_clear_text = forall a. a -> Maybe a
Just ClearText
ct }
Bool
False -> forall a. String -> KS a
errorKS String
"key failed to match hash"
(Maybe Hash
Nothing ,Just PublicKey
puk) ->
do PrivateKey
prk <- forall a. E a -> KS a
e2ks forall a b. (a -> b) -> a -> b
$ PublicKey -> ClearText -> E PrivateKey
verify_private_key_ PublicKey
puk ClearText
ct
forall (m :: * -> *) a. Monad m => a -> m a
return
Key
key { _key_clear_text :: Maybe ClearText
_key_clear_text = forall a. a -> Maybe a
Just ClearText
ct
, _key_clear_private :: Maybe PrivateKey
_key_clear_private = forall a. a -> Maybe a
Just PrivateKey
prk
}
(Maybe Hash, Maybe PublicKey)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return
Key
key { _key_clear_text :: Maybe ClearText
_key_clear_text = 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) 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
pukforall a. Eq a => a -> a -> Bool
==PrivateKey -> PublicKey
private_pub PrivateKey
prk of
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return PrivateKey
prk
Bool
False -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Reason
strMsg String
"private key mismatches public key"
cleanKeyMap :: KeyMap -> KeyMap
cleanKeyMap :: KeyMap -> KeyMap
cleanKeyMap KeyMap
mp = 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 = forall a. Maybe a
Nothing
, _key_clear_private :: Maybe PrivateKey
_key_clear_private = forall a. Maybe a
Nothing
}