gothic 0.1.8.2 → 0.1.8.3
raw patch · 13 files changed
+715/−711 lines, 13 filesdep ~hashablePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: hashable
API changes (from Hackage documentation)
Files
- Database/Vault/KVv2/Client.hs +0/−233
- Database/Vault/KVv2/Client/Internal.hs +0/−106
- Database/Vault/KVv2/Client/Lens.hs +0/−94
- Database/Vault/KVv2/Client/Requests.hs +0/−120
- Database/Vault/KVv2/Client/Types.hs +0/−148
- LICENSE +1/−1
- ReadMe.md +1/−2
- gothic.cabal +14/−7
- src/Database/Vault/KVv2/Client.hs +233/−0
- src/Database/Vault/KVv2/Client/Internal.hs +106/−0
- src/Database/Vault/KVv2/Client/Lens.hs +92/−0
- src/Database/Vault/KVv2/Client/Requests.hs +120/−0
- src/Database/Vault/KVv2/Client/Types.hs +148/−0
− Database/Vault/KVv2/Client.hs
@@ -1,233 +0,0 @@-{-# 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 mva kvep mvt dcv = do- nm <- newTlsManagerWith $- mkManagerSettings- TLSSettingsSimple- { settingDisableCertificateValidation = dcv- , settingDisableSession = False- , settingUseServerName = True- }- Nothing- va <- if M.isJust mva- then return mva- else lookupEnv "VAULT_ADDR"- evt <- case mvt of- Just t -> pure (Right $ encodeUtf8 $ T.pack t)- Nothing -> do- hm <- lookupEnv "HOME"- if M.isJust hm- then do- let fp = M.fromJust hm ++ "/.vault-token"- if M.isJust va- then do- fe <- fileExist fp- if fe- then Right <$> B.readFile fp- else pure (Left $ "No Vault token file found at " ++ fp)- else pure (Left "Variable environment VAULT_ADDR not set")- else pure (Left "Variable environment HOME not set")- pure $- (\vt ->- VaultConnection- { vaultAddr = M.fromJust va- , vaultToken = vt- , kvEnginePath = kvep- , manager = nm- }- ) <$> evt---- | Set default secret settings for the KVv2 engine.-kvEngineConfig- :: VaultConnection- -> Int -- ^ Max versions- -> Bool -- ^ CAS required- -> IO (Either String A.Value)-kvEngineConfig vc@VaultConnection{} =- configR ["POST ", show vc, "/config"] vc---- | Override default secret settings for the given secret.-secretConfig- :: VaultConnection- -> SecretPath- -> Int -- ^ Max versions- -> Bool -- ^ CAS required- -> IO (Either String A.Value)-secretConfig vc@VaultConnection{} SecretPath{..} =- configR ["POST ", show vc, "/metadata/", path] 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 vc sp msv =- (>>= secret) <$> getSecretR vc sp 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 vc cas sp sd =- (>>= version) <$> putSecretR vc cas sp sd--deleteSecret- :: VaultConnection- -> SecretPath- -> IO (Maybe Error)-deleteSecret vc sp =- maybeError <$> deleteSecretR vc sp--deleteSecretVersions- :: VaultConnection- -> SecretPath- -> SecretVersions- -> IO (Maybe Error)-deleteSecretVersions vc@VaultConnection{} SecretPath{..} svs =- maybeError <$> secretVersionsR ["POST ", show vc, "/delete/", path] vc svs--unDeleteSecretVersions- :: VaultConnection- -> SecretPath- -> SecretVersions- -> IO (Maybe Error)-unDeleteSecretVersions vc@VaultConnection{} SecretPath{..} svs =- maybeError <$> secretVersionsR ["POST ", show vc, "/undelete/", path] vc svs---- | Permanently delete a secret, i.e. all its versions and metadata.-destroySecret- :: VaultConnection- -> SecretPath- -> IO (Maybe Error)-destroySecret vc sp =- maybeError <$> destroySecretR vc sp--destroySecretVersions- :: VaultConnection- -> SecretPath- -> SecretVersions- -> IO (Either String A.Value)-destroySecretVersions vc@VaultConnection{} SecretPath{..} =- secretVersionsR ["POST ", show vc, "/destroy/", path] vc---- | Get list of secrets and folders at the given location.-secretsList- :: VaultConnection- -> SecretPath- -> IO (Either String [VaultKey])-secretsList vc sp =- (>>= list) <$> secretsListR vc 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 vc sp =- (>>= metadata) <$> readSecretMetadataR vc sp---- | Get version number of the current given secret.-currentSecretVersion- :: VaultConnection- -> SecretPath- -> IO (Either String SecretVersion)-currentSecretVersion vc sp =- (>>= current) <$> readSecretMetadataR vc sp---- Utils--toSecretData- :: [(Text,Text)]- -> SecretData-toSecretData = SecretData . fromList--fromSecretData- :: SecretData- -> [(Text,Text)]-fromSecretData (SecretData sd) = toList sd--toSecretVersions- :: [Int]- -> SecretVersions-toSecretVersions is =- SecretVersions (SecretVersion <$> is)-
− Database/Vault/KVv2/Client/Internal.hs
@@ -1,106 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Database.Vault.KVv2.Client.Internal where--import Control.Lens-import Control.Monad.Catch-import qualified Data.Aeson as A-import Data.Aeson.Key (fromText)-import Data.Aeson.Lens-import qualified Data.ByteString as B-import Data.List as L-import Data.List.NonEmpty as N-import qualified Data.Maybe as M-import Data.Scientific-import Data.Text as T-import qualified Data.Vector as V-import Network.HTTP.Client-import Network.HTTP.Types.Header--runRequest- :: Manager- -> Request- -> IO (Either String A.Value)-runRequest m r =- esv <$> try (httpLbs r m)- where- esv t =- case t of- Right b ->- pure (M.fromMaybe A.Null $ A.decode $ responseBody b)- Left e -> Left $ show (e::SomeException)--fromVaultResponse- :: T.Text- -> (A.Value -> Either String a)- -> A.Value- -> Either String a-fromVaultResponse k f v =- case v ^? key "data" . key (fromText k) of- Just o@(A.Object _) -> f o- Just n@(A.Number _) -> f n- Just a@(A.Array _) -> f a- Just _ -> Left "Unexpected JSON type"- Nothing -> Left (jsonErrors v)--vaultHeaders- :: B.ByteString -- ^ Vault token- -> [(HeaderName, B.ByteString)]-vaultHeaders vt =- [ ("Content-Type", "application/json; charset=utf-8")- , ("X-Vault-Token", vt)- ]--toJSONName :: String -> String-toJSONName "secret_data" = "data"-toJSONName "secret_metadata" = "metadata"-toJSONName "response_data" = "data"-toJSONName s = s--jsonErrors :: A.Value -> String-jsonErrors v =- case v ^? key "errors" of- Just ja ->- case ja of- A.Array a ->- if a == mempty- then "Undetermined error"- else- L.intercalate- ", "- (toString <$> V.toList a) ++ "."- _anyOther -> "Expected JSON array"- Nothing -> expectedJSONField "errors"--toString :: A.Value -> String-toString (A.String s) = T.unpack s-toString _ = fail "Expected JSON String"--expectedJSONField :: String -> String-expectedJSONField = (++) "Expected JSON field not found: "--unexpectedJSONType :: Either String b-unexpectedJSONType = Left "Unexpected JSON type"--toInt :: Scientific -> Int-toInt = M.fromJust . toBoundedInteger--hasTrailingSlash :: String -> Bool-hasTrailingSlash s = N.last (N.fromList s) == '/'--removeTrailingSlash :: String -> String-removeTrailingSlash s =- if hasTrailingSlash s- then N.init (N.fromList s)- else s--hasLeadingSlash :: String -> Bool--- hasLeadingSlash s = N.head (N.fromList s) == '/'-hasLeadingSlash s = N.head (N.fromList s) == '/'--removeLeadingSlash :: String -> String-removeLeadingSlash s =- if hasLeadingSlash s- then N.tail (N.fromList s)- else s-
− Database/Vault/KVv2/Client/Lens.hs
@@ -1,94 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- {-# LANGUAGE ExplicitForAll #-}--- {-# LANGUAGE RankNTypes #-}--module Database.Vault.KVv2.Client.Lens (-- current,- list,- metadata,- maybeError,- secret,- version-- ) where--import Control.Lens-import qualified Data.Aeson as A-import Data.Aeson.Lens-import qualified Data.Text as T-import qualified Data.Vector as V--import Database.Vault.KVv2.Client.Internal-import Database.Vault.KVv2.Client.Types--secret- :: A.Value- -> Either String SecretData-secret =- fromVaultResponse "data" toSecretData- where- toSecretData o@(A.Object _) =- case A.fromJSON o of- A.Success sd -> Right sd- A.Error e -> Left e- toSecretData A.Null = Left "No current secret version"- toSecretData _ = Left "Expected JSON object"--version- :: A.Value- -> Either String SecretVersion-version =- fromVaultResponse "version" toSecretVersion- where- toSecretVersion (A.Number n) = Right (SecretVersion $ toInt n)- toSecretVersion _ = Left "Expected JSON number"--current- :: A.Value- -> Either String SecretVersion-current =- fromVaultResponse "current_version" toSecretVersion- where- toSecretVersion (A.Number n) = Right (SecretVersion $ toInt n)- toSecretVersion _ = Left "Expected JSON number"--metadata- :: A.Value- -> Either String SecretMetadata-metadata =- fromVaultResponse "versions" toSecretMetadata- where- toSecretMetadata o@(A.Object _) =- case A.fromJSON o of- A.Success vs -> Right vs- A.Error e -> Left e- toSecretMetadata _ = error "Expected JSON object"--list- :: A.Value- -> Either String [VaultKey]-list =- fromVaultResponse "keys" toListKeys- where- toListKeys (A.Array a) =- Right (V.foldl lks mempty a)- where- lks ks (A.String t) =- let s = T.unpack t in- (if hasTrailingSlash s- then VaultFolder s- else VaultKey s) : ks- lks p _ = p- toListKeys _ = error "Expected JSON array"--maybeError- :: Either String A.Value- -> Maybe Error-maybeError (Left s) = Just s-maybeError (Right v) =- case v ^? key "data" . key "version" of- Just A.Null -> Nothing- Just _ -> Just "Unexpected JSON type"- Nothing -> Just (jsonErrors v)-
− Database/Vault/KVv2/Client/Requests.hs
@@ -1,120 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Database.Vault.KVv2.Client.Requests (-- configR,- getSecretR,- putSecretR,- deleteSecretR,- destroySecretR,- secretVersionsR,- readSecretMetadataR,- secretsListR-- ) where--import qualified Data.Aeson as A-import Network.HTTP.Client-import Network.HTTP.Simple (setRequestBody,- setRequestBodyJSON,- setRequestHeaders)--import Database.Vault.KVv2.Client.Internal-import Database.Vault.KVv2.Client.Types--configR- :: [String] -- ^ Endpoint- ->VaultConnection- -> Int -- ^ Max versions- -> Bool -- ^ CAS required- -> IO (Either String A.Value)-configR ss VaultConnection{..} mvs casr =- parseRequest (concat ss)- >>= runRequest manager- . setRequestHeaders (vaultHeaders vaultToken)- . setRequestBodyJSON- SecretSettings- { max_versions = mvs- , cas_required = casr- }--getSecretR- :: VaultConnection- -> SecretPath- -> Maybe SecretVersion- -> IO (Either String A.Value)-getSecretR vc@VaultConnection{..} SecretPath{..} msv =- parseRequest- (concat [show vc, "/data/", path, queryString msv])- >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)- where- queryString = maybe "" (\(SecretVersion v) -> "?version=" ++ show v)--putSecretR- :: VaultConnection- -> CheckAndSet- -> SecretPath- -> SecretData- -> IO (Either String A.Value)-putSecretR vc@VaultConnection{..} cas SecretPath{..} sd =- parseRequest- (concat ["POST ", show vc, "/data/", path])- >>= runRequest manager- . setRequestHeaders (vaultHeaders vaultToken)- . setRequestBodyJSON- PutSecretRequestBody- { options = PutSecretOptions { cas = cas }- , put_data = sd- }--deleteSecretR- :: VaultConnection- -> SecretPath- -> IO (Either String A.Value)-deleteSecretR vc@VaultConnection{..} SecretPath{..} =- parseRequest- (concat ["DELETE ", show vc, "/data/", path])- >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)--secretVersionsR- :: [String] -- ^ Endpoint- -> VaultConnection- -> SecretVersions- -> IO (Either String A.Value)-secretVersionsR ss VaultConnection{..} vs =- parseRequest (concat ss) >>=- runRequest manager- . setRequestHeaders (vaultHeaders vaultToken)- . setRequestBody (RequestBodyLBS $ A.encode vs)--destroySecretR- :: VaultConnection- -> SecretPath- -> IO (Either String A.Value)-destroySecretR vc@VaultConnection{..} SecretPath{..} =- parseRequest- (concat ["DELETE ", show vc, "/metadata/", path])- >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)--secretsListR- :: VaultConnection- -> SecretPath- -> IO (Either String A.Value)-secretsListR vc@VaultConnection{..} SecretPath{..} =- if hasTrailingSlash path- then- parseRequest- (concat ["LIST ", show vc, "/metadata/", path])- >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)- else pure (Left "SecretPath must be a folder/")--readSecretMetadataR- :: VaultConnection- -> SecretPath- -> IO (Either String A.Value)-readSecretMetadataR vc@VaultConnection{..} SecretPath{..} =- parseRequest- (concat ["GET ", show vc, "/metadata/", path])- >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)-
− Database/Vault/KVv2/Client/Types.hs
@@ -1,148 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}--module Database.Vault.KVv2.Client.Types where--import Control.Monad (mzero)-import Data.Aeson-#if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.Key as K-import qualified Data.Aeson.KeyMap as KM-#endif-import qualified Data.ByteString as B-import Data.Hashable-import Data.HashMap.Strict-import qualified Data.Text as T-import Data.Text.Read (decimal)-import GHC.Generics-import Network.HTTP.Client (Manager)-import Text.Read (readMaybe)--import Database.Vault.KVv2.Client.Internal--type VaultAddr = String--type VaultToken = String--type Error = String--type KVEnginePath = String--type DisableCertValidation =Bool--data VaultConnection =- VaultConnection- { vaultAddr :: !VaultAddr- , kvEnginePath :: !KVEnginePath- , vaultToken :: !B.ByteString- , manager :: !Manager- }--instance Show VaultConnection where- show (VaultConnection a p _ _) =- removeTrailingSlash a ++ "/v1/"- ++ removeTrailingSlash (removeLeadingSlash p)--newtype SecretVersions =- SecretVersions [SecretVersion]- deriving (Show, Eq)--instance ToJSON SecretVersions where- toJSON (SecretVersions svs) =- object- [ "versions" .= ((\(SecretVersion i) -> i) <$> svs) ]--newtype SecretVersion- = SecretVersion Int- deriving (Show, Eq, Generic, Hashable)--newtype SecretMetadata =- SecretMetadata (HashMap SecretVersion Metadata)- deriving (Show, Eq)--instance FromJSON SecretMetadata where- parseJSON (Object o) =-#if MIN_VERSION_aeson(2,0,0)- pure (SecretMetadata . fromList $ trans <$> toList (KM.toHashMap o))-#else- pure (SecretMetadata . fromList $ trans <$> toList o)-#endif- where- trans p =- case p of- (k,j@(Object _)) -> do-#if MIN_VERSION_aeson(2,0,0)- let d = decimal (K.toText k)-#else- let d = decimal k-#endif- (SecretVersion (fromDecimal d),fromSuccess $ fromJSON j)- _anyOther -> error "Expected JSON Object"- fromDecimal (Right (i,_)) = i- fromDecimal (Left e) = error e- fromSuccess (Success s) = s- fromSuccess (Error e) = error e- parseJSON _ = mzero--data Metadata =- Metadata- { destroyed :: !Bool- , deletion_time :: !T.Text- , created_time :: !T.Text- } deriving (Show, Eq, Generic, ToJSON, FromJSON)--newtype SecretData =- SecretData- (HashMap T.Text T.Text)- deriving (Show, Generic, ToJSON, FromJSON)--data SecretSettings =- SecretSettings- { max_versions :: !Int- , cas_required :: !Bool- } deriving (Show, Generic, ToJSON, FromJSON)--newtype SecretPath =- SecretPath- { path :: String }- deriving (Show, Generic, ToJSON)--data CheckAndSet- = WriteAllowed- | CreateOnly- | CurrentVersion !Int- deriving (Show, Generic, ToJSON)--newtype PutSecretOptions =- PutSecretOptions- { cas :: CheckAndSet }- deriving (Show)--instance ToJSON PutSecretOptions where- toJSON PutSecretOptions { cas = WriteAllowed } = object []- toJSON PutSecretOptions { cas = CreateOnly } = object [ "cas" .= Number 0.0 ]- toJSON PutSecretOptions { cas = CurrentVersion v } =- case readMaybe (show v) of- Just s -> object [ "cas" .= Number s ]- Nothing -> error "Expected type Int"--data PutSecretRequestBody =- PutSecretRequestBody- { options :: !PutSecretOptions- , put_data :: !SecretData- }--instance ToJSON PutSecretRequestBody where- toJSON (PutSecretRequestBody os sd) =- object- [ "options" .= os- , "data" .= sd- ]--data VaultKey- = VaultKey !String- | VaultFolder !String- deriving (Show)-
LICENSE view
@@ -1,4 +1,4 @@-gothic - Copyright (c) 2019, Michel Boucey+gothic - Copyright (c) 2019-2025, Michel Boucey All rights reserved. Redistribution and use in source and binary forms, with or without
ReadMe.md view
@@ -1,9 +1,8 @@- > "Historically, strongrooms were built in the basement of a bank where the ceilings were vaulted, hence the name." Art. "Bank vault", Wikipedia. -### Gothic, a Haskell client for Vault KV Engine v2 +### Gothic, a Haskell client for Vault KV Engine v2  [](https://hackage.haskell.org/package/gothic) This library implements the [HashiCorp Vault KVv2 Engine API](https://www.vaultproject.io/api/secret/kv/kv-v2.html).
gothic.cabal view
@@ -1,5 +1,5 @@ name: gothic-version: 0.1.8.2+version: 0.1.8.3 synopsis: A Haskell Vault KVv2 secret engine client description: A Haskell HashiCorp Vault KVv2 secret engine client library homepage: https://github.com/MichelBoucey/gothic@@ -7,33 +7,41 @@ license-file: LICENSE author: Michel Boucey maintainer: michel.boucey@gmail.com-copyright: (c) 2019-2024 - Michel Boucey+copyright: (c) 2019-2025 - Michel Boucey category: DevOps, Security, Database build-type: Simple cabal-version: >=1.10 extra-source-files: ReadMe.md -Tested-With: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.1+Tested-With:+ GHC ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.8+ || ==9.4.8+ || ==9.6.7+ || ==9.8.4+ || ==9.10.2+ || ==9.12.2 Source-Repository head Type: git Location: https://github.com/MichelBoucey/gothic library+ hs-source-dirs: src/ exposed-modules: Database.Vault.KVv2.Client , Database.Vault.KVv2.Client.Internal , Database.Vault.KVv2.Client.Lens , Database.Vault.KVv2.Client.Requests , Database.Vault.KVv2.Client.Types- other-extensions: OverloadedStrings- build-depends: aeson >= 2.0 && < 2.3 , base >= 4.8.1.0 && < 5 , binary >= 0.8.5.1 && < 0.9 , connection >= 0.2.8 && < 0.4 , exceptions >= 0.10.0 && < 0.11- , hashable >= 1.4.3 && < 1.5+ , hashable >= 1.4.3 && < 1.6 , http-conduit >= 2.3.2 && < 2.4 , http-client >= 0.5.13.1 && < 0.8 , http-client-tls >= 0.3.5.3 && < 0.4@@ -47,7 +55,6 @@ , scientific >= 0.3.6.2 && < 0.4 , unix >= 2.7.2.2 && < 2.9 , vector >= 0.12.0.1 && < 0.14- default-language: Haskell2010 GHC-Options: -Wall
+ src/Database/Vault/KVv2/Client.hs view
@@ -0,0 +1,233 @@+{-# 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 hiding (show)+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 mva kvep mvt dcv = do+ nm <- newTlsManagerWith $+ mkManagerSettings+ TLSSettingsSimple+ { settingDisableCertificateValidation = dcv+ , settingDisableSession = False+ , settingUseServerName = True+ }+ Nothing+ va <- if M.isJust mva+ then return mva+ else lookupEnv "VAULT_ADDR"+ evt <- case mvt of+ Just t -> pure (Right $ encodeUtf8 $ T.pack t)+ Nothing -> do+ hm <- lookupEnv "HOME"+ if M.isJust hm+ then do+ let fp = M.fromJust hm ++ "/.vault-token"+ if M.isJust va+ then do+ fe <- fileExist fp+ if fe+ then Right <$> B.readFile fp+ else pure (Left $ "No Vault token file found at " ++ fp)+ else pure (Left "Variable environment VAULT_ADDR not set")+ else pure (Left "Variable environment HOME not set")+ pure $+ (\vt ->+ VaultConnection+ { vaultAddr = M.fromJust va+ , vaultToken = vt+ , kvEnginePath = kvep+ , manager = nm+ }+ ) <$> evt++-- | Set default secret settings for the KVv2 engine.+kvEngineConfig+ :: VaultConnection+ -> Int -- ^ Max versions+ -> Bool -- ^ CAS required+ -> IO (Either String A.Value)+kvEngineConfig vc@VaultConnection{} =+ configR ["POST ", show vc, "/config"] vc++-- | Override default secret settings for the given secret.+secretConfig+ :: VaultConnection+ -> SecretPath+ -> Int -- ^ Max versions+ -> Bool -- ^ CAS required+ -> IO (Either String A.Value)+secretConfig vc@VaultConnection{} SecretPath{..} =+ configR ["POST ", show vc, "/metadata/", path] 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 vc sp msv =+ (>>= secret) <$> getSecretR vc sp 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 vc cas sp sd =+ (>>= version) <$> putSecretR vc cas sp sd++deleteSecret+ :: VaultConnection+ -> SecretPath+ -> IO (Maybe Error)+deleteSecret vc sp =+ maybeError <$> deleteSecretR vc sp++deleteSecretVersions+ :: VaultConnection+ -> SecretPath+ -> SecretVersions+ -> IO (Maybe Error)+deleteSecretVersions vc@VaultConnection{} SecretPath{..} svs =+ maybeError <$> secretVersionsR ["POST ", show vc, "/delete/", path] vc svs++unDeleteSecretVersions+ :: VaultConnection+ -> SecretPath+ -> SecretVersions+ -> IO (Maybe Error)+unDeleteSecretVersions vc@VaultConnection{} SecretPath{..} svs =+ maybeError <$> secretVersionsR ["POST ", show vc, "/undelete/", path] vc svs++-- | Permanently delete a secret, i.e. all its versions and metadata.+destroySecret+ :: VaultConnection+ -> SecretPath+ -> IO (Maybe Error)+destroySecret vc sp =+ maybeError <$> destroySecretR vc sp++destroySecretVersions+ :: VaultConnection+ -> SecretPath+ -> SecretVersions+ -> IO (Either String A.Value)+destroySecretVersions vc@VaultConnection{} SecretPath{..} =+ secretVersionsR ["POST ", show vc, "/destroy/", path] vc++-- | Get list of secrets and folders at the given location.+secretsList+ :: VaultConnection+ -> SecretPath+ -> IO (Either String [VaultKey])+secretsList vc sp =+ (>>= list) <$> secretsListR vc 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 vc sp =+ (>>= metadata) <$> readSecretMetadataR vc sp++-- | Get version number of the current given secret.+currentSecretVersion+ :: VaultConnection+ -> SecretPath+ -> IO (Either String SecretVersion)+currentSecretVersion vc sp =+ (>>= current) <$> readSecretMetadataR vc sp++-- Utils++toSecretData+ :: [(Text,Text)]+ -> SecretData+toSecretData = SecretData . fromList++fromSecretData+ :: SecretData+ -> [(Text,Text)]+fromSecretData (SecretData sd) = toList sd++toSecretVersions+ :: [Int]+ -> SecretVersions+toSecretVersions is =+ SecretVersions (SecretVersion <$> is)+
+ src/Database/Vault/KVv2/Client/Internal.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.Vault.KVv2.Client.Internal where++import Control.Lens+import Control.Monad.Catch+import qualified Data.Aeson as A+import Data.Aeson.Key (fromText)+import Data.Aeson.Lens+import qualified Data.ByteString as B+import Data.List as L+import Data.List.NonEmpty as N+import qualified Data.Maybe as M+import Data.Scientific+import Data.Text as T hiding (show)+import qualified Data.Vector as V+import Network.HTTP.Client+import Network.HTTP.Types.Header++runRequest+ :: Manager+ -> Request+ -> IO (Either String A.Value)+runRequest m r =+ esv <$> try (httpLbs r m)+ where+ esv t =+ case t of+ Right b ->+ pure (M.fromMaybe A.Null $ A.decode $ responseBody b)+ Left e -> Left $ show (e::SomeException)++fromVaultResponse+ :: T.Text+ -> (A.Value -> Either String a)+ -> A.Value+ -> Either String a+fromVaultResponse k f v =+ case v ^? key "data" . key (fromText k) of+ Just o@(A.Object _) -> f o+ Just n@(A.Number _) -> f n+ Just a@(A.Array _) -> f a+ Just _ -> Left "Unexpected JSON type"+ Nothing -> Left (jsonErrors v)++vaultHeaders+ :: B.ByteString -- ^ Vault token+ -> [(HeaderName, B.ByteString)]+vaultHeaders vt =+ [ ("Content-Type", "application/json; charset=utf-8")+ , ("X-Vault-Token", vt)+ ]++toJSONName :: String -> String+toJSONName "secret_data" = "data"+toJSONName "secret_metadata" = "metadata"+toJSONName "response_data" = "data"+toJSONName s = s++jsonErrors :: A.Value -> String+jsonErrors v =+ case v ^? key "errors" of+ Just ja ->+ case ja of+ A.Array a ->+ if a == mempty+ then "Undetermined error"+ else+ L.intercalate+ ", "+ (toString <$> V.toList a) ++ "."+ _anyOther -> "Expected JSON array"+ Nothing -> expectedJSONField "errors"++toString :: A.Value -> String+toString (A.String s) = T.unpack s+toString _ = fail "Expected JSON String"++expectedJSONField :: String -> String+expectedJSONField = (++) "Expected JSON field not found: "++unexpectedJSONType :: Either String b+unexpectedJSONType = Left "Unexpected JSON type"++toInt :: Scientific -> Int+toInt = M.fromJust . toBoundedInteger++hasTrailingSlash :: String -> Bool+hasTrailingSlash s = N.last (N.fromList s) == '/'++removeTrailingSlash :: String -> String+removeTrailingSlash s =+ if hasTrailingSlash s+ then N.init (N.fromList s)+ else s++hasLeadingSlash :: String -> Bool+-- hasLeadingSlash s = N.head (N.fromList s) == '/'+hasLeadingSlash s = N.head (N.fromList s) == '/'++removeLeadingSlash :: String -> String+removeLeadingSlash s =+ if hasLeadingSlash s+ then N.tail (N.fromList s)+ else s+
+ src/Database/Vault/KVv2/Client/Lens.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.Vault.KVv2.Client.Lens (++ current,+ list,+ metadata,+ maybeError,+ secret,+ version++ ) where++import Control.Lens+import qualified Data.Aeson as A+import Data.Aeson.Lens+import qualified Data.Text as T+import qualified Data.Vector as V++import Database.Vault.KVv2.Client.Internal+import Database.Vault.KVv2.Client.Types++secret+ :: A.Value+ -> Either String SecretData+secret =+ fromVaultResponse "data" toSecretData+ where+ toSecretData o@(A.Object _) =+ case A.fromJSON o of+ A.Success sd -> Right sd+ A.Error e -> Left e+ toSecretData A.Null = Left "No current secret version"+ toSecretData _ = Left "Expected JSON object"++version+ :: A.Value+ -> Either String SecretVersion+version =+ fromVaultResponse "version" toSecretVersion+ where+ toSecretVersion (A.Number n) = Right (SecretVersion $ toInt n)+ toSecretVersion _ = Left "Expected JSON number"++current+ :: A.Value+ -> Either String SecretVersion+current =+ fromVaultResponse "current_version" toSecretVersion+ where+ toSecretVersion (A.Number n) = Right (SecretVersion $ toInt n)+ toSecretVersion _ = Left "Expected JSON number"++metadata+ :: A.Value+ -> Either String SecretMetadata+metadata =+ fromVaultResponse "versions" toSecretMetadata+ where+ toSecretMetadata o@(A.Object _) =+ case A.fromJSON o of+ A.Success vs -> Right vs+ A.Error e -> Left e+ toSecretMetadata _ = error "Expected JSON object"++list+ :: A.Value+ -> Either String [VaultKey]+list =+ fromVaultResponse "keys" toListKeys+ where+ toListKeys (A.Array a) =+ Right (V.foldl lks mempty a)+ where+ lks ks (A.String t) =+ let s = T.unpack t in+ (if hasTrailingSlash s+ then VaultFolder s+ else VaultKey s) : ks+ lks p _ = p+ toListKeys _ = error "Expected JSON array"++maybeError+ :: Either String A.Value+ -> Maybe Error+maybeError (Left s) = Just s+maybeError (Right v) =+ case v ^? key "data" . key "version" of+ Just A.Null -> Nothing+ Just _ -> Just "Unexpected JSON type"+ Nothing -> Just (jsonErrors v)+
+ src/Database/Vault/KVv2/Client/Requests.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Vault.KVv2.Client.Requests (++ configR,+ getSecretR,+ putSecretR,+ deleteSecretR,+ destroySecretR,+ secretVersionsR,+ readSecretMetadataR,+ secretsListR++ ) where++import qualified Data.Aeson as A+import Network.HTTP.Client+import Network.HTTP.Simple (setRequestBody,+ setRequestBodyJSON,+ setRequestHeaders)++import Database.Vault.KVv2.Client.Internal+import Database.Vault.KVv2.Client.Types++configR+ :: [String] -- ^ Endpoint+ ->VaultConnection+ -> Int -- ^ Max versions+ -> Bool -- ^ CAS required+ -> IO (Either String A.Value)+configR ss VaultConnection{..} mvs casr =+ parseRequest (concat ss)+ >>= runRequest manager+ . setRequestHeaders (vaultHeaders vaultToken)+ . setRequestBodyJSON+ SecretSettings+ { max_versions = mvs+ , cas_required = casr+ }++getSecretR+ :: VaultConnection+ -> SecretPath+ -> Maybe SecretVersion+ -> IO (Either String A.Value)+getSecretR vc@VaultConnection{..} SecretPath{..} msv =+ parseRequest+ (concat [show vc, "/data/", path, queryString msv])+ >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)+ where+ queryString = maybe "" (\(SecretVersion v) -> "?version=" ++ show v)++putSecretR+ :: VaultConnection+ -> CheckAndSet+ -> SecretPath+ -> SecretData+ -> IO (Either String A.Value)+putSecretR vc@VaultConnection{..} cas SecretPath{..} sd =+ parseRequest+ (concat ["POST ", show vc, "/data/", path])+ >>= runRequest manager+ . setRequestHeaders (vaultHeaders vaultToken)+ . setRequestBodyJSON+ PutSecretRequestBody+ { options = PutSecretOptions { cas = cas }+ , put_data = sd+ }++deleteSecretR+ :: VaultConnection+ -> SecretPath+ -> IO (Either String A.Value)+deleteSecretR vc@VaultConnection{..} SecretPath{..} =+ parseRequest+ (concat ["DELETE ", show vc, "/data/", path])+ >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)++secretVersionsR+ :: [String] -- ^ Endpoint+ -> VaultConnection+ -> SecretVersions+ -> IO (Either String A.Value)+secretVersionsR ss VaultConnection{..} vs =+ parseRequest (concat ss) >>=+ runRequest manager+ . setRequestHeaders (vaultHeaders vaultToken)+ . setRequestBody (RequestBodyLBS $ A.encode vs)++destroySecretR+ :: VaultConnection+ -> SecretPath+ -> IO (Either String A.Value)+destroySecretR vc@VaultConnection{..} SecretPath{..} =+ parseRequest+ (concat ["DELETE ", show vc, "/metadata/", path])+ >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)++secretsListR+ :: VaultConnection+ -> SecretPath+ -> IO (Either String A.Value)+secretsListR vc@VaultConnection{..} SecretPath{..} =+ if hasTrailingSlash path+ then+ parseRequest+ (concat ["LIST ", show vc, "/metadata/", path])+ >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)+ else pure (Left "SecretPath must be a folder/")++readSecretMetadataR+ :: VaultConnection+ -> SecretPath+ -> IO (Either String A.Value)+readSecretMetadataR vc@VaultConnection{..} SecretPath{..} =+ parseRequest+ (concat ["GET ", show vc, "/metadata/", path])+ >>= runRequest manager . setRequestHeaders (vaultHeaders vaultToken)+
+ src/Database/Vault/KVv2/Client/Types.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Vault.KVv2.Client.Types where++import Control.Monad (mzero)+import Data.Aeson+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+#endif+import qualified Data.ByteString as B+import Data.Hashable+import Data.HashMap.Strict+import qualified Data.Text as T+import Data.Text.Read (decimal)+import GHC.Generics+import Network.HTTP.Client (Manager)+import Text.Read (readMaybe)++import Database.Vault.KVv2.Client.Internal++type VaultAddr = String++type VaultToken = String++type Error = String++type KVEnginePath = String++type DisableCertValidation =Bool++data VaultConnection =+ VaultConnection+ { vaultAddr :: !VaultAddr+ , kvEnginePath :: !KVEnginePath+ , vaultToken :: !B.ByteString+ , manager :: !Manager+ }++instance Show VaultConnection where+ show (VaultConnection a p _ _) =+ removeTrailingSlash a ++ "/v1/"+ ++ removeTrailingSlash (removeLeadingSlash p)++newtype SecretVersions =+ SecretVersions [SecretVersion]+ deriving (Show, Eq)++instance ToJSON SecretVersions where+ toJSON (SecretVersions svs) =+ object+ [ "versions" .= ((\(SecretVersion i) -> i) <$> svs) ]++newtype SecretVersion+ = SecretVersion Int+ deriving (Show, Eq, Generic, Hashable)++newtype SecretMetadata =+ SecretMetadata (HashMap SecretVersion Metadata)+ deriving (Show, Eq)++instance FromJSON SecretMetadata where+ parseJSON (Object o) =+#if MIN_VERSION_aeson(2,0,0)+ pure (SecretMetadata . fromList $ trans <$> toList (KM.toHashMap o))+#else+ pure (SecretMetadata . fromList $ trans <$> toList o)+#endif+ where+ trans p =+ case p of+ (k,j@(Object _)) -> do+#if MIN_VERSION_aeson(2,0,0)+ let d = decimal (K.toText k)+#else+ let d = decimal k+#endif+ (SecretVersion (fromDecimal d),fromSuccess $ fromJSON j)+ _anyOther -> error "Expected JSON Object"+ fromDecimal (Right (i,_)) = i+ fromDecimal (Left e) = error e+ fromSuccess (Success s) = s+ fromSuccess (Error e) = error e+ parseJSON _ = mzero++data Metadata =+ Metadata+ { destroyed :: !Bool+ , deletion_time :: !T.Text+ , created_time :: !T.Text+ } deriving (Show, Eq, Generic, ToJSON, FromJSON)++newtype SecretData =+ SecretData+ (HashMap T.Text T.Text)+ deriving (Show, Generic, ToJSON, FromJSON)++data SecretSettings =+ SecretSettings+ { max_versions :: !Int+ , cas_required :: !Bool+ } deriving (Show, Generic, ToJSON, FromJSON)++newtype SecretPath =+ SecretPath+ { path :: String }+ deriving (Show, Generic, ToJSON)++data CheckAndSet+ = WriteAllowed+ | CreateOnly+ | CurrentVersion !Int+ deriving (Show, Generic, ToJSON)++newtype PutSecretOptions =+ PutSecretOptions+ { cas :: CheckAndSet }+ deriving (Show)++instance ToJSON PutSecretOptions where+ toJSON PutSecretOptions { cas = WriteAllowed } = object []+ toJSON PutSecretOptions { cas = CreateOnly } = object [ "cas" .= Number 0.0 ]+ toJSON PutSecretOptions { cas = CurrentVersion v } =+ case readMaybe (show v) of+ Just s -> object [ "cas" .= Number s ]+ Nothing -> error "Expected type Int"++data PutSecretRequestBody =+ PutSecretRequestBody+ { options :: !PutSecretOptions+ , put_data :: !SecretData+ }++instance ToJSON PutSecretRequestBody where+ toJSON (PutSecretRequestBody os sd) =+ object+ [ "options" .= os+ , "data" .= sd+ ]++data VaultKey+ = VaultKey !String+ | VaultFolder !String+ deriving (Show)+