{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.VaultTool
( VaultAddress(..)
, VaultUnsealKey(..)
, VaultAuthToken(..)
, VaultAppRoleId(..)
, VaultAppRoleSecretId(..)
, VaultException(..)
, VaultHealth(..)
, vaultHealth
, VaultConnection
, connectToVault
, connectToVaultAppRole
, vaultAuthEnable
, vaultPolicyCreate
, vaultInit
, VaultSealStatus(..)
, vaultSealStatus
, vaultSeal
, VaultUnseal(..)
, vaultUnseal
, vaultAppRoleCreate
, vaultAppRoleRoleIdRead
, vaultAppRoleSecretIdGenerate
, defaultVaultAppRoleParameters
, VaultAppRoleParameters(..)
, VaultAppRoleSecretIdGenerateResponse(..)
, VaultMount(..)
, VaultMountRead
, VaultMountWrite
, VaultMountConfig(..)
, VaultMountConfigRead
, VaultMountConfigWrite
, vaultMounts
, vaultMountTune
, vaultMountSetTune
, vaultNewMount
, vaultUnmount
, VaultMountedPath(..)
, VaultSearchPath(..)
, VaultSecretPath(..)
, VaultSecretMetadata(..)
, vaultWrite
, vaultRead
, vaultDelete
, vaultList
, isFolder
, vaultListRecursive
) where
import Data.Monoid ((<>))
import Control.Exception (throwIO)
import Control.Monad (liftM)
import Data.Aeson
import Data.Aeson.Types (parseEither, Pair)
import Data.List (sortOn)
import Data.Text (Text)
import Data.Maybe (catMaybes)
import Network.HTTP.Client (Manager, newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Header (Header)
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.VaultTool.Internal
import Network.VaultTool.Types
data VaultAction
= Create
| ReadVersion
| ReadMetadata
| Update
| UpdateMetadata
| ListSecrets
| DeleteLast
| DeleteVersions
| Undelete
| Destroy
| DeleteMetadata
vaultUrlPrefix :: VaultAction -> String
vaultUrlPrefix Create = "/data"
vaultUrlPrefix ReadVersion = "/data"
vaultUrlPrefix Update = "/data"
vaultUrlPrefix DeleteLast = "/data"
vaultUrlPrefix DeleteVersions = "/delete"
vaultUrlPrefix Undelete = "/undelete"
vaultUrlPrefix Destroy = "/destroy"
vaultUrlPrefix ListSecrets = "/metadata"
vaultUrlPrefix ReadMetadata = "/metadata"
vaultUrlPrefix UpdateMetadata = "/metadata"
vaultUrlPrefix DeleteMetadata = "/metadata"
data VaultConnection = VaultConnection
{ _VaultConnection_AuthToken :: VaultAuthToken
, _VaultConnection_VaultAddress :: VaultAddress
, _VaultConnection_Manager :: Manager
}
data VaultHealth = VaultHealth
{ _VaultHealth_Version :: Text
, _VaultHealth_ServerTimeUtc :: Int
, _VaultHealth_Initialized :: Bool
, _VaultHealth_Sealed :: Bool
, _VaultHealth_Standby :: Bool
}
deriving (Show, Eq, Ord)
instance FromJSON VaultHealth where
parseJSON (Object v) =
VaultHealth <$>
v .: "version" <*>
v .: "server_time_utc" <*>
v .: "initialized" <*>
v .: "sealed" <*>
v .: "standby"
parseJSON _ = fail "Not an Object"
vaultUrl :: VaultAddress -> String -> String
vaultUrl (VaultAddress addr) path = T.unpack addr ++ "/v1" ++ path
vaultActionUrl :: VaultAction -> VaultAddress -> VaultMountedPath -> VaultSearchPath -> String
vaultActionUrl action (VaultAddress addr) (VaultMountedPath mountedPath) (VaultSearchPath searchPath) =
T.unpack addr ++ "/v1/" ++ T.unpack mountedPath ++ (vaultUrlPrefix action) ++ "/" ++ T.unpack searchPath
vaultHealth :: VaultAddress -> IO VaultHealth
vaultHealth vaultAddress = do
manager <- newManager tlsManagerSettings
vaultRequestJSON manager "GET" (vaultUrl vaultAddress "/sys/health") [] (Nothing :: Maybe ()) expectedStatusCodes
where
expectedStatusCodes = [200, 429, 501, 503]
connectToVault :: VaultAddress -> VaultAuthToken -> IO VaultConnection
connectToVault addr authToken = do
manager <- newManager tlsManagerSettings
pure VaultConnection
{ _VaultConnection_AuthToken = authToken
, _VaultConnection_VaultAddress = addr
, _VaultConnection_Manager = manager
}
connectToVaultAppRole :: VaultAddress -> VaultAppRoleId -> VaultAppRoleSecretId -> IO VaultConnection
connectToVaultAppRole addr roleId secretId = do
manager <- newManager tlsManagerSettings
authToken <- vaultAppRoleLogin addr manager roleId secretId
connectToVault addr authToken
data VaultInitResponse = VaultInitResponse
{ _VaultInitResponse_Keys :: [Text]
, _VaultInitResponse_RootToken :: VaultAuthToken
}
deriving (Show, Eq, Ord)
instance FromJSON VaultInitResponse where
parseJSON (Object v) =
VaultInitResponse <$>
v .: "keys" <*>
v .: "root_token"
parseJSON _ = fail "Not an Object"
vaultInit
:: VaultAddress
-> Int
-> Int
-> IO ([VaultUnsealKey], VaultAuthToken)
vaultInit addr secretShares secretThreshold = do
let reqBody = object
[ "secret_shares" .= secretShares
, "secret_threshold" .= secretThreshold
]
manager <- newManager tlsManagerSettings
rsp <- vaultRequestJSON manager "PUT" (vaultUrl addr "/sys/init") [] (Just reqBody) [200]
let VaultInitResponse{_VaultInitResponse_Keys, _VaultInitResponse_RootToken} = rsp
pure (map VaultUnsealKey _VaultInitResponse_Keys, _VaultInitResponse_RootToken)
data VaultSealStatus = VaultSealStatus
{ _VaultSealStatus_Sealed :: Bool
, _VaultSealStatus_T :: Int
, _VaultSealStatus_N :: Int
, _VaultSealStatus_Progress :: Int
}
deriving (Show, Eq, Ord)
instance FromJSON VaultSealStatus where
parseJSON (Object v) =
VaultSealStatus <$>
v .: "sealed" <*>
v .: "t" <*>
v .: "n" <*>
v .: "progress"
parseJSON _ = fail "Not an Object"
vaultSealStatus :: VaultAddress -> IO VaultSealStatus
vaultSealStatus addr = do
manager <- newManager tlsManagerSettings
vaultRequestJSON manager "GET" (vaultUrl addr "/sys/seal-status") [] (Nothing :: Maybe ()) [200]
data VaultAuth = VaultAuth
{ _VaultAuth_Renewable :: Bool
, _VaultAuth_LeaseDuration :: Int
, _VaultAuth_Policies :: [Text]
, _VaultAuth_ClientToken :: VaultAuthToken
}
deriving (Show, Eq, Ord)
instance FromJSON VaultAuth where
parseJSON (Object v) =
VaultAuth <$>
v .: "renewable" <*>
v .: "lease_duration" <*>
v .: "policies" <*>
v .: "client_token"
parseJSON _ = fail "Not an Object"
data VaultAppRoleResponse = VaultAppRoleResponse
{ _VaultAppRoleResponse_Auth :: Maybe VaultAuth
, _VaultAppRoleResponse_Warnings :: Value
, _VaultAppRoleResponse_WrapInfo :: Value
, _VaultAppRoleResponse_Data :: Value
, _VaultAppRoleResponse_LeaseDuration :: Int
, _VaultAppRoleResponse_Renewable :: Bool
, _VaultAppRoleResponse_LeaseId :: Text
}
deriving (Show, Eq)
instance FromJSON VaultAppRoleResponse where
parseJSON (Object v) =
VaultAppRoleResponse <$>
v .:? "auth" <*>
v .: "warnings" <*>
v .: "wrap_info" <*>
v .: "data" <*>
v .: "lease_duration" <*>
v .: "renewable" <*>
v .: "lease_id"
parseJSON _ = fail "Not an Object"
authTokenHeader :: VaultAuthToken -> Header
authTokenHeader (VaultAuthToken token) = ("X-Vault-Token", T.encodeUtf8 token)
vaultAppRoleLogin :: VaultAddress -> Manager -> VaultAppRoleId -> VaultAppRoleSecretId -> IO VaultAuthToken
vaultAppRoleLogin addr manager roleId secretId = do
response <- vaultRequestJSON manager "POST" (vaultUrl addr "/auth/approle/login") [] (Just reqBody) [200]
maybe failOnNullAuth (return . _VaultAuth_ClientToken) $ _VaultAppRoleResponse_Auth response
where
reqBody = object
[ "role_id" .= unVaultAppRoleId roleId,
"secret_id" .= unVaultAppRoleSecretId secretId
]
failOnNullAuth = fail "Auth on login is null"
vaultAuthEnable :: VaultConnection -> Text -> IO ()
vaultAuthEnable VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} authMethod = do
_ <- vaultRequest _VaultConnection_Manager "POST" (vaultUrl _VaultConnection_VaultAddress "/sys/auth/" ++ T.unpack authMethod) headers (Just reqBody) [200]
pure ()
where
reqBody = object [ "type" .= authMethod ]
headers = [authTokenHeader _VaultConnection_AuthToken]
vaultPolicyCreate :: VaultConnection -> Text -> Text -> IO ()
vaultPolicyCreate VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} policyName policy = do
_ <- vaultRequest _VaultConnection_Manager "PUT" (vaultUrl _VaultConnection_VaultAddress "/sys/policies/acl/" ++ T.unpack policyName) headers (Just reqBody) [200]
pure ()
where
reqBody = object [ "policy" .= policy ]
headers = [authTokenHeader _VaultConnection_AuthToken]
data VaultAppRoleListResponse = VaultAppRoleListResponse
{ _VaultAppRoleListResponse_AppRoles :: [Text] }
instance FromJSON VaultAppRoleListResponse where
parseJSON (Object v) =
VaultAppRoleListResponse <$>
v .: "keys"
parseJSON _ = fail "Not an Object"
data VaultAppRoleParameters = VaultAppRoleParameters
{ _VaultAppRoleParameters_BindSecretId :: Bool
, _VaultAppRoleParameters_Policies :: [Text]
, _VaultAppRoleParameters_SecretIdNumUses :: Maybe Int
, _VaultAppRoleParameters_SecretIdTTL :: Maybe Int
, _VaultAppRoleParameters_TokenNumUses :: Maybe Int
, _VaultAppRoleParameters_TokenTTL :: Maybe Int
, _VaultAppRoleParameters_TokenMaxTTL :: Maybe Int
, _VaultAppRoleParameters_Period :: Maybe Int
}
instance ToJSON VaultAppRoleParameters where
toJSON v = object $
[ "bind_secret_id" .= _VaultAppRoleParameters_BindSecretId v
, "policies" .= _VaultAppRoleParameters_Policies v
] <> catMaybes
[ "secret_id_num_uses" .=? _VaultAppRoleParameters_SecretIdNumUses v
, "secret_id_ttl" .=? _VaultAppRoleParameters_SecretIdTTL v
, "token_num_uses" .=? _VaultAppRoleParameters_TokenNumUses v
, "token_ttl" .=? _VaultAppRoleParameters_TokenTTL v
, "token_max_ttl" .=? _VaultAppRoleParameters_TokenMaxTTL v
, "period" .=? _VaultAppRoleParameters_Period v
]
where
(.=?) :: ToJSON x => Text -> Maybe x -> Maybe Pair
t .=? x = (t .=) <$> x
instance FromJSON VaultAppRoleParameters where
parseJSON (Object v) =
VaultAppRoleParameters <$>
v .: "bind_secret_id" <*>
v .: "policies" <*>
v .:? "secret_id_num_uses" <*>
v .:? "secret_id_ttl" <*>
v .:? "token_num_uses" <*>
v .:? "token_ttl" <*>
v .:? "token_max_ttl" <*>
v .:? "period"
parseJSON _ = fail "Not an Object"
defaultVaultAppRoleParameters :: VaultAppRoleParameters
defaultVaultAppRoleParameters = VaultAppRoleParameters True [] Nothing Nothing Nothing Nothing Nothing Nothing
vaultAppRoleCreate :: VaultConnection -> Text -> VaultAppRoleParameters -> IO ()
vaultAppRoleCreate VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} appRoleName varp = do
_ <- vaultRequest _VaultConnection_Manager "POST" (vaultUrl _VaultConnection_VaultAddress "/auth/approle/role/" ++ T.unpack appRoleName) headers (Just varp) [200]
pure ()
where
headers = [authTokenHeader _VaultConnection_AuthToken]
vaultAppRoleRoleIdRead :: VaultConnection -> Text -> IO VaultAppRoleId
vaultAppRoleRoleIdRead VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} appRoleName = do
response <- vaultRequestJSON _VaultConnection_Manager "GET" (vaultUrl _VaultConnection_VaultAddress "/auth/approle/role/" ++ T.unpack appRoleName ++ "/role-id") headers (Nothing :: Maybe ()) [200]
let d = _VaultAppRoleResponse_Data response
case parseEither parseJSON d of
Left err -> throwIO $ VaultException_ParseBodyError "GET" ("/auth/approle/role/" ++ T.unpack appRoleName ++ "/role-id") (encode d) err
Right obj -> return obj
where
headers = [authTokenHeader _VaultConnection_AuthToken]
data VaultAppRoleSecretIdGenerateResponse = VaultAppRoleSecretIdGenerateResponse
{ _VaultAppRoleSecretIdGenerateResponse_SecretIdAccessor :: VaultAppRoleSecretIdAccessor
, _VaultAppRoleSecretIdGenerateResponse_SecretId :: VaultAppRoleSecretId
}
instance FromJSON VaultAppRoleSecretIdGenerateResponse where
parseJSON (Object v) =
VaultAppRoleSecretIdGenerateResponse <$>
v .: "secret_id_accessor" <*>
v .: "secret_id"
parseJSON _ = fail "Not an Object"
vaultAppRoleSecretIdGenerate :: VaultConnection -> Text -> Text -> IO VaultAppRoleSecretIdGenerateResponse
vaultAppRoleSecretIdGenerate VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} appRoleName metadata = do
response <- vaultRequestJSON _VaultConnection_Manager "POST" (vaultUrl _VaultConnection_VaultAddress "/auth/approle/role/" ++ T.unpack appRoleName ++ "/secret-id") headers (Just reqBody) [200]
let d = _VaultAppRoleResponse_Data response
case parseEither parseJSON d of
Left err -> throwIO $ VaultException_ParseBodyError "POST" ("/auth/approle/role/" ++ T.unpack appRoleName ++ "/secret-id") (encode d) err
Right obj -> return obj
where
reqBody = object[ "metadata" .= metadata ]
headers = [authTokenHeader _VaultConnection_AuthToken]
vaultSeal :: VaultConnection -> IO ()
vaultSeal VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} = do
_ <- vaultRequest _VaultConnection_Manager "PUT" (vaultUrl _VaultConnection_VaultAddress "/sys/seal") headers (Nothing :: Maybe ()) [200]
pure ()
where
headers = [authTokenHeader _VaultConnection_AuthToken]
data VaultUnseal
= VaultUnseal_Key VaultUnsealKey
| VaultUnseal_Reset
deriving (Show, Eq, Ord)
vaultUnseal :: VaultAddress -> VaultUnseal -> IO VaultSealStatus
vaultUnseal addr unseal = do
let reqBody = case unseal of
VaultUnseal_Key (VaultUnsealKey key) -> object
[ "key" .= key
]
VaultUnseal_Reset -> object
[ "reset" .= True
]
manager <- newManager tlsManagerSettings
vaultRequestJSON manager "PUT" (vaultUrl addr "/sys/unseal") [] (Just reqBody) [200]
type VaultMountRead = VaultMount Text VaultMountConfigRead
type VaultMountWrite = VaultMount (Maybe Text) (Maybe VaultMountConfigWrite)
type VaultMountConfigRead = VaultMountConfig Int
type VaultMountConfigWrite = VaultMountConfig (Maybe Int)
data VaultMount a b = VaultMount
{ _VaultMount_Type :: Text
, _VaultMount_Description :: a
, _VaultMount_Config :: b
}
deriving (Show, Eq, Ord)
instance FromJSON VaultMountRead where
parseJSON (Object v) =
VaultMount <$>
v .: "type" <*>
v .: "description" <*>
v .: "config"
parseJSON _ = fail "Not an Object"
instance ToJSON VaultMountWrite where
toJSON v = object
[ "type" .= _VaultMount_Type v
, "description" .= _VaultMount_Description v
, "config" .= _VaultMount_Config v
]
data VaultMountConfig a = VaultMountConfig
{ _VaultMountConfig_DefaultLeaseTtl :: a
, _VaultMountConfig_MaxLeaseTtl :: a
}
deriving (Show, Eq, Ord)
instance FromJSON VaultMountConfigRead where
parseJSON (Object v) =
VaultMountConfig <$>
v .: "default_lease_ttl" <*>
v .: "max_lease_ttl"
parseJSON _ = fail "Not an Object"
instance ToJSON VaultMountConfigWrite where
toJSON v = object
[ "default_lease_ttl" .= fmap formatSeconds (_VaultMountConfig_DefaultLeaseTtl v)
, "max_lease_ttl" .= fmap formatSeconds (_VaultMountConfig_MaxLeaseTtl v)
]
formatSeconds :: Int -> String
formatSeconds n = show n ++ "s"
vaultMounts :: VaultConnection -> IO [(Text, VaultMountRead)]
vaultMounts VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} = do
let reqPath = vaultUrl _VaultConnection_VaultAddress "/sys/mounts"
rspObj <- vaultRequestJSON _VaultConnection_Manager "GET" reqPath headers (Nothing :: Maybe ()) [200]
let root = case H.lookup "data" rspObj of
Nothing -> Object rspObj
Just v -> v
case parseEither parseJSON root of
Left err -> throwIO $ VaultException_ParseBodyError "GET" reqPath (encode rspObj) err
Right obj -> pure $ sortOn fst (H.toList obj)
where
headers = [authTokenHeader _VaultConnection_AuthToken]
vaultMountTune :: VaultConnection -> Text -> IO VaultMountConfigRead
vaultMountTune VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} mountPoint = do
vaultRequestJSON _VaultConnection_Manager "GET" (vaultUrl _VaultConnection_VaultAddress "/sys/mounts/" ++ T.unpack mountPoint ++ "/tune") headers (Nothing :: Maybe ()) [200]
where
headers = [authTokenHeader _VaultConnection_AuthToken]
vaultMountSetTune :: VaultConnection -> Text -> VaultMountConfigWrite -> IO ()
vaultMountSetTune VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} mountPoint mountConfig = do
let reqBody = mountConfig
_ <- vaultRequest _VaultConnection_Manager "POST" (vaultUrl _VaultConnection_VaultAddress "/sys/mounts/" ++ T.unpack mountPoint ++ "/tune") headers (Just reqBody) [200]
pure ()
where
headers = [authTokenHeader _VaultConnection_AuthToken]
vaultNewMount :: VaultConnection -> Text -> VaultMountWrite -> IO ()
vaultNewMount VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} mountPoint vaultMount = do
let reqBody = vaultMount
_ <- vaultRequest _VaultConnection_Manager "POST" (vaultUrl _VaultConnection_VaultAddress "/sys/mounts/" ++ T.unpack mountPoint) headers (Just reqBody) [200]
pure ()
where
headers = [authTokenHeader _VaultConnection_AuthToken]
vaultUnmount :: VaultConnection -> Text -> IO ()
vaultUnmount VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} mountPoint = do
_ <- vaultRequest _VaultConnection_Manager "DELETE" (vaultUrl _VaultConnection_VaultAddress "/sys/mounts/" ++ T.unpack mountPoint) headers (Nothing :: Maybe ()) [200]
pure ()
where
headers = [authTokenHeader _VaultConnection_AuthToken]
data VaultSecretMetadata = VaultSecretMetadata
{ _VaultSecretMetadata_leaseDuration :: Int
, _VaultSecretMetadata_leaseId :: Text
, _VauleSecretMetadata_renewable :: Bool
}
deriving (Show, Eq )
instance FromJSON VaultSecretMetadata where
parseJSON (Object v) =
VaultSecretMetadata <$>
v .: "lease_duration" <*>
v .: "lease_id" <*>
v .: "renewable"
parseJSON _ = fail "Not an Object"
vaultWrite :: ToJSON a => VaultConnection -> VaultSecretPath -> a -> IO ()
vaultWrite VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} (VaultSecretPath (mountedPath, searchPath)) value = do
let reqBody = value
let path = vaultActionUrl Create _VaultConnection_VaultAddress mountedPath searchPath
_ <- vaultRequest _VaultConnection_Manager "POST" path headers (Just reqBody) [200, 204]
pure ()
where
headers = [authTokenHeader _VaultConnection_AuthToken]
vaultRead
:: FromJSON a
=> VaultConnection
-> VaultSecretPath
-> IO (VaultSecretMetadata, Either (Value, String) a)
vaultRead VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} (VaultSecretPath (mountedPath, searchPath)) = do
let path = vaultActionUrl ReadMetadata _VaultConnection_VaultAddress mountedPath searchPath
rspObj <- vaultRequestJSON _VaultConnection_Manager "GET" path headers (Nothing :: Maybe ()) [200]
case parseEither parseJSON (Object rspObj) of
Left err -> throwIO $ VaultException_ParseBodyError "GET" path (encode rspObj) err
Right metadata -> case parseEither (.: "data") rspObj of
Left err -> throwIO $ VaultException_ParseBodyError "GET" path (encode rspObj) err
Right dataObj -> case parseEither parseJSON (Object dataObj) of
Left err -> pure (metadata, Left (Object dataObj, err))
Right data_ -> pure (metadata, Right data_)
where
headers = [authTokenHeader _VaultConnection_AuthToken]
vaultDelete :: VaultConnection -> VaultSecretPath -> IO ()
vaultDelete VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} (VaultSecretPath (mountedPath, searchPath)) = do
let path = vaultActionUrl DeleteMetadata _VaultConnection_VaultAddress mountedPath searchPath
_ <- vaultRequest _VaultConnection_Manager "DELETE" path headers (Nothing :: Maybe ()) [204]
pure ()
where
headers = [authTokenHeader _VaultConnection_AuthToken]
data VaultListResult = VaultListResult [Text]
instance FromJSON VaultListResult where
parseJSON (Object v) = do
data_ <- v .: "data"
keys <- data_ .: "keys"
pure (VaultListResult keys)
parseJSON _ = fail "Not an Object"
vaultList :: VaultConnection -> VaultSecretPath -> IO [VaultSecretPath]
vaultList VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} (VaultSecretPath (VaultMountedPath mountedPath, VaultSearchPath searchPath)) = do
let path = vaultActionUrl ListSecrets _VaultConnection_VaultAddress (VaultMountedPath mountedPath) (VaultSearchPath searchPath)
VaultListResult keys <- vaultRequestJSON _VaultConnection_Manager "LIST" path headers (Nothing :: Maybe ()) [200]
pure $ map (VaultSecretPath . fullSecretPath) keys
where
headers = [authTokenHeader _VaultConnection_AuthToken]
fullSecretPath key = (VaultMountedPath mountedPath, VaultSearchPath (withTrailingSlash `T.append` key))
withTrailingSlash
| T.null searchPath = "/"
| T.last searchPath == '/' = searchPath
| otherwise = searchPath `T.snoc` '/'
isFolder :: VaultSecretPath -> Bool
isFolder (VaultSecretPath (_, VaultSearchPath searchPath))
| T.null searchPath = False
| otherwise = T.last searchPath == '/'
vaultListRecursive :: VaultConnection -> VaultSecretPath -> IO [VaultSecretPath]
vaultListRecursive conn location = do
paths <- vaultList conn location
(flip concatMapM) paths $ \path -> do
if isFolder path
then vaultListRecursive conn path
else pure [path]
concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = liftM concat (mapM f xs)