{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE BangPatterns               #-}

module Data.KeyStore.KS.KS
    ( KS
    , Ctx(..)
    , State(..)
    , LogEntry(..)
    , rsaErrorKS
    , withKey
    , trun
    , e2io
    , e2ks
    , run_
    , randomBytes
    , currentTime
    , putStrKS
    , btw
    , debugLog
    , catchKS
    , errorKS
    , throwKS
    , lookupOpt
    , storeKS
    , getSettings
    , lookupKey
    , insertNewKey
    , insertKey
    , adjustKeyKS
    , deleteKeysKS
    -- , randomRSA
    -- , randomKS
    , getKeymap
    , getConfig
    , modConfig
    ) where

import           Data.KeyStore.KS.CPRNG
import           Data.KeyStore.KS.Configuration
import           Data.KeyStore.KS.Opt
import           Data.KeyStore.Types
import qualified Data.ByteArray                 as BA
-- import           Crypto.PubKey.RSA
import           Crypto.Random.Types
import qualified Data.Map                       as Map
import qualified Data.ByteString                as B
import           Data.Typeable
import           Data.Time
import           Control.Monad.RWS.Strict
import qualified Control.Monad.Error            as E
import           Control.Exception
import           Control.Lens
import           Crypto.PubKey.RSA.Types


newtype KS a = KS { KS a -> ErrorT Reason (RWS Ctx [LogEntry] State) a
_KS :: E.ErrorT Reason (RWS Ctx [LogEntry] State) a }
    deriving (a -> KS b -> KS a
(a -> b) -> KS a -> KS b
(forall a b. (a -> b) -> KS a -> KS b)
-> (forall a b. a -> KS b -> KS a) -> Functor KS
forall a b. a -> KS b -> KS a
forall a b. (a -> b) -> KS a -> KS b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> KS b -> KS a
$c<$ :: forall a b. a -> KS b -> KS a
fmap :: (a -> b) -> KS a -> KS b
$cfmap :: forall a b. (a -> b) -> KS a -> KS b
Functor, Functor KS
a -> KS a
Functor KS
-> (forall a. a -> KS a)
-> (forall a b. KS (a -> b) -> KS a -> KS b)
-> (forall a b c. (a -> b -> c) -> KS a -> KS b -> KS c)
-> (forall a b. KS a -> KS b -> KS b)
-> (forall a b. KS a -> KS b -> KS a)
-> Applicative KS
KS a -> KS b -> KS b
KS a -> KS b -> KS a
KS (a -> b) -> KS a -> KS b
(a -> b -> c) -> KS a -> KS b -> KS c
forall a. a -> KS a
forall a b. KS a -> KS b -> KS a
forall a b. KS a -> KS b -> KS b
forall a b. KS (a -> b) -> KS a -> KS b
forall a b c. (a -> b -> c) -> KS a -> KS b -> KS c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: KS a -> KS b -> KS a
$c<* :: forall a b. KS a -> KS b -> KS a
*> :: KS a -> KS b -> KS b
$c*> :: forall a b. KS a -> KS b -> KS b
liftA2 :: (a -> b -> c) -> KS a -> KS b -> KS c
$cliftA2 :: forall a b c. (a -> b -> c) -> KS a -> KS b -> KS c
<*> :: KS (a -> b) -> KS a -> KS b
$c<*> :: forall a b. KS (a -> b) -> KS a -> KS b
pure :: a -> KS a
$cpure :: forall a. a -> KS a
$cp1Applicative :: Functor KS
Applicative, Applicative KS
a -> KS a
Applicative KS
-> (forall a b. KS a -> (a -> KS b) -> KS b)
-> (forall a b. KS a -> KS b -> KS b)
-> (forall a. a -> KS a)
-> Monad KS
KS a -> (a -> KS b) -> KS b
KS a -> KS b -> KS b
forall a. a -> KS a
forall a b. KS a -> KS b -> KS b
forall a b. KS a -> (a -> KS b) -> KS b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> KS a
$creturn :: forall a. a -> KS a
>> :: KS a -> KS b -> KS b
$c>> :: forall a b. KS a -> KS b -> KS b
>>= :: KS a -> (a -> KS b) -> KS b
$c>>= :: forall a b. KS a -> (a -> KS b) -> KS b
$cp1Monad :: Applicative KS
Monad, E.MonadError Reason)

data Ctx
    = Ctx
        { Ctx -> UTCTime
ctx_now      :: UTCTime
        , Ctx -> FilePath
ctx_store    :: FilePath
        , Ctx -> Settings
ctx_settings :: Settings
        }
    deriving (Typeable,Int -> Ctx -> ShowS
[Ctx] -> ShowS
Ctx -> FilePath
(Int -> Ctx -> ShowS)
-> (Ctx -> FilePath) -> ([Ctx] -> ShowS) -> Show Ctx
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Ctx] -> ShowS
$cshowList :: [Ctx] -> ShowS
show :: Ctx -> FilePath
$cshow :: Ctx -> FilePath
showsPrec :: Int -> Ctx -> ShowS
$cshowsPrec :: Int -> Ctx -> ShowS
Show)

data State
    = State
        { State -> KeyStore
st_keystore :: KeyStore
        , State -> CPRNG
st_cprng    :: CPRNG
        }
        deriving (Typeable)

data LogEntry
    = LogEntry
        { LogEntry -> Bool
le_debug   :: Bool
        , LogEntry -> FilePath
le_message :: String
        }
    deriving (Int -> LogEntry -> ShowS
[LogEntry] -> ShowS
LogEntry -> FilePath
(Int -> LogEntry -> ShowS)
-> (LogEntry -> FilePath) -> ([LogEntry] -> ShowS) -> Show LogEntry
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LogEntry] -> ShowS
$cshowList :: [LogEntry] -> ShowS
show :: LogEntry -> FilePath
$cshow :: LogEntry -> FilePath
showsPrec :: Int -> LogEntry -> ShowS
$cshowsPrec :: Int -> LogEntry -> ShowS
Show)


instance MonadRandom KS where
  getRandomBytes :: Int -> KS byteArray
getRandomBytes Int
sz = ErrorT Reason (RWS Ctx [LogEntry] State) byteArray -> KS byteArray
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS (ErrorT Reason (RWS Ctx [LogEntry] State) byteArray
 -> KS byteArray)
-> ErrorT Reason (RWS Ctx [LogEntry] State) byteArray
-> KS byteArray
forall a b. (a -> b) -> a -> b
$ (State -> (byteArray, State))
-> ErrorT Reason (RWS Ctx [LogEntry] State) byteArray
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state State -> (byteArray, State)
forall ba. ByteArray ba => State -> (ba, State)
upd
    where
      upd :: BA.ByteArray ba => State -> (ba,State)
      upd :: State -> (ba, State)
upd State
st = (ba
ba,State
st')
        where
          st' :: State
st' = State
st
            { st_cprng :: CPRNG
st_cprng = CPRNG
cprg'
            }
          (ba
ba,CPRNG
cprg') = Int -> CPRNG -> (ba, CPRNG)
forall ba. ByteArray ba => Int -> CPRNG -> (ba, CPRNG)
generateCPRNG Int
sz (CPRNG -> (ba, CPRNG)) -> CPRNG -> (ba, CPRNG)
forall a b. (a -> b) -> a -> b
$ State -> CPRNG
st_cprng State
st

rsaErrorKS :: KS (Either Error a) -> KS a
rsaErrorKS :: KS (Either Error a) -> KS a
rsaErrorKS KS (Either Error a)
ks_e = (Error -> KS a) -> (a -> KS a) -> Either Error a -> KS a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Reason -> KS a
forall a. Reason -> KS a
throwKS (Reason -> KS a) -> (Error -> Reason) -> Error -> KS a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Reason
rsaError) a -> KS a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a -> KS a) -> KS (Either Error a) -> KS a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KS (Either Error a)
ks_e

withKey :: Name -> KS a -> KS a
withKey :: Name -> KS a -> KS a
withKey Name
nm KS a
p =
 do Ctx
ctx <- ErrorT Reason (RWS Ctx [LogEntry] State) Ctx -> KS Ctx
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    State
st  <- ErrorT Reason (RWS Ctx [LogEntry] State) State -> KS State
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) State
forall s (m :: * -> *). MonadState s m => m s
get
    let cfg :: Configuration
cfg  = KeyStore -> Configuration
_ks_config (KeyStore -> Configuration) -> KeyStore -> Configuration
forall a b. (a -> b) -> a -> b
$ State -> KeyStore
st_keystore State
st
        stgs :: Settings
stgs = Configuration -> Settings
_cfg_settings Configuration
cfg
    Settings
stgs' <- E Settings -> KS Settings
forall a. E a -> KS a
e2ks (E Settings -> KS Settings) -> E Settings -> KS Settings
forall a b. (a -> b) -> a -> b
$ Name -> Configuration -> Settings -> E Settings
trigger Name
nm Configuration
cfg Settings
stgs
    case Ctx -> State -> KS a -> (E a, State, [LogEntry])
forall a. Ctx -> State -> KS a -> (E a, State, [LogEntry])
run_ Ctx
ctx {ctx_settings :: Settings
ctx_settings=Settings
stgs'} State
st KS a
p of
      (E a
e,State
st',[LogEntry]
les) ->
         do ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS (ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ())
-> ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a b. (a -> b) -> a -> b
$ State -> ErrorT Reason (RWS Ctx [LogEntry] State) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put State
st'
            ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS (ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ())
-> ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a b. (a -> b) -> a -> b
$ [LogEntry] -> ErrorT Reason (RWS Ctx [LogEntry] State) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [LogEntry]
les
            (Reason -> KS a) -> (a -> KS a) -> E a -> KS a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Reason -> KS a
forall a. Reason -> KS a
throwKS a -> KS a
forall (m :: * -> *) a. Monad m => a -> m a
return E a
e

trun :: KS a -> a
trun :: KS a -> a
trun KS a
p =
    case Ctx -> State -> KS a -> (E a, State, [LogEntry])
forall a. Ctx -> State -> KS a -> (E a, State, [LogEntry])
run_ (UTCTime -> FilePath -> Settings -> Ctx
Ctx UTCTime
u FilePath
"keystore.json" Settings
defaultSettings) State
s KS a
p of
      (Left  Reason
e,State
_,[LogEntry]
_) -> FilePath -> a
forall a. HasCallStack => FilePath -> a
error (FilePath -> a) -> FilePath -> a
forall a b. (a -> b) -> a -> b
$ Reason -> FilePath
forall a. Show a => a -> FilePath
show Reason
e
      (Right a
x,State
_,[LogEntry]
_) -> a
x
  where
    s :: State
s = State :: KeyStore -> CPRNG -> State
State
            { st_cprng :: CPRNG
st_cprng    = CPRNG
testCPRNG
            , st_keystore :: KeyStore
st_keystore = Configuration -> KeyStore
emptyKeyStore (Configuration -> KeyStore) -> Configuration -> KeyStore
forall a b. (a -> b) -> a -> b
$ Settings -> Configuration
defaultConfiguration Settings
defaultSettings
            }

    u :: UTCTime
u = FilePath -> UTCTime
forall a. Read a => FilePath -> a
read FilePath
"2014-01-01 00:00:00"

e2io :: E a -> IO a
e2io :: E a -> IO a
e2io = (Reason -> IO a) -> (a -> IO a) -> E a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Reason -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

e2ks :: E a -> KS a
e2ks :: E a -> KS a
e2ks = (Reason -> KS a) -> (a -> KS a) -> E a -> KS a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Reason -> KS a
forall a. Reason -> KS a
throwKS a -> KS a
forall (m :: * -> *) a. Monad m => a -> m a
return

run_ :: Ctx -> State -> KS a -> (E a,State,[LogEntry])
run_ :: Ctx -> State -> KS a -> (E a, State, [LogEntry])
run_ Ctx
c State
s KS a
p = RWS Ctx [LogEntry] State (E a)
-> Ctx -> State -> (E a, State, [LogEntry])
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS (ErrorT Reason (RWS Ctx [LogEntry] State) a
-> RWS Ctx [LogEntry] State (E a)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
E.runErrorT (KS a -> ErrorT Reason (RWS Ctx [LogEntry] State) a
forall a. KS a -> ErrorT Reason (RWS Ctx [LogEntry] State) a
_KS KS a
p)) Ctx
c State
s

randomBytes :: Octets -> (B.ByteString->a) -> KS a
randomBytes :: Octets -> (ByteString -> a) -> KS a
randomBytes (Octets Int
sz) ByteString -> a
k = (ByteString -> a) -> KS ByteString -> KS a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> a
k (KS ByteString -> KS a) -> KS ByteString -> KS a
forall a b. (a -> b) -> a -> b
$ Int -> KS ByteString
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
sz

currentTime :: KS UTCTime
currentTime :: KS UTCTime
currentTime = Ctx -> UTCTime
ctx_now (Ctx -> UTCTime) -> KS Ctx -> KS UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorT Reason (RWS Ctx [LogEntry] State) Ctx -> KS Ctx
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask

putStrKS :: String -> KS ()
putStrKS :: FilePath -> KS ()
putStrKS FilePath
msg = ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS (ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ())
-> ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a b. (a -> b) -> a -> b
$ [LogEntry] -> ErrorT Reason (RWS Ctx [LogEntry] State) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Bool -> FilePath -> LogEntry
LogEntry Bool
False FilePath
msg]

btw :: String -> KS ()
btw :: FilePath -> KS ()
btw = FilePath -> KS ()
debugLog

debugLog :: String -> KS ()
debugLog :: FilePath -> KS ()
debugLog FilePath
msg = ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS (ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ())
-> ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a b. (a -> b) -> a -> b
$ [LogEntry] -> ErrorT Reason (RWS Ctx [LogEntry] State) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Bool -> FilePath -> LogEntry
LogEntry Bool
True FilePath
msg]

catchKS :: KS a -> (Reason -> KS a) -> KS a
catchKS :: KS a -> (Reason -> KS a) -> KS a
catchKS = KS a -> (Reason -> KS a) -> KS a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
E.catchError

errorKS :: String -> KS a
errorKS :: FilePath -> KS a
errorKS = Reason -> KS a
forall a. Reason -> KS a
throwKS (Reason -> KS a) -> (FilePath -> Reason) -> FilePath -> KS a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Reason
forall a. Error a => FilePath -> a
strMsg

throwKS :: Reason -> KS a
throwKS :: Reason -> KS a
throwKS = Reason -> KS a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError

storeKS :: KS FilePath
storeKS :: KS FilePath
storeKS = Ctx -> FilePath
ctx_store (Ctx -> FilePath) -> KS Ctx -> KS FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorT Reason (RWS Ctx [LogEntry] State) Ctx -> KS Ctx
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask

lookupOpt :: Show a => Opt a -> KS a
lookupOpt :: Opt a -> KS a
lookupOpt Opt a
opt = Opt a -> Settings -> a
forall a. Opt a -> Settings -> a
getSettingsOpt Opt a
opt (Settings -> a) -> KS Settings -> KS a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KS Settings
getSettings

getSettings :: KS Settings
getSettings :: KS Settings
getSettings = Ctx -> Settings
ctx_settings (Ctx -> Settings) -> KS Ctx -> KS Settings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorT Reason (RWS Ctx [LogEntry] State) Ctx -> KS Ctx
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask

lookupKey :: Name -> KS Key
lookupKey :: Name -> KS Key
lookupKey Name
nm =
 do KeyMap
mp <- KS KeyMap
getKeymap
    KS Key -> (Key -> KS Key) -> Maybe Key -> KS Key
forall b a. b -> (a -> b) -> Maybe a -> b
maybe KS Key
forall a. KS a
oops Key -> KS Key
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Key -> KS Key) -> Maybe Key -> KS Key
forall a b. (a -> b) -> a -> b
$ Name -> KeyMap -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
nm KeyMap
mp
  where
    oops :: KS a
oops = FilePath -> KS a
forall a. FilePath -> KS a
errorKS (FilePath -> KS a) -> FilePath -> KS a
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
_name Name
nm FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": no such keystore key"

insertNewKey :: Key -> KS ()
insertNewKey :: Key -> KS ()
insertNewKey Key
key =
 do KeyMap
mp <- KS KeyMap
getKeymap
    KS () -> (Key -> KS ()) -> Maybe Key -> KS ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> KS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (KS () -> Key -> KS ()
forall a b. a -> b -> a
const KS ()
forall a. KS a
oops) (Maybe Key -> KS ()) -> Maybe Key -> KS ()
forall a b. (a -> b) -> a -> b
$ Name -> KeyMap -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
nm KeyMap
mp
    Key -> KS ()
insertKey Key
key
  where
    oops :: KS a
oops = FilePath -> KS a
forall a. FilePath -> KS a
errorKS (FilePath -> KS a) -> FilePath -> KS a
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
_name Name
nm FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": key already in use"

    nm :: Name
nm   = Key -> Name
_key_name Key
key

insertKey :: Key -> KS ()
insertKey :: Key -> KS ()
insertKey Key
key = (KeyMap -> KeyMap) -> KS ()
mod_keymap ((KeyMap -> KeyMap) -> KS ()) -> (KeyMap -> KeyMap) -> KS ()
forall a b. (a -> b) -> a -> b
$ Name -> Key -> KeyMap -> KeyMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Key -> Name
_key_name Key
key) Key
key

adjustKeyKS :: Name -> (Key->Key) -> KS ()
adjustKeyKS :: Name -> (Key -> Key) -> KS ()
adjustKeyKS Name
nm Key -> Key
adj = (KeyMap -> KeyMap) -> KS ()
mod_keymap ((KeyMap -> KeyMap) -> KS ()) -> (KeyMap -> KeyMap) -> KS ()
forall a b. (a -> b) -> a -> b
$ (Key -> Key) -> Name -> KeyMap -> KeyMap
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Key -> Key
adj Name
nm

deleteKeysKS :: [Name] -> KS ()
deleteKeysKS :: [Name] -> KS ()
deleteKeysKS [Name]
nms =
 do State
s <- ErrorT Reason (RWS Ctx [LogEntry] State) State -> KS State
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) State
forall s (m :: * -> *). MonadState s m => m s
get
    let mp :: KeyMap
mp  = KeyStore -> KeyMap
_ks_keymap (KeyStore -> KeyMap) -> KeyStore -> KeyMap
forall a b. (a -> b) -> a -> b
$ State -> KeyStore
st_keystore State
s
        mp' :: KeyMap
mp' = (Name -> KeyMap -> KeyMap) -> KeyMap -> [Name] -> KeyMap
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Name -> KeyMap -> KeyMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete KeyMap
mp [Name]
nms
    case KeyMap -> Bool
forall k a. Map k a -> Bool
Map.null (KeyMap -> Bool) -> KeyMap -> Bool
forall a b. (a -> b) -> a -> b
$ (Key -> Bool) -> KeyMap -> KeyMap
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Key -> Bool
tst KeyMap
mp' of
      Bool
True  -> (KeyMap -> KeyMap) -> KS ()
mod_keymap ((KeyMap -> KeyMap) -> KS ()) -> (KeyMap -> KeyMap) -> KS ()
forall a b. (a -> b) -> a -> b
$ KeyMap -> KeyMap -> KeyMap
forall a b. a -> b -> a
const KeyMap
mp'
      Bool
False -> FilePath -> KS ()
forall a. FilePath -> KS a
errorKS FilePath
"cannot delete these keys because they are still being used"
  where
    tst :: Key -> Bool
tst Key
key = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Safeguard -> [Name]
safeguardKeys Safeguard
sg) [Name]
nms |
                                    Safeguard
sg<-Map Safeguard EncrypedCopy -> [Safeguard]
forall k a. Map k a -> [k]
Map.keys (Map Safeguard EncrypedCopy -> [Safeguard])
-> Map Safeguard EncrypedCopy -> [Safeguard]
forall a b. (a -> b) -> a -> b
$ Key -> Map Safeguard EncrypedCopy
_key_secret_copies Key
key ]

getKeymap :: KS KeyMap
getKeymap :: KS KeyMap
getKeymap = KeyStore -> KeyMap
_ks_keymap(KeyStore -> KeyMap) -> (State -> KeyStore) -> State -> KeyMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
.State -> KeyStore
st_keystore (State -> KeyMap) -> KS State -> KS KeyMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorT Reason (RWS Ctx [LogEntry] State) State -> KS State
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) State
forall s (m :: * -> *). MonadState s m => m s
get

getConfig :: KS Configuration
getConfig :: KS Configuration
getConfig = KeyStore -> Configuration
_ks_config(KeyStore -> Configuration)
-> (State -> KeyStore) -> State -> Configuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
.State -> KeyStore
st_keystore (State -> Configuration) -> KS State -> KS Configuration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorT Reason (RWS Ctx [LogEntry] State) State -> KS State
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) State
forall s (m :: * -> *). MonadState s m => m s
get

mod_keymap :: (KeyMap->KeyMap) -> KS ()
mod_keymap :: (KeyMap -> KeyMap) -> KS ()
mod_keymap KeyMap -> KeyMap
upd = ErrorT Reason (RWS Ctx [LogEntry] State) State -> KS State
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) State
forall s (m :: * -> *). MonadState s m => m s
get KS State -> (State -> KS ()) -> KS ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \State
st -> ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS (ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ())
-> ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a b. (a -> b) -> a -> b
$ State -> ErrorT Reason (RWS Ctx [LogEntry] State) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
    State
st
        { st_keystore :: KeyStore
st_keystore = ASetter KeyStore KeyStore KeyMap KeyMap
-> (KeyMap -> KeyMap) -> KeyStore -> KeyStore
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter KeyStore KeyStore KeyMap KeyMap
Lens' KeyStore KeyMap
ks_keymap KeyMap -> KeyMap
upd (State -> KeyStore
st_keystore State
st)
        }

modConfig :: (Configuration->Configuration) -> KS ()
modConfig :: (Configuration -> Configuration) -> KS ()
modConfig Configuration -> Configuration
upd = ErrorT Reason (RWS Ctx [LogEntry] State) State -> KS State
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS ErrorT Reason (RWS Ctx [LogEntry] State) State
forall s (m :: * -> *). MonadState s m => m s
get KS State -> (State -> KS ()) -> KS ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \State
st -> ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a. ErrorT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS (ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ())
-> ErrorT Reason (RWS Ctx [LogEntry] State) () -> KS ()
forall a b. (a -> b) -> a -> b
$ State -> ErrorT Reason (RWS Ctx [LogEntry] State) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
    State
st
        { st_keystore :: KeyStore
st_keystore = ASetter KeyStore KeyStore Configuration Configuration
-> (Configuration -> Configuration) -> KeyStore -> KeyStore
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter KeyStore KeyStore Configuration Configuration
Lens' KeyStore Configuration
ks_config Configuration -> Configuration
upd (State -> KeyStore
st_keystore State
st)
        }