diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Bit Connor + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# vault-tool + +Client library for HashiCorp's [Vault](https://www.vaultproject.io) tool (via +HTTP API) + +Tested with Vault versions: + + - Vault 0.6.0 + - Vault 0.6.1 + - Vault 0.6.2 + +The tests for this library are in the package +[vault-tool-server](../vault-tool-server/) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Network/VaultTool.hs b/src/Network/VaultTool.hs new file mode 100644 --- /dev/null +++ b/src/Network/VaultTool.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Unless otherwise specified, all IO functions in this module may +-- potentially throw 'HttpException' or 'VaultException' + +module Network.VaultTool + ( VaultAddress(..) + , VaultUnsealKey(..) + , VaultAuthToken(..) + , VaultException(..) + + , VaultHealth(..) + , vaultHealth + + , VaultConnection + , connectToVault + + , vaultInit + , VaultSealStatus(..) + , vaultSealStatus + , vaultSeal + , VaultUnseal(..) + , vaultUnseal + + , VaultMount(..) + , VaultMountRead + , VaultMountWrite + , VaultMountConfig(..) + , VaultMountConfigRead + , VaultMountConfigWrite + , vaultMounts + , vaultMountTune + , vaultMountSetTune + , vaultNewMount + , vaultUnmount + + , VaultSecretPath(..) + , VaultSecretMetadata(..) + , vaultWrite + , vaultRead + , vaultDelete + , vaultList + , isFolder + , vaultListRecursive + ) where + +import Control.Exception (throwIO) +import Control.Monad (liftM) +import Data.Aeson +import Data.Aeson.Types (parseEither) +import Data.List (sortOn) +import Data.Text (Text) +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T + +import Network.VaultTool.Internal +import Network.VaultTool.Types + +data VaultConnection = VaultConnection + { _VaultConnection_AuthToken :: VaultAuthToken + , _VaultConnection_VaultAddress :: VaultAddress + , _VaultConnection_Manager :: Manager + } + +-- | +-- +-- See 'vaultHealth' +data VaultHealth = VaultHealth + { _VaultHealth_Initialized :: Bool + , _VaultHealth_Sealed :: Bool + , _VaultHealth_Standby :: Bool + } + deriving (Show, Eq, Ord) + +instance FromJSON VaultHealth where + parseJSON (Object v) = + VaultHealth <$> + v .: "initialized" <*> + v .: "sealed" <*> + v .: "standby" + parseJSON _ = fail "Not an Object" + +vaultUrl :: VaultAddress -> String -> String +vaultUrl (VaultAddress addr) path = T.unpack addr ++ "/v1" ++ path + +-- | https://www.vaultproject.io/docs/http/sys-health.html +vaultHealth :: VaultAddress -> IO VaultHealth +vaultHealth vaultAddress = do + manager <- newManager tlsManagerSettings + vaultRequestJSON manager "GET" (vaultUrl vaultAddress "/sys/health") [] (Nothing :: Maybe ()) expectedStatusCodes + where + expectedStatusCodes = [200, 429, 500, 501, 503] + +-- | Just initializes the 'VaultConnection' objects, does not actually make any +-- contact with the vault server. (That is also the explanation why there is no +-- function to disconnect) +connectToVault :: VaultAddress -> VaultAuthToken -> IO VaultConnection +connectToVault addr authToken = do + manager <- newManager tlsManagerSettings + pure VaultConnection + { _VaultConnection_AuthToken = authToken + , _VaultConnection_VaultAddress = addr + , _VaultConnection_Manager = manager + } + +-- | +-- +-- See 'vaultInit' +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 -- ^ @secret_shares@: The number of shares to split the master key + -- into + -> Int -- ^ @secret_threshold@: The number of shares required to + -- reconstruct the master key. This must be less than or equal to + -- secret_shares + -> IO ([VaultUnsealKey], VaultAuthToken) -- ^ master keys and initial root token +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) + +-- | +-- +-- See 'vaultSealStatus' +data VaultSealStatus = VaultSealStatus + { _VaultSealStatus_Sealed :: Bool + , _VaultSealStatus_T :: Int -- ^ threshold + , _VaultSealStatus_N :: Int -- ^ number of shares + , _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] + +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] + pure () + where + headers = [("X-Vault-Token", unVaultAuthToken _VaultConnection_AuthToken)] + +-- | +-- +-- See 'vaultUnseal' +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" + +-- | +-- +-- For your convenience, the results are returned sorted (by the mount point) +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] + + -- Vault 0.6.1 has a different format than previous versions. + -- See + -- + -- We do some detection to support both the new and the old format: + 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 = [("X-Vault-Token", unVaultAuthToken _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 = [("X-Vault-Token", unVaultAuthToken _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) [204] + pure () + where + headers = [("X-Vault-Token", unVaultAuthToken _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) [204] + pure () + where + headers = [("X-Vault-Token", unVaultAuthToken _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 ()) [204] + pure () + where + headers = [("X-Vault-Token", unVaultAuthToken _VaultConnection_AuthToken)] + +data VaultSecretMetadata = VaultSecretMetadata + { _VaultSecretMetadata_leaseDuration :: Int + , _VaultSecretMetadata_leaseId :: Text + , _VauleSecretMetadata_renewable :: Bool + } + deriving (Show, Eq {- TODO Ord #-}) + +instance FromJSON VaultSecretMetadata where + parseJSON (Object v) = + VaultSecretMetadata <$> + v .: "lease_duration" <*> + v .: "lease_id" <*> + v .: "renewable" + parseJSON _ = fail "Not an Object" + +-- | +-- +-- The value that you give must encode as a JSON object +vaultWrite :: ToJSON a => VaultConnection -> VaultSecretPath -> a -> IO () +vaultWrite VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} (VaultSecretPath location) value = do + let reqBody = value + _ <- vaultRequest _VaultConnection_Manager "POST" (vaultUrl _VaultConnection_VaultAddress "/" ++ T.unpack location) headers (Just reqBody) [204] + pure () + where + headers = [("X-Vault-Token", unVaultAuthToken _VaultConnection_AuthToken)] + +vaultRead + :: FromJSON a + => VaultConnection + -> VaultSecretPath + -> IO (VaultSecretMetadata, Either (Value, String) a) -- ^ A 'Left' result + -- means that the + -- secret's "data" + -- could not be + -- parsed into the + -- data structure + -- that you + -- requested. + -- + -- You will get the + -- "data" as a raw + -- 'Value' as well as + -- the error message + -- from the parse + -- failure +vaultRead VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} (VaultSecretPath location) = do + let path = vaultUrl _VaultConnection_VaultAddress "/" ++ T.unpack location + 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 = [("X-Vault-Token", unVaultAuthToken _VaultConnection_AuthToken)] + +-- | +vaultDelete :: VaultConnection -> VaultSecretPath -> IO () +vaultDelete VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} (VaultSecretPath location) = do + _ <- vaultRequest _VaultConnection_Manager "DELETE" (vaultUrl _VaultConnection_VaultAddress "/" ++ T.unpack location) headers (Nothing :: Maybe ()) [204] + pure () + where + headers = [("X-Vault-Token", unVaultAuthToken _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" + +-- | +-- +-- This will normalise the results to be full secret paths. +-- +-- Will return only secrets that in the are located in the folder hierarchy +-- directly below the given folder. +-- +-- Use 'isFolder' to check if whether each result is a secret or a subfolder. +-- +-- The order of the results is unspecified. +-- +-- To recursively retrieve all of the secrets use 'vaultListRecursive' +vaultList :: VaultConnection -> VaultSecretPath -> IO [VaultSecretPath] +vaultList VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Manager, _VaultConnection_AuthToken} (VaultSecretPath location) = do + VaultListResult keys <- vaultRequestJSON _VaultConnection_Manager "LIST" (vaultUrl _VaultConnection_VaultAddress "/" ++ T.unpack location) headers (Nothing :: Maybe ()) [200] + pure $ map (VaultSecretPath . (withTrailingSlash `T.append`)) keys + where + headers = [("X-Vault-Token", unVaultAuthToken _VaultConnection_AuthToken)] + withTrailingSlash + | T.null location = "/" + | T.last location == '/' = location + | otherwise = location `T.snoc` '/' + +-- | Does the path end with a '/' character? +-- +-- Meant to be used on the results of 'vaultList' +isFolder :: VaultSecretPath -> Bool +isFolder (VaultSecretPath path) + | T.null path = False + | otherwise = T.last path == '/' + +-- | Recursively calls 'vaultList' to retrieve all of the secrets in a folder +-- (including all subfolders and sub-subfolders, etc...) +-- +-- There will be no folders in the result. +-- +-- The order of the results is unspecified. +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) diff --git a/src/Network/VaultTool/Internal.hs b/src/Network/VaultTool/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/VaultTool/Internal.hs @@ -0,0 +1,38 @@ +module Network.VaultTool.Internal where + +import Control.Exception (throwIO) +import Control.Monad (when) +import Data.Aeson +import Network.HTTP.Client +import Network.HTTP.Types.Header +import Network.HTTP.Types.Method +import Network.HTTP.Types.Status +import qualified Data.ByteString.Lazy as BL + +import Network.VaultTool.Types + +vaultRequest :: ToJSON a => Manager -> Method -> String -> RequestHeaders -> Maybe a -> [Int] -> IO BL.ByteString +vaultRequest manager method_ path_ headers mbBody expectedStatus = do + initReq <- case parseRequest path_ of + Nothing -> throwIO $ VaultException_InvalidAddress method_ path_ + Just initReq -> pure initReq + let reqBody = case mbBody of + Nothing -> BL.empty + Just b -> encode b + req = initReq + { method = method_ + , requestBody = RequestBodyLBS reqBody + , requestHeaders = requestHeaders initReq ++ headers + } + rsp <- httpLbs req manager + let s = statusCode (responseStatus rsp) + when (not (elem s expectedStatus)) $ do + throwIO $ VaultException_BadStatusCode method_ path_ reqBody s (responseBody rsp) + pure (responseBody rsp) + +vaultRequestJSON :: (FromJSON b, ToJSON a) => Manager -> Method -> String -> RequestHeaders -> Maybe a -> [Int] -> IO b +vaultRequestJSON manager method_ path_ headers mbBody expectedStatus = do + rspBody <- vaultRequest manager method_ path_ headers mbBody expectedStatus + case eitherDecode' rspBody of + Left err -> throwIO $ VaultException_ParseBodyError method_ path_ rspBody err + Right x -> pure x diff --git a/src/Network/VaultTool/Types.hs b/src/Network/VaultTool/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/VaultTool/Types.hs @@ -0,0 +1,34 @@ +module Network.VaultTool.Types where + +import Control.Exception (Exception) +import Data.Aeson +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Encoding as T + +newtype VaultAddress = VaultAddress { unVaultAddress :: Text } + deriving (Show, Eq, Ord) + +newtype VaultUnsealKey = VaultUnsealKey { unVaultUnsealKey :: Text } + deriving (Show, Eq, Ord) + +newtype VaultAuthToken = VaultAuthToken { unVaultAuthToken :: ByteString } + deriving (Show, Eq, Ord) + +instance FromJSON VaultAuthToken where + parseJSON j = do + text <- parseJSON j + pure (VaultAuthToken (T.encodeUtf8 text)) + +newtype VaultSecretPath = VaultSecretPath { unVaultSecretPath :: Text } + deriving (Show, Eq, Ord) + +data VaultException + = VaultException + | VaultException_InvalidAddress ByteString String + | VaultException_BadStatusCode ByteString String BL.ByteString Int BL.ByteString + | VaultException_ParseBodyError ByteString String BL.ByteString String + deriving (Show, Eq) + +instance Exception VaultException diff --git a/vault-tool.cabal b/vault-tool.cabal new file mode 100644 --- /dev/null +++ b/vault-tool.cabal @@ -0,0 +1,38 @@ +name: vault-tool +version: 0.0.0.1 +synopsis: Client library for HashiCorp's Vault tool (via HTTP API) +description: Client library for HashiCorp's Vault tool (via HTTP API) +license: MIT +license-file: LICENSE +author: Bit Connor +maintainer: mutantlemon@gmail.com +-- copyright: +category: Network +build-type: Simple +cabal-version: >=1.10 +homepage: https://github.com/bitc/hs-vault-tool +bug-reports: https://github.com/bitc/hs-vault-tool/issues +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/bitc/hs-vault-tool.git + +library + exposed-modules: Network.VaultTool + + other-modules: Network.VaultTool.Internal, + Network.VaultTool.Types + + build-depends: base >=4.8 && <4.10, + text, + bytestring, + http-client, + http-types, + http-client-tls, + aeson, + unordered-containers + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall