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

-- | The parameters used to set up a KeyStore session.
data CtxParams
    = CtxParams
        { CtxParams -> Maybe FilePath
cp_store    :: Maybe FilePath   -- ^ location of any explictlt specified keystore file
        , CtxParams -> Maybe Bool
cp_debug    :: Maybe Bool       -- ^ whether debug output has been specified enabled or not
        , CtxParams -> Maybe Bool
cp_readonly :: Maybe Bool       -- ^ Just True => do not update keystore
        }
    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)

-- | Suitable default 'CtxParams'.
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
        }

-- | The default place for keystore settings (settings).
defaultSettingsFilePath :: FilePath
defaultSettingsFilePath :: FilePath
defaultSettingsFilePath = ShowS
settingsFilePath FilePath
"settings"

-- | Add the standard file extension to a base name (.json).
settingsFilePath :: String -> FilePath
settingsFilePath :: ShowS
settingsFilePath FilePath
base = FilePath
base FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
".json"


-- | The default file for a keystore (keystore.json).
defaultKeyStoreFilePath :: FilePath
defaultKeyStoreFilePath :: FilePath
defaultKeyStoreFilePath = FilePath
"keystore.json"

-- | Determine the 'Ctx' and keystore 'State' from 'CtxParams'
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)

-- | Set up the keystore state.
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
            }

-- | Read the JSON-encoded KeyStore settings from the named file.
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" ]