{-# LANGUAGE CPP                        #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE ScopedTypeVariables        #-}

-- | This module provide an IO-based API. The /ks/ executable provides
-- some keystore management functions that can be used from the shell
-- and "Data.KeyStore.KeyStore" provides the underlying functional model.

module Data.KeyStore.IO
    ( readSettings
    , CtxParams(..)
    , IC(..)
    , module Data.KeyStore.Types
    , module Data.KeyStore.KS.KS
    , keyStoreBytes
    , keyStoreFromBytes
    , settingsFromBytes
    , defaultSettingsFilePath
    , settingsFilePath
    , defaultKeyStoreFilePath
    , defaultCtxParams
    , instanceCtx
    , instanceCtx_
    , newKeyStore
    , store
    , listSettings
    , settings
    , updateSettings
    , listTriggers
    , triggers
    , addTrigger
    , addTrigger'
    , rmvTrigger
    , createRSAKeyPair
    , createKey
    , adjustKey
    , rememberKey
    , rememberKey_
    , secureKey
    , loadKey
    , showIdentity
    , showComment
    , showDate
    , showHash
    , showHashComment
    , showHashSalt
    , showPublic
    , showSecret
    , keys
    , list
    , keyInfo
    , deleteKeys
    , encrypt
    , encrypt_
    , encrypt__
    , decrypt
    , decrypt_
    , decrypt__
    , sign
    , sign_
    , verify
    , verify_
    , run
    , getKeystore
    , getState
    , getCtxState
    , putCtxState
    ) where

import           Data.KeyStore.IO.IC
import           Data.KeyStore.KS
import           Data.KeyStore.KS.KS
import           Data.KeyStore.Types
import           Data.KeyStore.Types.AesonCompat
import           Data.API.Types
import           Data.IORef
import qualified Data.Text                      as T
import qualified Data.ByteString.Char8          as B
import qualified Data.ByteString.Lazy.Char8     as LBS
import qualified Data.ByteString.Base64         as B64
import qualified Data.Map                       as Map
import           Data.Time
import           Text.Printf
import qualified Control.Exception              as X
import qualified Control.Lens                   as L
import           Control.Monad
import           System.IO

#if MIN_VERSION_time(1,5,0)
#else
import           System.Locale (defaultTimeLocale)
#endif

-- | Generate a new keystore located in the given file with the given global
-- settings.
newKeyStore :: FilePath -> Settings -> IO ()
newKeyStore :: String -> Settings -> IO ()
newKeyStore String
str_fp Settings
stgs =
 do Either SomeException ByteString
ei <- forall e a. Exception e => IO a -> IO (Either e a)
X.try forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
str_fp :: IO (Either X.SomeException B.ByteString)
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. String -> IO a
errorIO String
"keystore file exists") Either SomeException ByteString
ei
    CPRNG
g  <- IO CPRNG
newGenerator
    let state :: State
state =
            State
                { st_keystore :: KeyStore
st_keystore = Configuration -> KeyStore
emptyKeyStore forall a b. (a -> b) -> a -> b
$ Settings -> Configuration
defaultConfiguration Settings
stgs
                , st_cprng :: CPRNG
st_cprng    = CPRNG
g
                }
    String -> ByteString -> IO ()
LBS.writeFile String
str_fp forall a b. (a -> b) -> a -> b
$ KeyStore -> ByteString
keyStoreBytes forall a b. (a -> b) -> a -> b
$ State -> KeyStore
st_keystore State
state

-- | Given 'CtxParams' describing the location of the keystore, etc., generate
-- an IC for use in the following keystore access functions that will allow
-- context to be cached between calls to these access functions.
instanceCtx :: CtxParams -> IO IC
instanceCtx :: CtxParams -> IO IC
instanceCtx CtxParams
cp =
 do (Ctx, State)
ctx_st <- IC -> IO (Ctx, State)
getCtxState forall a b. (a -> b) -> a -> b
$ CtxParams -> IC
instanceCtx_ CtxParams
cp
    CtxParams -> Maybe (IORef (Ctx, State)) -> IC
IC CtxParams
cp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef (Ctx, State)
ctx_st

-- | This functional method will generate an IC that will not cache any
-- state between calls.
instanceCtx_ :: CtxParams -> IC
instanceCtx_ :: CtxParams -> IC
instanceCtx_ CtxParams
cp = CtxParams -> Maybe (IORef (Ctx, State)) -> IC
IC CtxParams
cp forall a. Maybe a
Nothing

-- | the filepath of the loaded store
store :: IC -> IO FilePath
store :: IC -> IO String
store IC
ic = forall a. IC -> KS a -> IO a
run IC
ic KS String
storeKS

-- | List the JSON settings on stdout.
listSettings :: IC -> IO ()
listSettings :: IC -> IO ()
listSettings IC
ic = IC -> IO Settings
settings IC
ic forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ()
LBS.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> HashMap Text Value
_Settings

-- | Return the settings associated with the keystore.
settings :: IC -> IO Settings
settings :: IC -> IO Settings
settings IC
ic = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Configuration -> Settings
_cfg_settings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KS Configuration
getConfig

-- | Update the global settings of a keystore from the given JSON settings.
updateSettings :: IC -> FilePath -> IO ()
updateSettings :: IC -> String -> IO ()
updateSettings IC
ic String
fp =
 do ByteString
bs   <- String -> IO ByteString
LBS.readFile String
fp
    Settings
stgs <- forall a. E a -> IO a
e2io forall a b. (a -> b) -> a -> b
$ ByteString -> E Settings
settingsFromBytes ByteString
bs
    forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ (Configuration -> Configuration) -> KS ()
modConfig forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
L.over Lens' Configuration Settings
cfg_settings forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Settings
stgs

-- | List the triggers set up in the keystore on stdout.
listTriggers :: IC -> IO ()
listTriggers :: IC -> IO ()
listTriggers IC
ic = IC -> IO [Trigger]
triggers IC
ic forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {t}. PrintfType t => Trigger -> t
fmt
  where
    fmt :: Trigger -> t
fmt Trigger{Settings
Pattern
TriggerID
_trg_settings :: Trigger -> Settings
_trg_pattern :: Trigger -> Pattern
_trg_id :: Trigger -> TriggerID
_trg_settings :: Settings
_trg_pattern :: Pattern
_trg_id :: TriggerID
..} = forall r. PrintfType r => String -> r
printf String
"%-12s : %12s => %s" String
id_s String
pat_s String
stgs_s
      where
        id_s :: String
id_s   = Text -> String
T.unpack   forall a b. (a -> b) -> a -> b
$ TriggerID -> Text
_TriggerID                  TriggerID
_trg_id
        pat_s :: String
pat_s  = Pattern -> String
_pat_string                              Pattern
_trg_pattern
        stgs_s :: String
stgs_s = ByteString -> String
LBS.unpack forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall a. HashMap Text a -> KM a
intoKM forall a b. (a -> b) -> a -> b
$ Settings -> HashMap Text Value
_Settings Settings
_trg_settings

-- | Returns the striggers setup on the keystore.
triggers :: IC -> IO [Trigger]
triggers :: IC -> IO [Trigger]
triggers IC
ic = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> TriggerMap
_cfg_triggers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KS Configuration
getConfig

-- | addTrigger' cariant that erads the setting from a file.
addTrigger :: IC -> TriggerID -> Pattern -> FilePath -> IO ()
addTrigger :: IC -> TriggerID -> Pattern -> String -> IO ()
addTrigger IC
ic TriggerID
tid Pattern
pat String
fp =
 do ByteString
bs   <- String -> IO ByteString
LBS.readFile String
fp
    Settings
stgs <- forall a. E a -> IO a
e2io forall a b. (a -> b) -> a -> b
$ ByteString -> E Settings
settingsFromBytes ByteString
bs
    IC -> TriggerID -> Pattern -> Settings -> IO ()
addTrigger' IC
ic TriggerID
tid Pattern
pat Settings
stgs

-- | Set up a named trigger on a keystore that will fire when a key matches the
-- given pattern establishing the settings.
addTrigger' :: IC -> TriggerID -> Pattern -> Settings -> IO ()
addTrigger' :: IC -> TriggerID -> Pattern -> Settings -> IO ()
addTrigger' IC
ic TriggerID
tid Pattern
pat Settings
stgs =
    forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ (Configuration -> Configuration) -> KS ()
modConfig forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
L.over Lens' Configuration TriggerMap
cfg_triggers forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TriggerID
tid forall a b. (a -> b) -> a -> b
$ TriggerID -> Pattern -> Settings -> Trigger
Trigger TriggerID
tid Pattern
pat Settings
stgs

-- | Remove the named trigger from the keystore.
rmvTrigger :: IC -> TriggerID -> IO ()
rmvTrigger :: IC -> TriggerID -> IO ()
rmvTrigger IC
ic TriggerID
tid = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ (Configuration -> Configuration) -> KS ()
modConfig forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
L.over Lens' Configuration TriggerMap
cfg_triggers forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TriggerID
tid

-- | Create an RSA key pair, encoding the private key in the named Safeguards.
createRSAKeyPair :: IC -> Name -> Comment -> Identity -> [Safeguard] -> IO ()
createRSAKeyPair :: IC -> Name -> Comment -> Identity -> [Safeguard] -> IO ()
createRSAKeyPair IC
ic Name
nm Comment
cmt Identity
ide [Safeguard]
sgs = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> Comment -> Identity -> [Safeguard] -> KS ()
createRSAKeyPairKS Name
nm Comment
cmt Identity
ide [Safeguard]
sgs

-- | Create a symmetric key, possibly auto-loaded from an environment variable.
createKey :: IC
          -> Name
          -> Comment
          -> Identity
          -> Maybe EnvVar
          -> Maybe B.ByteString
          -> IO ()
createKey :: IC
-> Name
-> Comment
-> Identity
-> Maybe EnvVar
-> Maybe ByteString
-> IO ()
createKey IC
ic Name
nm Comment
cmt Identity
ide Maybe EnvVar
mb_ev Maybe ByteString
mb_bs =
            forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name
-> Comment -> Identity -> Maybe EnvVar -> Maybe ClearText -> KS ()
createKeyKS Name
nm Comment
cmt Identity
ide Maybe EnvVar
mb_ev (Binary -> ClearText
ClearText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Binary
Binary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
mb_bs)

-- | Adjust a named key.
adjustKey :: IC -> Name -> (Key->Key) -> IO ()
adjustKey :: IC -> Name -> (Key -> Key) -> IO ()
adjustKey IC
ic Name
nm Key -> Key
adj = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> (Key -> Key) -> KS ()
adjustKeyKS Name
nm Key -> Key
adj

-- | Load a named key from the named file.
rememberKey :: IC -> Name -> FilePath -> IO ()
rememberKey :: IC -> Name -> String -> IO ()
rememberKey IC
ic Name
nm String
fp = String -> IO ByteString
B.readFile String
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IC -> Name -> ByteString -> IO ()
rememberKey_ IC
ic Name
nm

-- | Load the named key.
rememberKey_ :: IC -> Name -> B.ByteString -> IO ()
rememberKey_ :: IC -> Name -> ByteString -> IO ()
rememberKey_ IC
ic Name
nm ByteString
bs = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> ClearText -> KS ()
rememberKeyKS Name
nm forall a b. (a -> b) -> a -> b
$ Binary -> ClearText
ClearText forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
bs

-- | Encrypt and store the key with the named safeguard.
secureKey :: IC -> Name -> Safeguard -> IO ()
secureKey :: IC -> Name -> Safeguard -> IO ()
secureKey IC
ic Name
nm Safeguard
nms = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> Safeguard -> KS ()
secureKeyKS Name
nm Safeguard
nms

-- | Try and retrieve the secret text for a given key.
loadKey :: IC -> Name -> IO Key
loadKey :: IC -> Name -> IO Key
loadKey IC
ic Name
nm = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> KS Key
loadKeyKS Name
nm

-- | Return the identity of a key.
showIdentity :: IC -> Bool -> Name -> IO B.ByteString
showIdentity :: IC -> Bool -> Name -> IO ByteString
showIdentity IC
ic = forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic String
"identity" (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Identity
_key_identity) (String -> ByteString
B.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity -> Text
_Identity)

-- | Return the comment associated with a key.
showComment :: IC -> Bool -> Name -> IO B.ByteString
showComment :: IC -> Bool -> Name -> IO ByteString
showComment IC
ic = forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic String
"comment"  (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Comment
_key_comment)  (String -> ByteString
B.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> Text
_Comment )

-- | Return the creation UTC of a key.
showDate :: IC -> Bool -> Name -> IO B.ByteString
showDate :: IC -> Bool -> Name -> IO ByteString
showDate IC
ic = forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic String
"date" (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> UTCTime
_key_created_at) (String -> ByteString
B.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
fmt)
  where
    fmt :: String
fmt = String
"%F-%TZ"

-- | Return the hash of a key.
showHash :: IC -> Bool -> Name -> IO B.ByteString
showHash :: IC -> Bool -> Name -> IO ByteString
showHash IC
ic = forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic String
"hash" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash -> HashData
_hash_hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe Hash
_key_hash) HashData -> Binary
_HashData

-- | Return the hash comment of a key/
showHashComment :: IC -> Bool -> Name -> IO B.ByteString
showHashComment :: IC -> Bool -> Name -> IO ByteString
showHashComment IC
ic = forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic String
"hash" Key -> Maybe Hash
_key_hash Hash -> ByteString
cmt
  where
    cmt :: Hash -> ByteString
cmt = String -> ByteString
B.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> Text
_Comment forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashDescription -> Comment
_hashd_comment forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> HashDescription
_hash_description

-- | Retuen the hash salt of a key.
showHashSalt :: IC -> Bool -> Name -> IO B.ByteString
showHashSalt :: IC -> Bool -> Name -> IO ByteString
showHashSalt IC
ic = forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic String
"hash" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HashDescription -> Salt
_hashd_salt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> HashDescription
_hash_description) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe Hash
_key_hash) Salt -> Binary
_Salt

-- | (For public key pairs only) return the public key.
showPublic  :: IC -> Bool -> Name -> IO B.ByteString
showPublic :: IC -> Bool -> Name -> IO ByteString
showPublic IC
ic = forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic String
"public" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PublicKey -> ClearText
encodePublicKeyDER forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe PublicKey
_key_public) ClearText -> Binary
_ClearText

-- | Return the secret text of a key (will be the private key for a public key pair).
showSecret :: IC -> Bool -> Name -> IO B.ByteString
showSecret :: IC -> Bool -> Name -> IO ByteString
showSecret IC
ic = forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic String
"secret" Key -> Maybe ClearText
_key_clear_text ClearText -> Binary
_ClearText

show_it :: IC
        -> String
        -> (Key->Maybe a)
        -> (a->Binary)
        -> Bool
        -> Name
        -> IO B.ByteString
show_it :: forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic String
lbl Key -> Maybe a
prj_1 a -> Binary
prj_2 Bool
aa Name
nm = forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic String
lbl Key -> Maybe a
prj_1 (Binary -> ByteString
_Binary forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Binary
prj_2) Bool
aa Name
nm

show_it' :: IC
         -> String
         -> (Key->Maybe a)
         -> (a->B.ByteString)
         -> Bool
         -> Name
         -> IO B.ByteString
show_it' :: forall a.
IC
-> String
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic String
lbl Key -> Maybe a
prj_1 a -> ByteString
prj_2 Bool
aa Name
nm =
 do Key
key <- IC -> Name -> IO Key
loadKey IC
ic Name
nm
    case a -> ByteString
prj_2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Maybe a
prj_1 Key
key of
      Maybe ByteString
Nothing -> forall a. String -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%s: %s not present" (Name -> String
_name Name
nm) String
lbl
      Just ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
armr ByteString
bs
  where
    armr :: ByteString -> ByteString
armr = if Bool
aa then ByteString -> ByteString
B64.encode else forall a. a -> a
id

-- | List a summary of all of the keys on stdout.
list :: IC -> IO ()
list :: IC -> IO ()
list IC
ic = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ KS ()
listKS

-- Summarize a single key on stdout.
keyInfo :: IC -> Name -> IO ()
keyInfo :: IC -> Name -> IO ()
keyInfo IC
ic Name
nm = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> KS ()
keyInfoKS Name
nm

-- | Return all of the keys in the keystore.
keys :: IC -> IO [Key]
keys :: IC -> IO [Key]
keys IC
ic = forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyStore -> KeyMap
_ks_keymap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> IO KeyStore
getKeystore IC
ic

-- | Delete a list of keys from the keystore.
deleteKeys :: IC -> [Name] -> IO ()
deleteKeys :: IC -> [Name] -> IO ()
deleteKeys IC
ic [Name]
nms = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ [Name] -> KS ()
deleteKeysKS [Name]
nms

-- Encrypt a file with a named key.
encrypt :: IC -> Name -> FilePath -> FilePath -> IO ()
encrypt :: IC -> Name -> String -> String -> IO ()
encrypt IC
ic Name
nm String
s_fp String
d_fp =
 do ByteString
bs <- String -> IO ByteString
B.readFile String
s_fp
    ByteString
bs' <- IC -> Name -> ByteString -> IO ByteString
encrypt_ IC
ic Name
nm ByteString
bs
    String -> ByteString -> IO ()
B.writeFile String
d_fp ByteString
bs'

-- | Encrypt a 'B.ByteString' with a named key.
encrypt_ :: IC -> Name -> B.ByteString -> IO B.ByteString
encrypt_ :: IC -> Name -> ByteString -> IO ByteString
encrypt_ IC
ic Name
nm ByteString
bs = Binary -> ByteString
_Binary forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncryptionPacket -> Binary
_EncryptionPacket forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> ClearText -> KS EncryptionPacket
encryptWithRSAKeyKS Name
nm forall a b. (a -> b) -> a -> b
$ Binary -> ClearText
ClearText forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
bs)

-- | Encrypt a 'B.ByteString' with a named key to produce a 'RSASecretData'.

encrypt__ :: IC -> Name -> B.ByteString -> IO RSASecretData
encrypt__ :: IC -> Name -> ByteString -> IO RSASecretData
encrypt__ IC
ic Name
nm ByteString
bs = forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> ClearText -> KS RSASecretData
encryptWithRSAKeyKS_ Name
nm forall a b. (a -> b) -> a -> b
$ Binary -> ClearText
ClearText forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
bs


-- | Decrypt a file with the named key (whose secret text must be accessible).
decrypt :: IC -> FilePath -> FilePath -> IO ()
decrypt :: IC -> String -> String -> IO ()
decrypt IC
ic String
s_fp String
d_fp =
 do ByteString
bs <- String -> IO ByteString
B.readFile String
s_fp
    ByteString
bs' <- IC -> ByteString -> IO ByteString
decrypt_ IC
ic ByteString
bs
    String -> ByteString -> IO ()
B.writeFile String
d_fp ByteString
bs'

-- | Decrypt a 'B.ByteString' with the named key
-- (whose secret text must be accessible).
decrypt_ :: IC -> B.ByteString -> IO B.ByteString
decrypt_ :: IC -> ByteString -> IO ByteString
decrypt_ IC
ic ByteString
bs = Binary -> ByteString
_Binary forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClearText -> Binary
_ClearText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ EncryptionPacket -> KS ClearText
decryptWithRSAKeyKS forall a b. (a -> b) -> a -> b
$ Binary -> EncryptionPacket
EncryptionPacket forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
bs)

-- | Decrypt a 'B.ByteString' from a 'RSASecretData' with the named key
-- (whose secret text must be accessible).
decrypt__ :: IC -> Name -> RSASecretData -> IO B.ByteString
decrypt__ :: IC -> Name -> RSASecretData -> IO ByteString
decrypt__ IC
ic Name
nm RSASecretData
rsd = Binary -> ByteString
_Binary forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClearText -> Binary
_ClearText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> RSASecretData -> KS ClearText
decryptWithRSAKeyKS_ Name
nm RSASecretData
rsd)

-- | Sign a file with the named key (whose secret text must be accessible)
-- to produce a detached signature in the named file.
sign :: IC -> Name -> FilePath -> FilePath -> IO ()
sign :: IC -> Name -> String -> String -> IO ()
sign IC
ic Name
nm String
s_fp String
d_fp =
 do ByteString
bs <- String -> IO ByteString
B.readFile String
s_fp
    ByteString
bs' <- IC -> Name -> ByteString -> IO ByteString
sign_ IC
ic Name
nm ByteString
bs
    String -> ByteString -> IO ()
B.writeFile String
d_fp ByteString
bs'

-- | Sign a 'B.ByteString' with the named key (whose secret text must be accessible)
-- to produce a detached signature.
sign_ :: IC -> Name -> B.ByteString -> IO B.ByteString
sign_ :: IC -> Name -> ByteString -> IO ByteString
sign_ IC
ic Name
nm ByteString
m_bs = Binary -> ByteString
_Binary forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignaturePacket -> Binary
_SignaturePacket forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ Name -> ClearText -> KS SignaturePacket
signWithRSAKeyKS Name
nm forall a b. (a -> b) -> a -> b
$ Binary -> ClearText
ClearText forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
m_bs)

-- | Verify that a signature for a file via the named public key.
verify :: IC -> FilePath -> FilePath -> IO Bool
verify :: IC -> String -> String -> IO Bool
verify IC
ic String
m_fp String
s_fp =
 do ByteString
m_bs <- String -> IO ByteString
B.readFile String
m_fp
    ByteString
s_bs <- String -> IO ByteString
B.readFile String
s_fp
    Bool
ok <- IC -> ByteString -> ByteString -> IO Bool
verify_ IC
ic ByteString
m_bs ByteString
s_bs
    case Bool
ok of
      Bool
True  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Bool
False -> String -> IO ()
report String
"signature does not match the data"
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ok

-- | Verify that a signature for a 'B.ByteString' via the named public key.
verify_ :: IC -> B.ByteString -> B.ByteString -> IO Bool
verify_ :: IC -> ByteString -> ByteString -> IO Bool
verify_ IC
ic ByteString
m_bs ByteString
s_bs =
    forall a. IC -> KS a -> IO a
run IC
ic forall a b. (a -> b) -> a -> b
$ ClearText -> SignaturePacket -> KS Bool
verifyWithRSAKeyKS (Binary -> ClearText
ClearText       forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
m_bs)
                                (Binary -> SignaturePacket
SignaturePacket forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
s_bs)

-- | Run a KS function in an IO context, dealing with keystore updates, output,
-- debug logging and errors.
run :: IC -> KS a -> IO a
run :: forall a. IC -> KS a -> IO a
run IC
ic KS a
p =
 do (Ctx
ctx,State
st0) <- IC -> IO (Ctx, State)
getCtxState IC
ic
    State
st1 <- Ctx -> State -> IO State
scan_env Ctx
ctx State
st0
    let msg :: String
msg         = String
"[Keystore: " forall a. [a] -> [a] -> [a]
++ Ctx -> String
ctx_store Ctx
ctx forall a. [a] -> [a] -> [a]
++String
"]\n"
        (E a
e,State
st2,[LogEntry]
les) = forall a. Ctx -> State -> KS a -> (E a, State, [LogEntry])
run_ Ctx
ctx State
st1 forall a b. (a -> b) -> a -> b
$ String -> KS ()
debugLog String
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KS a
p
    a
r <- forall a. E a -> IO a
e2io E a
e
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ctx -> LogEntry -> IO ()
logit Ctx
ctx) [LogEntry]
les
    State
st' <- Ctx -> State -> IO State
backup_env Ctx
ctx State
st2
    IC -> Ctx -> State -> IO ()
putCtxState IC
ic Ctx
ctx State
st'
    forall (m :: * -> *) a. Monad m => a -> m a
return a
r

scan_env :: Ctx -> State -> IO State
scan_env :: Ctx -> State -> IO State
scan_env Ctx
ctx State
st0 =
 do (KeyStore
ks,[LogEntry]
les) <- KeyStore -> IO (KeyStore, [LogEntry])
scanEnv KeyStore
ks0
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ctx -> LogEntry -> IO ()
logit Ctx
ctx) [LogEntry]
les
    forall (m :: * -> *) a. Monad m => a -> m a
return State
st0 { st_keystore :: KeyStore
st_keystore = KeyStore
ks }
  where
    ks0 :: KeyStore
ks0 = State -> KeyStore
st_keystore State
st0

backup_env :: Ctx -> State -> IO State
backup_env :: Ctx -> State -> IO State
backup_env Ctx
ctx State
st0 =
 do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ctx -> LogEntry -> IO ()
logit Ctx
ctx) [LogEntry]
les'
    forall a. E a -> IO a
e2io E ()
e
    forall (m :: * -> *) a. Monad m => a -> m a
return State
st'
  where
    (E ()
e,State
st',[LogEntry]
les') = forall a. Ctx -> State -> KS a -> (E a, State, [LogEntry])
run_ Ctx
ctx State
st0 KS ()
backupKeysKS

getKeystore :: IC -> IO KeyStore
getKeystore :: IC -> IO KeyStore
getKeystore IC
ic = State -> KeyStore
st_keystore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> IO State
getState IC
ic

getState :: IC -> IO State
getState :: IC -> IO State
getState IC
ic = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> IO (Ctx, State)
getCtxState IC
ic

getCtxState :: IC -> IO (Ctx,State)
getCtxState :: IC -> IO (Ctx, State)
getCtxState IC{Maybe (IORef (Ctx, State))
CtxParams
ic_cache :: IC -> Maybe (IORef (Ctx, State))
ic_ctx_params :: IC -> CtxParams
ic_cache :: Maybe (IORef (Ctx, State))
ic_ctx_params :: CtxParams
..} =
    case Maybe (IORef (Ctx, State))
ic_cache of
      Maybe (IORef (Ctx, State))
Nothing -> CtxParams -> IO (Ctx, State)
determineCtx CtxParams
ic_ctx_params
      Just IORef (Ctx, State)
rf -> forall a. IORef a -> IO a
readIORef IORef (Ctx, State)
rf

putCtxState :: IC -> Ctx -> State -> IO ()
putCtxState :: IC -> Ctx -> State -> IO ()
putCtxState IC{Maybe (IORef (Ctx, State))
CtxParams
ic_cache :: Maybe (IORef (Ctx, State))
ic_ctx_params :: CtxParams
ic_cache :: IC -> Maybe (IORef (Ctx, State))
ic_ctx_params :: IC -> CtxParams
..} Ctx
ctx State
st =
 do forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IORef a -> a -> IO ()
writeIORef (Ctx
ctx,State
st)) Maybe (IORef (Ctx, State))
ic_cache
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ CtxParams -> Maybe Bool
cp_readonly CtxParams
ic_ctx_params) forall a b. (a -> b) -> a -> b
$
      String -> ByteString -> IO ()
LBS.writeFile (Ctx -> String
ctx_store Ctx
ctx) forall a b. (a -> b) -> a -> b
$ KeyStore -> ByteString
keyStoreBytes forall a b. (a -> b) -> a -> b
$ State -> KeyStore
st_keystore State
st

report :: String -> IO ()
report :: String -> IO ()
report = Handle -> String -> IO ()
hPutStrLn Handle
stderr