module Data.KeyStore.KS.KS
( KS
, Ctx(..)
, State(..)
, LogEntry(..)
, 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 Crypto.PubKey.RSA
import qualified Data.Map as Map
import qualified Data.ByteString as B
import Data.Typeable
import Data.Time
import Control.Applicative
import Control.Monad.RWS.Strict
import qualified Control.Monad.Error as E
import Control.Exception
import Control.Lens
newtype KS a = KS { _KS :: E.ErrorT Reason (RWS Ctx [LogEntry] State) a }
deriving (Functor, Applicative, Monad, E.MonadError Reason)
data Ctx
= Ctx
{ ctx_now :: UTCTime
, ctx_store :: FilePath
, ctx_settings :: Settings
}
deriving (Typeable,Show)
data State
= State
{ st_keystore :: KeyStore
, st_cprng :: CPRNG
}
deriving (Typeable)
data LogEntry
= LogEntry
{ le_debug :: Bool
, le_message :: String
}
deriving (Show)
withKey :: Name -> KS a -> KS a
withKey nm p =
do ctx <- KS ask
st <- KS get
let cfg = _ks_config $ st_keystore st
stgs = _cfg_settings cfg
stgs' <- e2ks $ trigger nm cfg stgs
case run_ ctx {ctx_settings=stgs'} st p of
(e,st',les) ->
do KS $ put st'
KS $ tell les
either throwKS return e
trun :: KS a -> a
trun p =
case run_ (Ctx u "keystore.json" defaultSettings) s p of
(Left e,_,_) -> error $ show e
(Right x,_,_) -> x
where
s = State
{ st_cprng = testCPRNG
, st_keystore = emptyKeyStore $ defaultConfiguration defaultSettings
}
u = read "2014-01-01 00:00:00"
e2io :: E a -> IO a
e2io = either throwIO return
e2ks :: E a -> KS a
e2ks = either throwKS return
run_ :: Ctx -> State -> KS a -> (E a,State,[LogEntry])
run_ c s p = runRWS (E.runErrorT (_KS p)) c s
randomBytes :: Octets -> (B.ByteString->a) -> KS a
randomBytes (Octets sz) k = k <$> randomKS (generateCPRNG sz)
currentTime :: KS UTCTime
currentTime = ctx_now <$> KS ask
putStrKS :: String -> KS ()
putStrKS msg = KS $ tell [LogEntry False msg]
btw :: String -> KS ()
btw = debugLog
debugLog :: String -> KS ()
debugLog msg = KS $ tell [LogEntry True msg]
catchKS :: KS a -> (Reason -> KS a) -> KS a
catchKS = E.catchError
errorKS :: String -> KS a
errorKS = throwKS . strMsg
throwKS :: Reason -> KS a
throwKS = E.throwError
storeKS :: KS FilePath
storeKS = ctx_store <$> KS ask
lookupOpt :: Show a => Opt a -> KS a
lookupOpt opt = getSettingsOpt opt <$> getSettings
getSettings :: KS Settings
getSettings = ctx_settings <$> KS ask
lookupKey :: Name -> KS Key
lookupKey nm =
do mp <- getKeymap
maybe oops return $ Map.lookup nm mp
where
oops = errorKS $ _name nm ++ ": no such keystore key"
insertNewKey :: Key -> KS ()
insertNewKey key =
do mp <- getKeymap
maybe (return ()) (const oops) $ Map.lookup nm mp
insertKey key
where
oops = errorKS $ _name nm ++ ": key already in use"
nm = _key_name key
insertKey :: Key -> KS ()
insertKey key = mod_keymap $ Map.insert (_key_name key) key
adjustKeyKS :: Name -> (Key->Key) -> KS ()
adjustKeyKS nm adj = mod_keymap $ Map.adjust adj nm
deleteKeysKS :: [Name] -> KS ()
deleteKeysKS nms =
do s <- KS get
let mp = _ks_keymap $ st_keystore s
mp' = foldr Map.delete mp nms
case Map.null $ Map.filter tst mp' of
True -> mod_keymap $ const mp'
False -> errorKS "cannot delete these keys because they are still being used"
where
tst key = or [ any (`elem` safeguardKeys sg) nms |
sg<-Map.keys $ _key_secret_copies key ]
randomRSA :: (CPRNG->(Either Error a,CPRNG)) -> KS a
randomRSA f = randomKS f >>= either (throwKS . rsaError) return
randomKS :: (CPRNG->(a,CPRNG)) -> KS a
randomKS f = KS $
do s <- get
let (x,!g') = f $ st_cprng s
put s { st_cprng = g' }
return x
getKeymap :: KS KeyMap
getKeymap = _ks_keymap.st_keystore <$> KS get
getConfig :: KS Configuration
getConfig = _ks_config.st_keystore <$> KS get
mod_keymap :: (KeyMap->KeyMap) -> KS ()
mod_keymap upd = KS get >>= \st -> KS $ put
st
{ st_keystore = over ks_keymap upd (st_keystore st)
}
modConfig :: (Configuration->Configuration) -> KS ()
modConfig upd = KS get >>= \st -> KS $ put
st
{ st_keystore = over ks_config upd (st_keystore st)
}