diff --git a/src/Network/VaultTool.hs b/src/Network/VaultTool.hs --- a/src/Network/VaultTool.hs +++ b/src/Network/VaultTool.hs @@ -9,6 +9,8 @@ ( VaultAddress(..) , VaultUnsealKey(..) , VaultAuthToken(..) + , VaultAppRoleId(..) + , VaultAppRoleSecretId(..) , VaultException(..) , VaultHealth(..) @@ -17,6 +19,12 @@ , VaultConnection , connectToVault + , connectToVaultAppRole + + , vaultAuthEnable + + , vaultPolicyCreate + , vaultInit , VaultSealStatus(..) , vaultSealStatus @@ -24,6 +32,13 @@ , VaultUnseal(..) , vaultUnseal + , vaultAppRoleCreate + , vaultAppRoleRoleIdRead + , vaultAppRoleSecretIdGenerate + , defaultVaultAppRoleParameters + , VaultAppRoleParameters(..) + , VaultAppRoleSecretIdGenerateResponse(..) + , VaultMount(..) , VaultMountRead , VaultMountWrite @@ -46,12 +61,14 @@ , vaultListRecursive ) where +import Data.Monoid ((<>)) import Control.Exception (throwIO) import Control.Monad (liftM) import Data.Aeson -import Data.Aeson.Types (parseEither) +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 qualified Data.HashMap.Strict as H @@ -111,6 +128,14 @@ , _VaultConnection_Manager = manager } +-- | Initializes the 'VaultConnection' objects using approle credentials to retrieve an authtoken, +-- and then calls `connectToVault` +connectToVaultAppRole :: VaultAddress -> VaultAppRoleId -> VaultAppRoleSecretId -> IO VaultConnection +connectToVaultAppRole addr roleId secretId = do + manager <- newManager tlsManagerSettings + authToken <- vaultAppRoleLogin addr manager roleId secretId + connectToVault addr authToken + -- | -- -- See 'vaultInit' @@ -171,6 +196,180 @@ manager <- newManager tlsManagerSettings vaultRequestJSON manager "GET" (vaultUrl addr "/sys/seal-status") [] (Nothing :: Maybe ()) [200] +-- | +-- +-- See 'sample-response-7' +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" + +-- | +-- +-- See 'sample-response-7' +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" + +-- | +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) [204] + pure () + where + reqBody = object [ "type" .= authMethod ] + headers = [("X-Vault-Token", unVaultAuthToken _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) [204] + pure () + where + reqBody = object [ "policy" .= policy ] + headers = [("X-Vault-Token", unVaultAuthToken _VaultConnection_AuthToken)] + +data VaultAppRoleListResponse = VaultAppRoleListResponse + { _VaultAppRoleListResponse_AppRoles :: [Text] } + +instance FromJSON VaultAppRoleListResponse where + parseJSON (Object v) = + VaultAppRoleListResponse <$> + v .: "keys" + parseJSON _ = fail "Not an Object" + +-- | +-- +-- Note: For TTL fields, only integer number seconds, i.e. 3600, are supported +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) [204] + pure () + where + headers = [("X-Vault-Token", unVaultAuthToken _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 = [("X-Vault-Token", unVaultAuthToken _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 = [("X-Vault-Token", unVaultAuthToken _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 ()) [204] @@ -198,7 +397,6 @@ ] 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) diff --git a/src/Network/VaultTool/Types.hs b/src/Network/VaultTool/Types.hs --- a/src/Network/VaultTool/Types.hs +++ b/src/Network/VaultTool/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Network.VaultTool.Types where import Control.Exception (Exception) @@ -23,6 +25,38 @@ newtype VaultSecretPath = VaultSecretPath { unVaultSecretPath :: Text } deriving (Show, Eq, Ord) + +newtype VaultAppRoleId = VaultAppRoleId { unVaultAppRoleId :: Text } + deriving (Show, Eq, Ord) + +instance FromJSON VaultAppRoleId where + parseJSON (Object v) = VaultAppRoleId <$> v .: "role_id" + parseJSON _ = fail "Not an Object" + +instance ToJSON VaultAppRoleId where + toJSON v = object [ "role_id" .= unVaultAppRoleId v ] + +newtype VaultAppRoleSecretId = VaultAppRoleSecretId { unVaultAppRoleSecretId :: Text } + deriving (Show, Eq, Ord) + +instance FromJSON VaultAppRoleSecretId where + parseJSON j = do + text <- parseJSON j + pure $ VaultAppRoleSecretId text + +instance ToJSON VaultAppRoleSecretId where + toJSON v = object [ "secret_id" .= unVaultAppRoleSecretId v ] + +newtype VaultAppRoleSecretIdAccessor = VaultAppRoleSecretIdAccessor { unVaultAppRoleSecretIdAccessor :: Text } + deriving (Show, Eq, Ord) + +instance FromJSON VaultAppRoleSecretIdAccessor where + parseJSON j = do + text <- parseJSON j + pure $ VaultAppRoleSecretIdAccessor text + +instance ToJSON VaultAppRoleSecretIdAccessor where + toJSON v = object [ "secret_id_accessor" .= unVaultAppRoleSecretIdAccessor v ] data VaultException = VaultException diff --git a/vault-tool.cabal b/vault-tool.cabal --- a/vault-tool.cabal +++ b/vault-tool.cabal @@ -1,5 +1,5 @@ name: vault-tool -version: 0.0.0.3 +version: 0.0.0.4 synopsis: Client library for HashiCorp's Vault tool (via HTTP API) description: Client library for HashiCorp's Vault tool (via HTTP API) license: MIT