{-# 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
, 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.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.Except as E
import Control.Exception
import Control.Lens
import Crypto.PubKey.RSA.Types
newtype KS a = KS { forall a. KS a -> ExceptT Reason (RWS Ctx [LogEntry] State) a
_KS :: E.ExceptT Reason (RWS Ctx [LogEntry] State) a }
deriving (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
<$ :: forall a b. a -> KS b -> KS a
$c<$ :: forall a b. a -> KS b -> KS a
fmap :: forall a b. (a -> b) -> KS a -> KS b
$cfmap :: forall a b. (a -> b) -> KS a -> KS b
Functor, Functor KS
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
<* :: forall a b. KS a -> KS b -> KS a
$c<* :: forall a b. KS a -> KS b -> KS a
*> :: forall a b. KS a -> KS b -> KS b
$c*> :: forall a b. KS a -> KS b -> KS b
liftA2 :: forall a b c. (a -> b -> c) -> KS a -> KS b -> KS c
$cliftA2 :: forall a b c. (a -> b -> c) -> KS a -> KS b -> KS c
<*> :: forall a b. KS (a -> b) -> KS a -> KS b
$c<*> :: forall a b. KS (a -> b) -> KS a -> KS b
pure :: forall a. a -> KS a
$cpure :: forall a. a -> KS a
Applicative, Applicative KS
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 :: forall a. a -> KS a
$creturn :: forall a. a -> KS a
>> :: forall a b. KS a -> KS b -> KS b
$c>> :: forall a b. KS a -> KS b -> KS b
>>= :: forall a b. KS a -> (a -> KS b) -> KS b
$c>>= :: forall a b. KS a -> (a -> KS b) -> KS b
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
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
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 :: forall byteArray. ByteArray byteArray => Int -> KS byteArray
getRandomBytes Int
sz = forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall ba. ByteArray ba => State -> (ba, State)
upd
where
upd :: BA.ByteArray ba => State -> (ba,State)
upd :: forall ba. ByteArray ba => 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') = forall ba. ByteArray ba => Int -> CPRNG -> (ba, CPRNG)
generateCPRNG Int
sz forall a b. (a -> b) -> a -> b
$ State -> CPRNG
st_cprng State
st
rsaErrorKS :: KS (Either Error a) -> KS a
rsaErrorKS :: forall a. KS (Either Error a) -> KS a
rsaErrorKS KS (Either Error a)
ks_e = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Reason -> KS a
throwKS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Reason
rsaError) forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a. Name -> KS a -> KS a
withKey Name
nm KS a
p =
do Ctx
ctx <- forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall r (m :: * -> *). MonadReader r m => m r
ask
State
st <- forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall s (m :: * -> *). MonadState s m => m s
get
let cfg :: Configuration
cfg = KeyStore -> Configuration
_ks_config forall a b. (a -> b) -> a -> b
$ State -> KeyStore
st_keystore State
st
stgs :: Settings
stgs = Configuration -> Settings
_cfg_settings Configuration
cfg
Settings
stgs' <- forall a. E a -> KS a
e2ks forall a b. (a -> b) -> a -> b
$ Name -> Configuration -> Settings -> E Settings
trigger Name
nm Configuration
cfg Settings
stgs
case 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 forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put State
st'
forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [LogEntry]
les
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Reason -> KS a
throwKS forall (m :: * -> *) a. Monad m => a -> m a
return E a
e
trun :: KS a -> a
trun :: forall a. KS a -> a
trun KS a
p =
case 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]
_) -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show Reason
e
(Right a
x,State
_,[LogEntry]
_) -> a
x
where
s :: State
s = State
{ st_cprng :: CPRNG
st_cprng = CPRNG
testCPRNG
, st_keystore :: KeyStore
st_keystore = Configuration -> KeyStore
emptyKeyStore forall a b. (a -> b) -> a -> b
$ Settings -> Configuration
defaultConfiguration Settings
defaultSettings
}
u :: UTCTime
u = forall a. Read a => FilePath -> a
read FilePath
"2014-01-01 00:00:00"
e2io :: E a -> IO a
e2io :: forall a. E a -> IO a
e2io = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return
e2ks :: E a -> KS a
e2ks :: forall a. E a -> KS a
e2ks = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Reason -> KS a
throwKS forall (m :: * -> *) a. Monad m => a -> m a
return
run_ :: Ctx -> State -> KS a -> (E a,State,[LogEntry])
run_ :: forall a. Ctx -> State -> KS a -> (E a, State, [LogEntry])
run_ Ctx
c State
s KS a
p = forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
E.runExceptT (forall a. KS a -> ExceptT Reason (RWS Ctx [LogEntry] State) a
_KS KS a
p)) Ctx
c State
s
randomBytes :: Octets -> (B.ByteString->a) -> KS a
randomBytes :: forall a. Octets -> (ByteString -> a) -> KS a
randomBytes (Octets Int
sz) ByteString -> a
k = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> a
k forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
sz
currentTime :: KS UTCTime
currentTime :: KS UTCTime
currentTime = Ctx -> UTCTime
ctx_now forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall r (m :: * -> *). MonadReader r m => m r
ask
putStrKS :: String -> KS ()
putStrKS :: FilePath -> KS ()
putStrKS FilePath
msg = forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall a b. (a -> b) -> a -> b
$ 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 = forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall a b. (a -> b) -> a -> b
$ 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 :: forall a. KS a -> (Reason -> KS a) -> KS a
catchKS = forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
E.catchError
errorKS :: String -> KS a
errorKS :: forall a. FilePath -> KS a
errorKS = forall a. Reason -> KS a
throwKS forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Reason
strMsg
throwKS :: Reason -> KS a
throwKS :: forall a. Reason -> KS a
throwKS = forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError
storeKS :: KS FilePath
storeKS :: KS FilePath
storeKS = Ctx -> FilePath
ctx_store forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall r (m :: * -> *). MonadReader r m => m r
ask
lookupOpt :: Show a => Opt a -> KS a
lookupOpt :: forall a. Show a => Opt a -> KS a
lookupOpt Opt a
opt = forall a. Opt a -> Settings -> a
getSettingsOpt Opt a
opt 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS 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
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. KS a
oops forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
nm KeyMap
mp
where
oops :: KS a
oops = forall a. FilePath -> KS a
errorKS forall a b. (a -> b) -> a -> b
$ Name -> FilePath
_name Name
nm 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
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a b. a -> b -> a
const forall {a}. KS a
oops) forall a b. (a -> b) -> a -> b
$ 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 = forall a. FilePath -> KS a
errorKS forall a b. (a -> b) -> a -> b
$ Name -> FilePath
_name Name
nm 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 <- forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall s (m :: * -> *). MonadState s m => m s
get
let mp :: KeyMap
mp = KeyStore -> KeyMap
_ks_keymap forall a b. (a -> b) -> a -> b
$ State -> KeyStore
st_keystore State
s
mp' :: KeyMap
mp' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall k a. Ord k => k -> Map k a -> Map k a
Map.delete KeyMap
mp [Name]
nms
case forall k a. Map k a -> Bool
Map.null forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const KeyMap
mp'
Bool
False -> forall a. FilePath -> KS a
errorKS FilePath
"cannot delete these keys because they are still being used"
where
tst :: Key -> Bool
tst Key
key = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Safeguard -> [Name]
safeguardKeys Safeguard
sg) [Name]
nms |
Safeguard
sg<-forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ Key -> EncrypedCopyMap
_key_secret_copies Key
key ]
getKeymap :: KS KeyMap
getKeymap :: KS KeyMap
getKeymap = KeyStore -> KeyMap
_ks_keymapforall b c a. (b -> c) -> (a -> b) -> a -> c
.State -> KeyStore
st_keystore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall s (m :: * -> *). MonadState s m => m s
get
getConfig :: KS Configuration
getConfig :: KS Configuration
getConfig = KeyStore -> Configuration
_ks_configforall b c a. (b -> c) -> (a -> b) -> a -> c
.State -> KeyStore
st_keystore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall s (m :: * -> *). MonadState s m => m s
get
mod_keymap :: (KeyMap->KeyMap) -> KS ()
mod_keymap :: (KeyMap -> KeyMap) -> KS ()
mod_keymap KeyMap -> KeyMap
upd = forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \State
st -> forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put
State
st
{ st_keystore :: KeyStore
st_keystore = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over 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 = forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \State
st -> forall a. ExceptT Reason (RWS Ctx [LogEntry] State) a -> KS a
KS forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put
State
st
{ st_keystore :: KeyStore
st_keystore = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' KeyStore Configuration
ks_config Configuration -> Configuration
upd (State -> KeyStore
st_keystore State
st)
}