{-# 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 qualified Data.ByteString.Char8               as C
import           Data.HashMap.Strict
import qualified Data.Maybe                          as M
import           Data.Text                           hiding (concat)
import           Network.Connection 
import           Network.HTTP.Client.TLS
import           System.Environment                  (lookupEnv)
import           System.Posix.Files                  (fileExist)

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

-- | Get a 'VaultConnection', or an error message.
--
-- >λ: vaultConnect (Just "https://vault.local.lan:8200/") "/secret" Nothing False
--
vaultConnect
  :: Maybe String                       -- ^ Use 'Just' this Vault server address, or get it from environment variable VAULT_ADDR
  -> String                             -- ^ KV engine path
  -> Maybe VaultToken                   -- ^ Use 'Just' this 'VaultToken' or get it from $HOME/.vaut-token
  -> Bool                               -- ^ Disable certificate validation
  -> IO (Either String VaultConnection)
vaultConnect :: Maybe String
-> String
-> Maybe String
-> Bool
-> IO (Either String VaultConnection)
vaultConnect Maybe String
mva String
kvep Maybe String
mvt Bool
dcv = do
  Manager
nm <- ManagerSettings -> IO Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newTlsManagerWith (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$
          TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings
            TLSSettingsSimple :: Bool -> Bool -> Bool -> TLSSettings
TLSSettingsSimple
              { settingDisableCertificateValidation :: Bool
settingDisableCertificateValidation = Bool
dcv
              , settingDisableSession :: Bool
settingDisableSession               = Bool
False
              , settingUseServerName :: Bool
settingUseServerName                = Bool
True
              }
            Maybe SockSettings
forall a. Maybe a
Nothing
  Maybe String
va <- if Maybe String -> Bool
forall a. Maybe a -> Bool
M.isJust Maybe String
mva then Maybe String -> IO (Maybe String)
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  -> Either String ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
C.pack String
t)
           Maybe String
Nothing -> do
             Maybe String
hm <- String -> IO (Maybe String)
lookupEnv String
"HOME"
             if Maybe String -> Bool
forall a. Maybe a -> Bool
M.isJust Maybe String
hm
               then do
                 let fp :: String
fp = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
M.fromJust Maybe String
hm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/.vault-token"
                 if Maybe String -> Bool
forall a. Maybe a -> Bool
M.isJust Maybe String
va
                   then do
                     Bool
fe <- String -> IO Bool
fileExist String
fp
                     if Bool
fe 
                       then ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> IO ByteString -> IO (Either String ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fp
                       else Either String ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ String
"No Vault token file found at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp)
                   else Either String ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Variable environment VAULT_ADDR not set")
               else Either String ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Variable environment HOME not set")
  Either String VaultConnection -> IO (Either String VaultConnection)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String VaultConnection
 -> IO (Either String VaultConnection))
-> Either String VaultConnection
-> IO (Either String VaultConnection)
forall a b. (a -> b) -> a -> b
$
    (\ByteString
vt ->
      VaultConnection :: String -> String -> ByteString -> Manager -> VaultConnection
VaultConnection
        { vaultAddr :: String
vaultAddr    = Maybe String -> String
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
        }
    ) (ByteString -> VaultConnection)
-> Either String ByteString -> Either String VaultConnection
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 -> Bool -> IO (Either String Value)
kvEngineConfig vc :: VaultConnection
vc@VaultConnection{} =
  [String]
-> VaultConnection -> Int -> Bool -> IO (Either String Value)
configR [String
"POST ", VaultConnection -> String
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 -> Bool -> IO (Either String Value)
secretConfig vc :: VaultConnection
vc@VaultConnection{} SecretPath{String
path :: SecretPath -> String
path :: String
..} =
  [String]
-> VaultConnection -> Int -> Bool -> IO (Either String Value)
configR [String
"POST ", VaultConnection -> String
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 =
  (Either String Value
-> (Value -> Either String SecretData) -> Either String SecretData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String SecretData
secret) (Either String Value -> Either String SecretData)
-> IO (Either String Value) -> IO (Either String SecretData)
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 =
  (Either String Value
-> (Value -> Either String SecretVersion)
-> Either String SecretVersion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String SecretVersion
version) (Either String Value -> Either String SecretVersion)
-> IO (Either String Value) -> IO (Either String SecretVersion)
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 (Either String Value -> Maybe String)
-> IO (Either String Value) -> IO (Maybe String)
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 (Either String Value -> Maybe String)
-> IO (Either String Value) -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
-> VaultConnection -> SecretVersions -> IO (Either String Value)
secretVersionsR [String
"POST ", VaultConnection -> String
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 (Either String Value -> Maybe String)
-> IO (Either String Value) -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
-> VaultConnection -> SecretVersions -> IO (Either String Value)
secretVersionsR [String
"POST ", VaultConnection -> String
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 (Either String Value -> Maybe String)
-> IO (Either String Value) -> IO (Maybe String)
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 ", VaultConnection -> String
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 =
  (Either String Value
-> (Value -> Either String [VaultKey]) -> Either String [VaultKey]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String [VaultKey]
list) (Either String Value -> Either String [VaultKey])
-> IO (Either String Value) -> IO (Either String [VaultKey])
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 =
  (Either String Value
-> (Value -> Either String SecretMetadata)
-> Either String SecretMetadata
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String SecretMetadata
metadata) (Either String Value -> Either String SecretMetadata)
-> IO (Either String Value) -> IO (Either String SecretMetadata)
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 =
  (Either String Value
-> (Value -> Either String SecretVersion)
-> Either String SecretVersion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Either String SecretVersion
current) (Either String Value -> Either String SecretVersion)
-> IO (Either String Value) -> IO (Either String SecretVersion)
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 (HashMap Text Text -> SecretData)
-> ([(Text, Text)] -> HashMap Text Text)
-> [(Text, Text)]
-> SecretData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> HashMap Text Text
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) = HashMap Text Text -> [(Text, Text)]
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 (Int -> SecretVersion) -> [Int] -> [SecretVersion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
is)