{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.KeyStore.IO.IC
( IC(..)
, CtxParams(..)
, defaultCtxParams
, defaultSettingsFilePath
, settingsFilePath
, defaultKeyStoreFilePath
, determineCtx
, establishState
, newGenerator
, readKeyStore
, readSettings
, scanEnv
, errorIO
, logit
) where
import Data.KeyStore.KS
import Data.KeyStore.Types
import Data.KeyStore.Types.AesonCompat
import Data.API.Types
import Data.Text as T hiding (elem)
import qualified Data.Map as Map
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Maybe
import Data.Time
import Data.IORef
import qualified Control.Exception as X
import System.Environment
import System.Directory
import System.FilePath
import System.IO
import Safe
data IC =
IC { IC -> CtxParams
ic_ctx_params :: CtxParams
, IC -> Maybe (IORef (Ctx, State))
ic_cache :: Maybe (IORef (Ctx,State))
}
data CtxParams
= CtxParams
{ CtxParams -> Maybe FilePath
cp_store :: Maybe FilePath
, CtxParams -> Maybe Bool
cp_debug :: Maybe Bool
, CtxParams -> Maybe Bool
cp_readonly :: Maybe Bool
}
deriving (Int -> CtxParams -> ShowS
[CtxParams] -> ShowS
CtxParams -> FilePath
(Int -> CtxParams -> ShowS)
-> (CtxParams -> FilePath)
-> ([CtxParams] -> ShowS)
-> Show CtxParams
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CtxParams] -> ShowS
$cshowList :: [CtxParams] -> ShowS
show :: CtxParams -> FilePath
$cshow :: CtxParams -> FilePath
showsPrec :: Int -> CtxParams -> ShowS
$cshowsPrec :: Int -> CtxParams -> ShowS
Show)
defaultCtxParams :: CtxParams
defaultCtxParams :: CtxParams
defaultCtxParams =
CtxParams :: Maybe FilePath -> Maybe Bool -> Maybe Bool -> CtxParams
CtxParams
{ cp_store :: Maybe FilePath
cp_store = Maybe FilePath
forall a. Maybe a
Nothing
, cp_debug :: Maybe Bool
cp_debug = Maybe Bool
forall a. Maybe a
Nothing
, cp_readonly :: Maybe Bool
cp_readonly = Maybe Bool
forall a. Maybe a
Nothing
}
defaultSettingsFilePath :: FilePath
defaultSettingsFilePath :: FilePath
defaultSettingsFilePath = ShowS
settingsFilePath FilePath
"settings"
settingsFilePath :: String -> FilePath
settingsFilePath :: ShowS
settingsFilePath FilePath
base = FilePath
base FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
".json"
defaultKeyStoreFilePath :: FilePath
defaultKeyStoreFilePath :: FilePath
defaultKeyStoreFilePath = FilePath
"keystore.json"
determineCtx :: CtxParams -> IO (Ctx,State)
determineCtx :: CtxParams -> IO (Ctx, State)
determineCtx CtxParams{Maybe Bool
Maybe FilePath
cp_readonly :: Maybe Bool
cp_debug :: Maybe Bool
cp_store :: Maybe FilePath
cp_readonly :: CtxParams -> Maybe Bool
cp_debug :: CtxParams -> Maybe Bool
cp_store :: CtxParams -> Maybe FilePath
..} =
do FilePath
str_fp_ <-
case Maybe FilePath
cp_store of
Maybe FilePath
Nothing ->
do Maybe FilePath
mb_ev_pth <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"KEYSTORE"
case Maybe FilePath
mb_ev_pth of
Maybe FilePath
Nothing ->
do [FilePath]
pth <- IO [FilePath]
mk_path
FilePath -> [FilePath] -> IO FilePath -> IO FilePath
lu_path FilePath
defaultKeyStoreFilePath [FilePath]
pth (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$
FilePath -> IO FilePath
forall a. FilePath -> IO a
errorIO FilePath
"keystore not found"
Just FilePath
str_fp -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
str_fp
Just FilePath
str_fp -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
str_fp
FilePath
cwd <- IO FilePath
getCurrentDirectory
UTCTime
now <- IO UTCTime
getCurrentTime
let str_fp :: FilePath
str_fp = FilePath
cwd FilePath -> ShowS
</> FilePath
str_fp_
ctx0 :: Ctx
ctx0 = Ctx :: UTCTime -> FilePath -> Settings -> Ctx
Ctx
{ ctx_now :: UTCTime
ctx_now = UTCTime
now
, ctx_store :: FilePath
ctx_store = FilePath
str_fp
, ctx_settings :: Settings
ctx_settings = Settings
defaultSettings
}
KeyStore
ks <- Ctx -> IO KeyStore
readKeyStore Ctx
ctx0
CPRNG
g <- IO CPRNG
newGenerator
let st :: State
st =
State :: KeyStore -> CPRNG -> State
State
{ st_keystore :: KeyStore
st_keystore = KeyStore
ks
, st_cprng :: CPRNG
st_cprng = CPRNG
g
}
sdbg :: Settings -> Settings
sdbg = Opt Bool -> Bool -> Settings -> Settings
forall a. Opt a -> a -> Settings -> Settings
setSettingsOpt Opt Bool
opt__debug_enabled (Bool -> Settings -> Settings) -> Bool -> Settings -> Settings
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
cp_debug
stg :: Settings
stg = Settings -> Settings
sdbg (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Configuration -> Settings
configurationSettings (Configuration -> Settings) -> Configuration -> Settings
forall a b. (a -> b) -> a -> b
$ KeyStore -> Configuration
_ks_config KeyStore
ks
ctx :: Ctx
ctx = Ctx
ctx0 { ctx_settings :: Settings
ctx_settings = Settings
stg }
(Ctx, State) -> IO (Ctx, State)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx
ctx,State
st)
establishState :: Ctx -> IO State
establishState :: Ctx -> IO State
establishState Ctx
ctx =
do KeyStore
ks <- Ctx -> IO KeyStore
readKeyStore Ctx
ctx
CPRNG
g <- IO CPRNG
newGenerator
State -> IO State
forall (m :: * -> *) a. Monad m => a -> m a
return
State :: KeyStore -> CPRNG -> State
State
{ st_keystore :: KeyStore
st_keystore = KeyStore
ks
, st_cprng :: CPRNG
st_cprng = CPRNG
g
}
newGenerator :: IO CPRNG
newGenerator :: IO CPRNG
newGenerator = IO CPRNG
newCPRNG
readKeyStore :: Ctx -> IO KeyStore
readKeyStore :: Ctx -> IO KeyStore
readKeyStore Ctx
ctx = IO (E KeyStore) -> IO KeyStore
forall a. IO (E a) -> IO a
ioE (IO (E KeyStore) -> IO KeyStore) -> IO (E KeyStore) -> IO KeyStore
forall a b. (a -> b) -> a -> b
$ ByteString -> E KeyStore
keyStoreFromBytes (ByteString -> E KeyStore) -> IO ByteString -> IO (E KeyStore)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
LBS.readFile (Ctx -> FilePath
ctx_store Ctx
ctx)
scanEnv :: KeyStore -> IO (KeyStore,[LogEntry])
scanEnv :: KeyStore -> IO (KeyStore, [LogEntry])
scanEnv KeyStore
ks = IO UTCTime
getCurrentTime IO UTCTime
-> (UTCTime -> IO (KeyStore, [LogEntry]))
-> IO (KeyStore, [LogEntry])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UTCTime
now -> UTCTime -> KeyStore -> IO (KeyStore, [LogEntry])
scanEnv' UTCTime
now KeyStore
ks
scanEnv' :: UTCTime -> KeyStore -> IO (KeyStore,[LogEntry])
scanEnv' :: UTCTime -> KeyStore -> IO (KeyStore, [LogEntry])
scanEnv' UTCTime
now KeyStore
ks = [Maybe (Key, FilePath)] -> (KeyStore, [LogEntry])
s_e ([Maybe (Key, FilePath)] -> (KeyStore, [LogEntry]))
-> IO [Maybe (Key, FilePath)] -> IO (KeyStore, [LogEntry])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Key, EnvVar) -> IO (Maybe (Key, FilePath)))
-> [(Key, EnvVar)] -> IO [Maybe (Key, FilePath)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Key, EnvVar) -> IO (Maybe (Key, FilePath))
forall a. (a, EnvVar) -> IO (Maybe (a, FilePath))
lu [(Key, EnvVar)]
k_evs
where
lu :: (a, EnvVar) -> IO (Maybe (a, FilePath))
lu (a
key,EnvVar Text
enm) = (FilePath -> (a, FilePath))
-> Maybe FilePath -> Maybe (a, FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) a
key) (Maybe FilePath -> Maybe (a, FilePath))
-> IO (Maybe FilePath) -> IO (Maybe (a, FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv (Text -> FilePath
T.unpack Text
enm)
s_e :: [Maybe (Key, FilePath)] -> (KeyStore, [LogEntry])
s_e [Maybe (Key, FilePath)]
mbs =
case E ()
e of
Left Reason
_ -> FilePath -> (KeyStore, [LogEntry])
forall a. HasCallStack => FilePath -> a
error FilePath
"scanEnv: unexpected error"
Right ()
_ -> (State -> KeyStore
st_keystore State
st',[LogEntry]
les)
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 () -> (E (), State, [LogEntry]))
-> KS () -> (E (), State, [LogEntry])
forall a b. (a -> b) -> a -> b
$ ((Key, FilePath) -> KS ()) -> [(Key, FilePath)] -> KS ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Key, FilePath) -> KS ()
s_e' ([(Key, FilePath)] -> KS ()) -> [(Key, FilePath)] -> KS ()
forall a b. (a -> b) -> a -> b
$ [Maybe (Key, FilePath)] -> [(Key, FilePath)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Key, FilePath)]
mbs
s_e' :: (Key, FilePath) -> KS ()
s_e' (Key
key,FilePath
sv) =
case Key -> Bool
_key_is_binary Key
key of
Bool
False -> Key -> ByteString -> KS ()
s_e'' Key
key (ByteString -> KS ()) -> ByteString -> KS ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
B.pack FilePath
sv
Bool
True ->
case ByteString -> Either FilePath ByteString
B64.decode (ByteString -> Either FilePath ByteString)
-> ByteString -> Either FilePath ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
B.pack FilePath
sv of
Left FilePath
_ -> FilePath -> KS ()
putStrKS (FilePath -> KS ()) -> FilePath -> KS ()
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
_name(Key -> Name
_key_name Key
key) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
enm FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": base-64 decode failure"
Right ByteString
bs -> Key -> ByteString -> KS ()
s_e'' Key
key ByteString
bs
where
EnvVar Text
enm = FilePath -> Maybe EnvVar -> EnvVar
forall a. HasCallStack => FilePath -> Maybe a -> a
fromJustNote FilePath
"scan_env" (Maybe EnvVar -> EnvVar) -> Maybe EnvVar -> EnvVar
forall a b. (a -> b) -> a -> b
$ Key -> Maybe EnvVar
_key_env_var Key
key
s_e'' :: Key -> ByteString -> KS ()
s_e'' Key{Bool
Maybe PublicKey
Maybe PrivateKey
Maybe ClearText
Maybe EnvVar
Maybe Hash
UTCTime
EncrypedCopyMap
Name
Comment
Identity
_key_created_at :: Key -> UTCTime
_key_clear_private :: Key -> Maybe PrivateKey
_key_clear_text :: Key -> Maybe ClearText
_key_secret_copies :: Key -> EncrypedCopyMap
_key_public :: Key -> Maybe PublicKey
_key_hash :: Key -> Maybe Hash
_key_identity :: Key -> Identity
_key_comment :: Key -> Comment
_key_created_at :: UTCTime
_key_clear_private :: Maybe PrivateKey
_key_clear_text :: Maybe ClearText
_key_secret_copies :: EncrypedCopyMap
_key_public :: Maybe PublicKey
_key_hash :: Maybe Hash
_key_env_var :: Maybe EnvVar
_key_is_binary :: Bool
_key_identity :: Identity
_key_comment :: Comment
_key_name :: Name
_key_env_var :: Key -> Maybe EnvVar
_key_name :: Key -> Name
_key_is_binary :: Key -> Bool
..} ByteString
bs =
do FilePath -> KS ()
btw (FilePath -> KS ()) -> FilePath -> KS ()
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
_name Name
_key_name FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" loaded\n"
()
_ <- Name -> ClearText -> KS ()
rememberKeyKS Name
_key_name (Binary -> ClearText
ClearText (Binary -> ClearText) -> Binary -> ClearText
forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
bs)
() -> KS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
k_evs :: [(Key, EnvVar)]
k_evs = [ (Key
key,EnvVar
ev) | Key
key<-Map Name Key -> [Key]
forall k a. Map k a -> [a]
Map.elems Map Name Key
mp, Just EnvVar
ev<-[Key -> Maybe EnvVar
_key_env_var Key
key],
Maybe ClearText -> Bool
forall a. Maybe a -> Bool
isNothing(Key -> Maybe ClearText
_key_clear_text Key
key) ]
mp :: Map Name Key
mp = KeyStore -> Map Name Key
_ks_keymap KeyStore
ks
ctx :: Ctx
ctx =
Ctx :: UTCTime -> FilePath -> Settings -> Ctx
Ctx
{ ctx_now :: UTCTime
ctx_now = UTCTime
now
, ctx_store :: FilePath
ctx_store = FilePath
""
, ctx_settings :: Settings
ctx_settings = Settings
defaultSettings
}
st0 :: State
st0 =
State :: KeyStore -> CPRNG -> State
State
{ st_cprng :: CPRNG
st_cprng = CPRNG
testCPRNG
, st_keystore :: KeyStore
st_keystore = KeyStore
ks
}
readSettings :: FilePath -> IO Settings
readSettings :: FilePath -> IO Settings
readSettings FilePath
fp =
do ByteString
lbs <- FilePath -> IO ByteString
LBS.readFile FilePath
fp
case ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode ByteString
lbs of
Left FilePath
msg -> FilePath -> IO Settings
forall a. FilePath -> IO a
errorIO FilePath
msg
Right Value
val ->
case Value
val of
Object Object
hm -> Settings -> IO Settings
forall (m :: * -> *) a. Monad m => a -> m a
return (Settings -> IO Settings) -> Settings -> IO Settings
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> Settings
Settings (HashMap Text Value -> Settings) -> HashMap Text Value -> Settings
forall a b. (a -> b) -> a -> b
$ Object -> HashMap Text Value
forall a. KM a -> HashMap Text a
fromKM Object
hm
Value
_ -> FilePath -> IO Settings
forall a. FilePath -> IO a
errorIO FilePath
"JSON object expected in the configuration file"
errorIO :: String -> IO a
errorIO :: FilePath -> IO a
errorIO FilePath
msg = E a -> IO a
forall a. E a -> IO a
e2io (E a -> IO a) -> E a -> IO a
forall a b. (a -> b) -> a -> b
$ Reason -> E a
forall a b. a -> Either a b
Left (Reason -> E a) -> Reason -> E a
forall a b. (a -> b) -> a -> b
$ FilePath -> Reason
forall a. Error a => FilePath -> a
strMsg FilePath
msg
ioE :: IO (E a) -> IO a
ioE :: IO (E a) -> IO a
ioE IO (E a)
p = IO (E a)
p IO (E a) -> (E a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (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 a e. Exception e => e -> a
X.throw a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
logit :: Ctx -> LogEntry -> IO ()
logit :: Ctx -> LogEntry -> IO ()
logit Ctx
ctx LogEntry{Bool
FilePath
le_message :: LogEntry -> FilePath
le_debug :: LogEntry -> Bool
le_message :: FilePath
le_debug :: Bool
..} =
case Bool
dbg Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
le_debug of
Bool
True -> Handle -> FilePath -> IO ()
hPutStr Handle
h (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
pfx FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
le_message
Bool
False -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
dbg :: Bool
dbg = Opt Bool -> Settings -> Bool
forall a. Opt a -> Settings -> a
getSettingsOpt Opt Bool
opt__debug_enabled (Settings -> Bool) -> Settings -> Bool
forall a b. (a -> b) -> a -> b
$ Ctx -> Settings
ctx_settings Ctx
ctx
pfx :: FilePath
pfx = if Bool
le_debug then FilePath
"(debug) " else FilePath
""
h :: Handle
h = if Bool
le_debug then Handle
stderr else Handle
stdout
lu_path :: FilePath -> [FilePath] -> IO FilePath -> IO FilePath
lu_path :: FilePath -> [FilePath] -> IO FilePath -> IO FilePath
lu_path FilePath
_ [] IO FilePath
nope = IO FilePath
nope
lu_path FilePath
fp (FilePath
dp:[FilePath]
dps) IO FilePath
nope =
do [FilePath]
fps <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
dp IO [FilePath] -> (SomeException -> IO [FilePath]) -> IO [FilePath]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`X.catch` \(SomeException
_::X.SomeException) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
case FilePath
fp FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
fps of
Bool
True -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dp FilePath -> ShowS
</> FilePath
fp
Bool
False -> FilePath -> [FilePath] -> IO FilePath -> IO FilePath
lu_path FilePath
fp [FilePath]
dps IO FilePath
nope
mk_path :: IO [FilePath]
mk_path :: IO [FilePath]
mk_path =
do Maybe FilePath
mb <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"HOME"
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
[ FilePath
"." ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
hd FilePath -> ShowS
</> FilePath
".keystore" | Just FilePath
hd<-[Maybe FilePath
mb] ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
"/var/lib/keystore" ]