{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

--------------------------------------------------------------------------------------------------
-- | See https://www.vaultproject.io/api/secret/kv/kv-v2.html for HashiCorp Vault KVv2 API details
--------------------------------------------------------------------------------------------------

module Database.Vault.KVv2.Client (

    VaultConnection,

    -- * Connect & configure Vault KVv2 Engine
    vaultConnect,
    kvEngineConfig,
    secretConfig,

    -- * Basic operations

    putSecret,
    getSecret,

    -- * Soft secret deletion
    deleteSecret,
    deleteSecretVersions,
    unDeleteSecretVersions,

    -- * Permanent secret deletion
    destroySecret,
    destroySecretVersions,

    -- * Get informations

    currentSecretVersion,
    readSecretMetadata,
    secretsList,

    -- * Utils
    toSecretData,
    fromSecretData,
    toSecretVersions,

  ) where

import qualified Data.Aeson                          as A
import qualified Data.ByteString                     as B
import           Data.HashMap.Strict
import qualified Data.Maybe                          as M
import           Data.Text                           as T
import           Data.Text.Encoding
import           Network.Connection
import           Network.HTTP.Client.TLS
import           System.Environment                  (lookupEnv)
import           System.Posix.Files                  (fileExist)

import           Database.Vault.KVv2.Client.Lens
import           Database.Vault.KVv2.Client.Requests
import           Database.Vault.KVv2.Client.Types

-- | Get a 'VaultConnection', or an error message.
--
-- >λ: vaultConnect (Just "https://vault.local.lan:8200/") "/secret" Nothing False
--
vaultConnect
  :: Maybe VaultAddr                    -- ^ Use 'Just' this Vault server address, or get it from environment variable VAULT_ADDR
  -> KVEnginePath                       -- ^ KV engine path
  -> Maybe VaultToken                   -- ^ Use 'Just' this 'VaultToken' or get it from $HOME/.vaut-token
  -> DisableCertValidation              -- ^ Disable certificate validation
  -> IO (Either String VaultConnection)
vaultConnect :: Maybe String
-> String
-> Maybe String
-> DisableCertValidation
-> IO (Either String VaultConnection)
vaultConnect Maybe String
mva String
kvep Maybe String
mvt DisableCertValidation
dcv = do
  Manager
nm <- forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newTlsManagerWith forall a b. (a -> b) -> a -> b
$
          TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings
            TLSSettingsSimple
              { settingDisableCertificateValidation :: DisableCertValidation
settingDisableCertificateValidation = DisableCertValidation
dcv
              , settingDisableSession :: DisableCertValidation
settingDisableSession               = DisableCertValidation
False
              , settingUseServerName :: DisableCertValidation
settingUseServerName                = DisableCertValidation
True
              }
            forall a. Maybe a
Nothing
  Maybe String
va <- if forall a. Maybe a -> DisableCertValidation
M.isJust Maybe String
mva
          then forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
mva
          else String -> IO (Maybe String)
lookupEnv String
"VAULT_ADDR"
  Either String ByteString
evt <- case Maybe String
mvt of
           Just String
t  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
t)
           Maybe String
Nothing -> do
             Maybe String
hm <- String -> IO (Maybe String)
lookupEnv String
"HOME"
             if forall a. Maybe a -> DisableCertValidation
M.isJust Maybe String
hm
               then do
                 let fp :: String
fp = forall a. HasCallStack => Maybe a -> a
M.fromJust Maybe String
hm forall a. [a] -> [a] -> [a]
++ String
"/.vault-token"
                 if forall a. Maybe a -> DisableCertValidation
M.isJust Maybe String
va
                   then do
                     DisableCertValidation
fe <- String -> IO DisableCertValidation
fileExist String
fp
                     if DisableCertValidation
fe
                       then forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fp
                       else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"No Vault token file found at " forall a. [a] -> [a] -> [a]
++ String
fp)
                   else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left String
"Variable environment VAULT_ADDR not set")
               else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left String
"Variable environment HOME not set")
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    (\ByteString
vt ->
      VaultConnection
        { vaultAddr :: String
vaultAddr    = forall a. HasCallStack => Maybe a -> a
M.fromJust Maybe String
va
        , vaultToken :: ByteString
vaultToken   = ByteString
vt
        , kvEnginePath :: String
kvEnginePath = String
kvep
        , manager :: Manager
manager      = Manager
nm
        }
    ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String ByteString
evt

-- | Set default secret settings for the KVv2 engine.
kvEngineConfig
  :: VaultConnection
  -> Int                        -- ^ Max versions
  -> Bool                       -- ^ CAS required
  -> IO (Either String A.Value)
kvEngineConfig :: VaultConnection
-> Int -> DisableCertValidation -> IO (Either String Value)
kvEngineConfig vc :: VaultConnection
vc@VaultConnection{} =
  [String]
-> VaultConnection
-> Int
-> DisableCertValidation
-> IO (Either String Value)
configR [String
"POST ", forall a. Show a => a -> String
show VaultConnection
vc, String
"/config"] VaultConnection
vc

-- | Override default secret settings for the given secret.
secretConfig
  :: VaultConnection
  -> SecretPath
  -> Int                        -- ^ Max versions
  -> Bool                       -- ^ CAS required
  -> IO (Either String A.Value)
secretConfig :: VaultConnection
-> SecretPath
-> Int
-> DisableCertValidation
-> IO (Either String Value)
secretConfig vc :: VaultConnection
vc@VaultConnection{} SecretPath{String
path :: SecretPath -> String
path :: String
..} =
  [String]
-> VaultConnection
-> Int
-> DisableCertValidation
-> IO (Either String Value)
configR [String
"POST ", forall a. Show a => a -> String
show VaultConnection
vc, String
"/metadata/", String
path] VaultConnection
vc

-- | Get a secret from Vault. Give 'Just' the 'SecretVersion'
-- to retrieve or 'Nothing' to get the current one.
--
-- >λ>getSecret conn (SecretPath "MySecret") Nothing
-- >Right (SecretData (fromList [("my","password")]))
--
getSecret
  :: VaultConnection
  -> SecretPath
  -> Maybe SecretVersion
  -> IO (Either String SecretData)
getSecret :: VaultConnection
-> SecretPath
-> Maybe SecretVersion
-> IO (Either String SecretData)
getSecret VaultConnection
vc SecretPath
sp Maybe SecretVersion
msv =
  (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String SecretData
secret) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VaultConnection
-> SecretPath -> Maybe SecretVersion -> IO (Either String Value)
getSecretR VaultConnection
vc SecretPath
sp Maybe SecretVersion
msv

-- | Put 'SecretData' into Vault at the given location.
putSecret
  :: VaultConnection
  -> CheckAndSet                      -- ^ 'WriteAllowed', 'CreateOnly' or 'CurrentVersion'
  -> SecretPath
  -> SecretData                       -- ^ Data to put at 'SecretPath' location
  -> IO (Either String SecretVersion)
putSecret :: VaultConnection
-> CheckAndSet
-> SecretPath
-> SecretData
-> IO (Either String SecretVersion)
putSecret VaultConnection
vc CheckAndSet
cas SecretPath
sp SecretData
sd =
  (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String SecretVersion
version) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VaultConnection
-> CheckAndSet
-> SecretPath
-> SecretData
-> IO (Either String Value)
putSecretR VaultConnection
vc CheckAndSet
cas SecretPath
sp SecretData
sd

deleteSecret
  :: VaultConnection
  -> SecretPath
  -> IO (Maybe Error)
deleteSecret :: VaultConnection -> SecretPath -> IO (Maybe String)
deleteSecret VaultConnection
vc SecretPath
sp =
  Either String Value -> Maybe String
maybeError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VaultConnection -> SecretPath -> IO (Either String Value)
deleteSecretR VaultConnection
vc SecretPath
sp

deleteSecretVersions
  :: VaultConnection
  -> SecretPath
  -> SecretVersions
  -> IO (Maybe Error)
deleteSecretVersions :: VaultConnection
-> SecretPath -> SecretVersions -> IO (Maybe String)
deleteSecretVersions vc :: VaultConnection
vc@VaultConnection{} SecretPath{String
path :: String
path :: SecretPath -> String
..} SecretVersions
svs =
  Either String Value -> Maybe String
maybeError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
-> VaultConnection -> SecretVersions -> IO (Either String Value)
secretVersionsR [String
"POST ", forall a. Show a => a -> String
show VaultConnection
vc, String
"/delete/", String
path] VaultConnection
vc SecretVersions
svs

unDeleteSecretVersions
  :: VaultConnection
  -> SecretPath
  -> SecretVersions
  -> IO (Maybe Error)
unDeleteSecretVersions :: VaultConnection
-> SecretPath -> SecretVersions -> IO (Maybe String)
unDeleteSecretVersions vc :: VaultConnection
vc@VaultConnection{} SecretPath{String
path :: String
path :: SecretPath -> String
..} SecretVersions
svs =
  Either String Value -> Maybe String
maybeError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
-> VaultConnection -> SecretVersions -> IO (Either String Value)
secretVersionsR [String
"POST ", forall a. Show a => a -> String
show VaultConnection
vc, String
"/undelete/", String
path] VaultConnection
vc SecretVersions
svs

-- | Permanently delete a secret, i.e. all its versions and metadata.
destroySecret
  :: VaultConnection
  -> SecretPath
  -> IO (Maybe Error)
destroySecret :: VaultConnection -> SecretPath -> IO (Maybe String)
destroySecret VaultConnection
vc SecretPath
sp =
  Either String Value -> Maybe String
maybeError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VaultConnection -> SecretPath -> IO (Either String Value)
destroySecretR VaultConnection
vc SecretPath
sp

destroySecretVersions
  :: VaultConnection
  -> SecretPath
  -> SecretVersions
  -> IO (Either String A.Value)
destroySecretVersions :: VaultConnection
-> SecretPath -> SecretVersions -> IO (Either String Value)
destroySecretVersions vc :: VaultConnection
vc@VaultConnection{} SecretPath{String
path :: String
path :: SecretPath -> String
..} =
  [String]
-> VaultConnection -> SecretVersions -> IO (Either String Value)
secretVersionsR [String
"POST ", forall a. Show a => a -> String
show VaultConnection
vc, String
"/destroy/", String
path] VaultConnection
vc

-- | Get list of secrets and folders at the given location.
secretsList
  :: VaultConnection
  -> SecretPath
  -> IO (Either String [VaultKey])
secretsList :: VaultConnection -> SecretPath -> IO (Either String [VaultKey])
secretsList VaultConnection
vc SecretPath
sp =
  (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String [VaultKey]
list) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VaultConnection -> SecretPath -> IO (Either String Value)
secretsListR VaultConnection
vc SecretPath
sp

-- | Retrieve versions history of the given secret.
--
-- >λ: readSecretMetadata conn (SecretPath "MySecret")
-- >Right (SecretMetadata (fromList [(SecretVersion 1,Metadata {destroyed = True, deletion_time = "", created_time = "2019-05-30T13:22:58.416399224Z"}),(SecretVersion 2,Metadata {destroyed = True, deletion_time = "2019-06-29T15:28:46.145302138Z"})]))
--
readSecretMetadata
  :: VaultConnection
  -> SecretPath
  -> IO (Either String SecretMetadata)
readSecretMetadata :: VaultConnection -> SecretPath -> IO (Either String SecretMetadata)
readSecretMetadata VaultConnection
vc SecretPath
sp =
  (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String SecretMetadata
metadata) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VaultConnection -> SecretPath -> IO (Either String Value)
readSecretMetadataR VaultConnection
vc SecretPath
sp

-- | Get version number of the current given secret.
currentSecretVersion
  :: VaultConnection
  -> SecretPath
  -> IO (Either String SecretVersion)
currentSecretVersion :: VaultConnection -> SecretPath -> IO (Either String SecretVersion)
currentSecretVersion VaultConnection
vc SecretPath
sp =
  (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String SecretVersion
current) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VaultConnection -> SecretPath -> IO (Either String Value)
readSecretMetadataR VaultConnection
vc SecretPath
sp

-- Utils

toSecretData
  :: [(Text,Text)]
  -> SecretData
toSecretData :: [(Text, Text)] -> SecretData
toSecretData = HashMap Text Text -> SecretData
SecretData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList

fromSecretData
  :: SecretData
  -> [(Text,Text)]
fromSecretData :: SecretData -> [(Text, Text)]
fromSecretData (SecretData HashMap Text Text
sd) = forall k v. HashMap k v -> [(k, v)]
toList HashMap Text Text
sd

toSecretVersions
  :: [Int]
  -> SecretVersions
toSecretVersions :: [Int] -> SecretVersions
toSecretVersions [Int]
is =
  [SecretVersion] -> SecretVersions
SecretVersions (Int -> SecretVersion
SecretVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
is)