{-# 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.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)
        }