{-# 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 :: FilePath -> Settings -> IO ()
newKeyStore FilePath
str_fp Settings
stgs =
 do Either SomeException ByteString
ei <- IO ByteString -> IO (Either SomeException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
X.try (IO ByteString -> IO (Either SomeException ByteString))
-> IO ByteString -> IO (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
B.readFile FilePath
str_fp :: IO (Either X.SomeException B.ByteString)
    (SomeException -> IO ())
-> (ByteString -> IO ())
-> Either SomeException ByteString
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const (IO () -> SomeException -> IO ())
-> IO () -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> ByteString -> IO ()
forall a b. a -> b -> a
const (IO () -> ByteString -> IO ()) -> IO () -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. FilePath -> IO a
errorIO FilePath
"keystore file exists") Either SomeException ByteString
ei
    CPRNG
g  <- IO CPRNG
newGenerator
    let state :: State
state =
            State :: KeyStore -> CPRNG -> State
State
                { st_keystore :: KeyStore
st_keystore = Configuration -> KeyStore
emptyKeyStore (Configuration -> KeyStore) -> Configuration -> KeyStore
forall a b. (a -> b) -> a -> b
$ Settings -> Configuration
defaultConfiguration Settings
stgs
                , st_cprng :: CPRNG
st_cprng    = CPRNG
g
                }
    FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
str_fp (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ KeyStore -> ByteString
keyStoreBytes (KeyStore -> ByteString) -> KeyStore -> ByteString
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 (IC -> IO (Ctx, State)) -> IC -> IO (Ctx, State)
forall a b. (a -> b) -> a -> b
$ CtxParams -> IC
instanceCtx_ CtxParams
cp
    CtxParams -> Maybe (IORef (Ctx, State)) -> IC
IC CtxParams
cp (Maybe (IORef (Ctx, State)) -> IC)
-> (IORef (Ctx, State) -> Maybe (IORef (Ctx, State)))
-> IORef (Ctx, State)
-> IC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Ctx, State) -> Maybe (IORef (Ctx, State))
forall a. a -> Maybe a
Just (IORef (Ctx, State) -> IC) -> IO (IORef (Ctx, State)) -> IO IC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ctx, State) -> IO (IORef (Ctx, State))
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 Maybe (IORef (Ctx, State))
forall a. Maybe a
Nothing

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

-- | List the JSON settings on stdout.
listSettings :: IC -> IO ()
listSettings :: IC -> IO ()
listSettings IC
ic = IC -> IO Settings
settings IC
ic IO Settings -> (Settings -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ()
LBS.putStrLn (ByteString -> IO ())
-> (Settings -> ByteString) -> Settings -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (HashMap Text Value -> ByteString)
-> (Settings -> HashMap Text Value) -> Settings -> ByteString
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 = IC -> KS Settings -> IO Settings
forall a. IC -> KS a -> IO a
run IC
ic (KS Settings -> IO Settings) -> KS Settings -> IO Settings
forall a b. (a -> b) -> a -> b
$ Configuration -> Settings
_cfg_settings (Configuration -> Settings) -> KS Configuration -> KS 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 -> FilePath -> IO ()
updateSettings IC
ic FilePath
fp =
 do ByteString
bs   <- FilePath -> IO ByteString
LBS.readFile FilePath
fp
    Settings
stgs <- E Settings -> IO Settings
forall a. E a -> IO a
e2io (E Settings -> IO Settings) -> E Settings -> IO Settings
forall a b. (a -> b) -> a -> b
$ ByteString -> E Settings
settingsFromBytes ByteString
bs
    IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Configuration -> Configuration) -> KS ()
modConfig ((Configuration -> Configuration) -> KS ())
-> (Configuration -> Configuration) -> KS ()
forall a b. (a -> b) -> a -> b
$ ASetter Configuration Configuration Settings Settings
-> (Settings -> Settings) -> Configuration -> Configuration
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
L.over ASetter Configuration Configuration Settings Settings
Lens' Configuration Settings
cfg_settings ((Settings -> Settings) -> Configuration -> Configuration)
-> (Settings -> Settings) -> Configuration -> Configuration
forall a b. (a -> b) -> a -> b
$ Settings -> Settings -> Settings
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 IO [Trigger] -> ([Trigger] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO ()
putStr (FilePath -> IO ())
-> ([Trigger] -> FilePath) -> [Trigger] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines ([FilePath] -> FilePath)
-> ([Trigger] -> [FilePath]) -> [Trigger] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Trigger -> FilePath) -> [Trigger] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Trigger -> FilePath
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
..} = FilePath -> FilePath -> FilePath -> FilePath -> t
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-12s : %12s => %s" FilePath
id_s FilePath
pat_s FilePath
stgs_s
      where
        id_s :: FilePath
id_s   = Text -> FilePath
T.unpack   (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ TriggerID -> Text
_TriggerID                  TriggerID
_trg_id
        pat_s :: FilePath
pat_s  = Pattern -> FilePath
_pat_string                              Pattern
_trg_pattern
        stgs_s :: FilePath
stgs_s = ByteString -> FilePath
LBS.unpack (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> Object
forall a. HashMap Text a -> KM a
intoKM (HashMap Text Value -> Object) -> HashMap Text Value -> Object
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 = IC -> KS [Trigger] -> IO [Trigger]
forall a. IC -> KS a -> IO a
run IC
ic (KS [Trigger] -> IO [Trigger]) -> KS [Trigger] -> IO [Trigger]
forall a b. (a -> b) -> a -> b
$ Map TriggerID Trigger -> [Trigger]
forall k a. Map k a -> [a]
Map.elems (Map TriggerID Trigger -> [Trigger])
-> (Configuration -> Map TriggerID Trigger)
-> Configuration
-> [Trigger]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> Map TriggerID Trigger
_cfg_triggers (Configuration -> [Trigger]) -> KS Configuration -> KS [Trigger]
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 -> FilePath -> IO ()
addTrigger IC
ic TriggerID
tid Pattern
pat FilePath
fp =
 do ByteString
bs   <- FilePath -> IO ByteString
LBS.readFile FilePath
fp
    Settings
stgs <- E Settings -> IO Settings
forall a. E a -> IO a
e2io (E Settings -> IO Settings) -> E Settings -> IO Settings
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 =
    IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Configuration -> Configuration) -> KS ()
modConfig ((Configuration -> Configuration) -> KS ())
-> (Configuration -> Configuration) -> KS ()
forall a b. (a -> b) -> a -> b
$ ASetter
  Configuration
  Configuration
  (Map TriggerID Trigger)
  (Map TriggerID Trigger)
-> (Map TriggerID Trigger -> Map TriggerID Trigger)
-> Configuration
-> Configuration
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
L.over ASetter
  Configuration
  Configuration
  (Map TriggerID Trigger)
  (Map TriggerID Trigger)
Lens' Configuration (Map TriggerID Trigger)
cfg_triggers ((Map TriggerID Trigger -> Map TriggerID Trigger)
 -> Configuration -> Configuration)
-> (Map TriggerID Trigger -> Map TriggerID Trigger)
-> Configuration
-> Configuration
forall a b. (a -> b) -> a -> b
$ TriggerID
-> Trigger -> Map TriggerID Trigger -> Map TriggerID Trigger
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TriggerID
tid (Trigger -> Map TriggerID Trigger -> Map TriggerID Trigger)
-> Trigger -> Map TriggerID Trigger -> Map TriggerID Trigger
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 = IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Configuration -> Configuration) -> KS ()
modConfig ((Configuration -> Configuration) -> KS ())
-> (Configuration -> Configuration) -> KS ()
forall a b. (a -> b) -> a -> b
$ ASetter
  Configuration
  Configuration
  (Map TriggerID Trigger)
  (Map TriggerID Trigger)
-> (Map TriggerID Trigger -> Map TriggerID Trigger)
-> Configuration
-> Configuration
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
L.over ASetter
  Configuration
  Configuration
  (Map TriggerID Trigger)
  (Map TriggerID Trigger)
Lens' Configuration (Map TriggerID Trigger)
cfg_triggers ((Map TriggerID Trigger -> Map TriggerID Trigger)
 -> Configuration -> Configuration)
-> (Map TriggerID Trigger -> Map TriggerID Trigger)
-> Configuration
-> Configuration
forall a b. (a -> b) -> a -> b
$ TriggerID -> Map TriggerID Trigger -> Map TriggerID Trigger
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 = IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
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 =
            IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
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 (Binary -> ClearText)
-> (ByteString -> Binary) -> ByteString -> ClearText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Binary
Binary (ByteString -> ClearText) -> Maybe ByteString -> Maybe ClearText
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 = IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
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 -> FilePath -> IO ()
rememberKey IC
ic Name
nm FilePath
fp = FilePath -> IO ByteString
B.readFile FilePath
fp IO ByteString -> (ByteString -> IO ()) -> IO ()
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 = IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
forall a b. (a -> b) -> a -> b
$ Name -> ClearText -> KS ()
rememberKeyKS Name
nm (ClearText -> KS ()) -> ClearText -> KS ()
forall a b. (a -> b) -> a -> b
$ Binary -> ClearText
ClearText (Binary -> ClearText) -> Binary -> 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 = IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
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 = IC -> KS Key -> IO Key
forall a. IC -> KS a -> IO a
run IC
ic (KS Key -> IO Key) -> KS Key -> IO Key
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 = IC
-> FilePath
-> (Key -> Maybe Identity)
-> (Identity -> ByteString)
-> Bool
-> Name
-> IO ByteString
forall a.
IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic FilePath
"identity" (Identity -> Maybe Identity
forall a. a -> Maybe a
Just (Identity -> Maybe Identity)
-> (Key -> Identity) -> Key -> Maybe Identity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Identity
_key_identity) (FilePath -> ByteString
B.pack (FilePath -> ByteString)
-> (Identity -> FilePath) -> Identity -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (Identity -> Text) -> Identity -> FilePath
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 = IC
-> FilePath
-> (Key -> Maybe Comment)
-> (Comment -> ByteString)
-> Bool
-> Name
-> IO ByteString
forall a.
IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic FilePath
"comment"  (Comment -> Maybe Comment
forall a. a -> Maybe a
Just (Comment -> Maybe Comment)
-> (Key -> Comment) -> Key -> Maybe Comment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Comment
_key_comment)  (FilePath -> ByteString
B.pack (FilePath -> ByteString)
-> (Comment -> FilePath) -> Comment -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (Comment -> Text) -> Comment -> FilePath
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 = IC
-> FilePath
-> (Key -> Maybe UTCTime)
-> (UTCTime -> ByteString)
-> Bool
-> Name
-> IO ByteString
forall a.
IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic FilePath
"date" (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime)
-> (Key -> UTCTime) -> Key -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> UTCTime
_key_created_at) (FilePath -> ByteString
B.pack (FilePath -> ByteString)
-> (UTCTime -> FilePath) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
fmt)
  where
    fmt :: FilePath
fmt = FilePath
"%F-%TZ"

-- | Return the hash of a key.
showHash :: IC -> Bool -> Name -> IO B.ByteString
showHash :: IC -> Bool -> Name -> IO ByteString
showHash IC
ic = IC
-> FilePath
-> (Key -> Maybe HashData)
-> (HashData -> Binary)
-> Bool
-> Name
-> IO ByteString
forall a.
IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic FilePath
"hash" ((Hash -> HashData) -> Maybe Hash -> Maybe HashData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash -> HashData
_hash_hash (Maybe Hash -> Maybe HashData)
-> (Key -> Maybe Hash) -> Key -> Maybe HashData
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 = IC
-> FilePath
-> (Key -> Maybe Hash)
-> (Hash -> ByteString)
-> Bool
-> Name
-> IO ByteString
forall a.
IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic FilePath
"hash" Key -> Maybe Hash
_key_hash Hash -> ByteString
cmt
  where
    cmt :: Hash -> ByteString
cmt = FilePath -> ByteString
B.pack (FilePath -> ByteString)
-> (Hash -> FilePath) -> Hash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (Hash -> Text) -> Hash -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> Text
_Comment (Comment -> Text) -> (Hash -> Comment) -> Hash -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashDescription -> Comment
_hashd_comment (HashDescription -> Comment)
-> (Hash -> HashDescription) -> Hash -> 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 = IC
-> FilePath
-> (Key -> Maybe Salt)
-> (Salt -> Binary)
-> Bool
-> Name
-> IO ByteString
forall a.
IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic FilePath
"hash" ((Hash -> Salt) -> Maybe Hash -> Maybe Salt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HashDescription -> Salt
_hashd_salt (HashDescription -> Salt)
-> (Hash -> HashDescription) -> Hash -> Salt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> HashDescription
_hash_description) (Maybe Hash -> Maybe Salt)
-> (Key -> Maybe Hash) -> Key -> Maybe Salt
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 = IC
-> FilePath
-> (Key -> Maybe ClearText)
-> (ClearText -> Binary)
-> Bool
-> Name
-> IO ByteString
forall a.
IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic FilePath
"public" ((PublicKey -> ClearText) -> Maybe PublicKey -> Maybe ClearText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PublicKey -> ClearText
encodePublicKeyDER (Maybe PublicKey -> Maybe ClearText)
-> (Key -> Maybe PublicKey) -> Key -> Maybe ClearText
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 = IC
-> FilePath
-> (Key -> Maybe ClearText)
-> (ClearText -> Binary)
-> Bool
-> Name
-> IO ByteString
forall a.
IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic FilePath
"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 :: IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> Binary)
-> Bool
-> Name
-> IO ByteString
show_it IC
ic FilePath
lbl Key -> Maybe a
prj_1 a -> Binary
prj_2 Bool
aa Name
nm = IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
forall a.
IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic FilePath
lbl Key -> Maybe a
prj_1 (Binary -> ByteString
_Binary (Binary -> ByteString) -> (a -> Binary) -> a -> ByteString
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' :: IC
-> FilePath
-> (Key -> Maybe a)
-> (a -> ByteString)
-> Bool
-> Name
-> IO ByteString
show_it' IC
ic FilePath
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 (a -> ByteString) -> Maybe a -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Maybe a
prj_1 Key
key of
      Maybe ByteString
Nothing -> FilePath -> IO ByteString
forall a. FilePath -> IO a
errorIO (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s: %s not present" (Name -> FilePath
_name Name
nm) FilePath
lbl
      Just ByteString
bs -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
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 ByteString -> ByteString
forall a. a -> a
id

-- | List a summary of all of the keys on stdout.
list :: IC -> IO ()
list :: IC -> IO ()
list IC
ic = IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
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 = IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
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 = Map Name Key -> [Key]
forall k a. Map k a -> [a]
Map.elems (Map Name Key -> [Key])
-> (KeyStore -> Map Name Key) -> KeyStore -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyStore -> Map Name Key
_ks_keymap (KeyStore -> [Key]) -> IO KeyStore -> IO [Key]
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 = IC -> KS () -> IO ()
forall a. IC -> KS a -> IO a
run IC
ic (KS () -> IO ()) -> KS () -> IO ()
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 -> FilePath -> FilePath -> IO ()
encrypt IC
ic Name
nm FilePath
s_fp FilePath
d_fp =
 do ByteString
bs <- FilePath -> IO ByteString
B.readFile FilePath
s_fp
    ByteString
bs' <- IC -> Name -> ByteString -> IO ByteString
encrypt_ IC
ic Name
nm ByteString
bs
    FilePath -> ByteString -> IO ()
B.writeFile FilePath
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 (Binary -> ByteString)
-> (EncryptionPacket -> Binary) -> EncryptionPacket -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncryptionPacket -> Binary
_EncryptionPacket (EncryptionPacket -> ByteString)
-> IO EncryptionPacket -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (IC -> KS EncryptionPacket -> IO EncryptionPacket
forall a. IC -> KS a -> IO a
run IC
ic (KS EncryptionPacket -> IO EncryptionPacket)
-> KS EncryptionPacket -> IO EncryptionPacket
forall a b. (a -> b) -> a -> b
$ Name -> ClearText -> KS EncryptionPacket
encryptWithRSAKeyKS Name
nm (ClearText -> KS EncryptionPacket)
-> ClearText -> KS EncryptionPacket
forall a b. (a -> b) -> a -> b
$ Binary -> ClearText
ClearText (Binary -> ClearText) -> Binary -> 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 = IC -> KS RSASecretData -> IO RSASecretData
forall a. IC -> KS a -> IO a
run IC
ic (KS RSASecretData -> IO RSASecretData)
-> KS RSASecretData -> IO RSASecretData
forall a b. (a -> b) -> a -> b
$ Name -> ClearText -> KS RSASecretData
encryptWithRSAKeyKS_ Name
nm (ClearText -> KS RSASecretData) -> ClearText -> KS RSASecretData
forall a b. (a -> b) -> a -> b
$ Binary -> ClearText
ClearText (Binary -> ClearText) -> Binary -> 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 -> FilePath -> FilePath -> IO ()
decrypt IC
ic FilePath
s_fp FilePath
d_fp =
 do ByteString
bs <- FilePath -> IO ByteString
B.readFile FilePath
s_fp
    ByteString
bs' <- IC -> ByteString -> IO ByteString
decrypt_ IC
ic ByteString
bs
    FilePath -> ByteString -> IO ()
B.writeFile FilePath
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 (Binary -> ByteString)
-> (ClearText -> Binary) -> ClearText -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClearText -> Binary
_ClearText (ClearText -> ByteString) -> IO ClearText -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (IC -> KS ClearText -> IO ClearText
forall a. IC -> KS a -> IO a
run IC
ic (KS ClearText -> IO ClearText) -> KS ClearText -> IO ClearText
forall a b. (a -> b) -> a -> b
$ EncryptionPacket -> KS ClearText
decryptWithRSAKeyKS (EncryptionPacket -> KS ClearText)
-> EncryptionPacket -> KS ClearText
forall a b. (a -> b) -> a -> b
$ Binary -> EncryptionPacket
EncryptionPacket (Binary -> EncryptionPacket) -> Binary -> 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 (Binary -> ByteString)
-> (ClearText -> Binary) -> ClearText -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClearText -> Binary
_ClearText (ClearText -> ByteString) -> IO ClearText -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IC -> KS ClearText -> IO ClearText
forall a. IC -> KS a -> IO a
run IC
ic (KS ClearText -> IO ClearText) -> KS ClearText -> IO ClearText
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 -> FilePath -> FilePath -> IO ()
sign IC
ic Name
nm FilePath
s_fp FilePath
d_fp =
 do ByteString
bs <- FilePath -> IO ByteString
B.readFile FilePath
s_fp
    ByteString
bs' <- IC -> Name -> ByteString -> IO ByteString
sign_ IC
ic Name
nm ByteString
bs
    FilePath -> ByteString -> IO ()
B.writeFile FilePath
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 (Binary -> ByteString)
-> (SignaturePacket -> Binary) -> SignaturePacket -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignaturePacket -> Binary
_SignaturePacket (SignaturePacket -> ByteString)
-> IO SignaturePacket -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (IC -> KS SignaturePacket -> IO SignaturePacket
forall a. IC -> KS a -> IO a
run IC
ic (KS SignaturePacket -> IO SignaturePacket)
-> KS SignaturePacket -> IO SignaturePacket
forall a b. (a -> b) -> a -> b
$ Name -> ClearText -> KS SignaturePacket
signWithRSAKeyKS Name
nm (ClearText -> KS SignaturePacket)
-> ClearText -> KS SignaturePacket
forall a b. (a -> b) -> a -> b
$ Binary -> ClearText
ClearText (Binary -> ClearText) -> Binary -> 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 -> FilePath -> FilePath -> IO Bool
verify IC
ic FilePath
m_fp FilePath
s_fp =
 do ByteString
m_bs <- FilePath -> IO ByteString
B.readFile FilePath
m_fp
    ByteString
s_bs <- FilePath -> IO ByteString
B.readFile FilePath
s_fp
    Bool
ok <- IC -> ByteString -> ByteString -> IO Bool
verify_ IC
ic ByteString
m_bs ByteString
s_bs
    case Bool
ok of
      Bool
True  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Bool
False -> FilePath -> IO ()
report FilePath
"signature does not match the data"
    Bool -> IO Bool
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 =
    IC -> KS Bool -> IO Bool
forall a. IC -> KS a -> IO a
run IC
ic (KS Bool -> IO Bool) -> KS Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ClearText -> SignaturePacket -> KS Bool
verifyWithRSAKeyKS (Binary -> ClearText
ClearText       (Binary -> ClearText) -> Binary -> ClearText
forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
m_bs)
                                (Binary -> SignaturePacket
SignaturePacket (Binary -> SignaturePacket) -> Binary -> 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 :: 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 :: FilePath
msg         = FilePath
"[Keystore: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Ctx -> FilePath
ctx_store Ctx
ctx FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"]\n"
        (E a
e,State
st2,[LogEntry]
les) = Ctx -> State -> KS a -> (E a, State, [LogEntry])
forall a. Ctx -> State -> KS a -> (E a, State, [LogEntry])
run_ Ctx
ctx State
st1 (KS a -> (E a, State, [LogEntry]))
-> KS a -> (E a, State, [LogEntry])
forall a b. (a -> b) -> a -> b
$ FilePath -> KS ()
debugLog FilePath
msg KS () -> KS a -> KS a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KS a
p
    a
r <- E a -> IO a
forall a. E a -> IO a
e2io E a
e
    (LogEntry -> IO ()) -> [LogEntry] -> IO ()
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'
    a -> IO a
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
    (LogEntry -> IO ()) -> [LogEntry] -> IO ()
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 -> IO State
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 (LogEntry -> IO ()) -> [LogEntry] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ctx -> LogEntry -> IO ()
logit Ctx
ctx) [LogEntry]
les'
    E () -> IO ()
forall a. E a -> IO a
e2io E ()
e
    State -> IO State
forall (m :: * -> *) a. Monad m => a -> m a
return State
st'
  where
    (E ()
e,State
st',[LogEntry]
les') = Ctx -> State -> KS () -> (E (), State, [LogEntry])
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 (State -> KeyStore) -> IO State -> IO 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 = (Ctx, State) -> State
forall a b. (a, b) -> b
snd ((Ctx, State) -> State) -> IO (Ctx, State) -> IO State
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 -> IORef (Ctx, State) -> IO (Ctx, State)
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 IO ()
-> (IORef (Ctx, State) -> IO ())
-> Maybe (IORef (Ctx, State))
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((IORef (Ctx, State) -> (Ctx, State) -> IO ())
-> (Ctx, State) -> IORef (Ctx, State) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef (Ctx, State) -> (Ctx, State) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Ctx
ctx,State
st)) Maybe (IORef (Ctx, State))
ic_cache
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (Bool -> Bool) -> Maybe Bool -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Bool -> Bool
forall a. a -> a
id (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CtxParams -> Maybe Bool
cp_readonly CtxParams
ic_ctx_params) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> ByteString -> IO ()
LBS.writeFile (Ctx -> FilePath
ctx_store Ctx
ctx) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ KeyStore -> ByteString
keyStoreBytes (KeyStore -> ByteString) -> KeyStore -> ByteString
forall a b. (a -> b) -> a -> b
$ State -> KeyStore
st_keystore State
st

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