diff --git a/stack.yaml b/stack.yaml index de6baeb..dea42a4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-11.19 +resolver: lts-18.10 # User packages to be built. # Various formats can be used as shown in the example below. @@ -63,4 +63,4 @@ packages: # extra-lib-dirs: [/path/to/dir] # # Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file +# compiler-check: newer-minor diff --git a/vault-tool-server/src/Network/VaultTool/VaultServerProcess.hs b/vault-tool-server/src/Network/VaultTool/VaultServerProcess.hs index 5d7d9b0..0646e77 100644 --- a/vault-tool-server/src/Network/VaultTool/VaultServerProcess.hs +++ b/vault-tool-server/src/Network/VaultTool/VaultServerProcess.hs @@ -19,23 +19,43 @@ module Network.VaultTool.VaultServerProcess ) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Async +import Control.Concurrent.Async (waitAnyCancel, withAsync) import Control.Exception (Exception, IOException, catches, Handler(Handler), bracket, bracketOnError, throwIO, try) import Control.Monad (forever) -import Data.Aeson +import Data.Aeson (ToJSON, Value, (.=), eitherDecode', encode, object, toJSON) import Data.Maybe (fromMaybe) import Data.Text (Text) import Network.HTTP.Client (HttpException) import System.Exit (ExitCode) import System.FilePath (()) import System.IO (Handle, hClose) -import System.IO.Temp -import System.Process +import System.IO.Temp (withSystemTempDirectory) +import System.Process ( + ProcessHandle, + StdStream (..), + close_fds, + createProcess, + env, + getProcessExitCode, + proc, + std_err, + std_in, + std_out, + terminateProcess, + waitForProcess, + ) import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.IO as T -import Network.VaultTool +import Network.VaultTool ( + VaultAddress (..), + VaultException, + VaultUnsealKey (..), + unauthenticatedVaultConnection, + vaultHealth, + defaultManager, + ) -- | The ""backend"" section of the Vault server configuration. -- @@ -101,8 +121,7 @@ readVaultBackendConfig file = do -- | File should have one line per key (blank lines are ignored) readVaultUnsealKeys :: FilePath -> IO [VaultUnsealKey] readVaultUnsealKeys file = - T.readFile file >>= - (pure . map VaultUnsealKey . (filter (not . T.null)) . map T.strip . T.lines) + map VaultUnsealKey . filter (not . T.null) . map T.strip . T.lines <$> T.readFile file withVaultConfigFile :: VaultConfig -> (FilePath -> IO a) -> IO a withVaultConfigFile vaultConfig action = do @@ -130,7 +149,7 @@ instance Exception VaultServerLaunchException withVaultServerProcess :: Maybe FilePath -> FilePath -> VaultAddress -> IO a -> IO a withVaultServerProcess mbVaultExe vaultConfigFile addr act = do bracket (launchVaultServerProcess mbVaultExe vaultConfigFile addr) - (shutdownVaultServerProcess) + shutdownVaultServerProcess (const act) launchVaultServerProcess :: Maybe FilePath -> FilePath -> VaultAddress -> IO VaultServerProcess @@ -221,7 +240,8 @@ shutdownVaultServerProcess vs = do vaultIsRunning :: VaultAddress -> IO Bool vaultIsRunning addr = do - (vaultHealth addr >> pure True) `catches` + conn <- flip unauthenticatedVaultConnection addr <$> defaultManager + (True <$ vaultHealth conn) `catches` [ Handler $ \(_ :: HttpException) -> pure False , Handler $ \(_ :: VaultException) -> pure False ] diff --git a/vault-tool-server/test/test.hs b/vault-tool-server/test/test.hs index f7f8f76..ead8379 100644 --- a/vault-tool-server/test/test.hs +++ b/vault-tool-server/test/test.hs @@ -4,15 +4,67 @@ module Main where -import Data.Aeson +import Control.Exception (catch) +import Data.Aeson (FromJSON, ToJSON, (.=), object) +import Data.Functor (($>)) import Data.List (sort) -import GHC.Generics -import System.Environment +import Data.Text (Text) +import GHC.Generics (Generic) +import System.Environment (lookupEnv) import System.IO.Temp (withSystemTempDirectory) -import Test.Tasty.HUnit - -import Network.VaultTool -import Network.VaultTool.VaultServerProcess +import Test.Tasty.HUnit ((@?=), assertBool) + +import Network.VaultTool ( + VaultAddress, + VaultAppRoleParameters (..), + VaultAppRoleSecretIdGenerateResponse (..), + VaultException, + VaultHealth (..), + VaultMount (..), + VaultMountConfig (..), + VaultMountOptions (..), + VaultMountedPath (..), + VaultSealStatus (..), + VaultSearchPath (..), + VaultSecretPath (..), + VaultUnseal (..), + authenticatedVaultConnection, + connectToVaultAppRole, + defaultManager, + defaultVaultAppRoleParameters, + unauthenticatedVaultConnection, + vaultAppRoleCreate, + vaultAppRoleRoleIdRead, + vaultAppRoleSecretIdGenerate, + vaultAuthEnable, + vaultHealth, + vaultInit, + vaultMountSetTune, + vaultMountTune, + vaultMounts, + vaultNewMount, + vaultPolicyCreate, + vaultSeal, + vaultSealStatus, + vaultUnmount, + vaultUnseal, + ) +import Network.VaultTool.KeyValueV2 ( + VaultSecretVersion (..), + vaultDelete, + vaultRead, + vaultReadVersion, + vaultWrite, + vaultList, + vaultListRecursive, + ) +import Network.VaultTool.VaultServerProcess ( + VaultBackendConfig, + vaultAddress, + vaultConfigDefaultAddress, + withVaultConfigFile, + withVaultServerProcess, + ) withTempVaultBackend :: (VaultBackendConfig -> IO a) -> IO a withTempVaultBackend action = withSystemTempDirectory "hs_vault" $ \tmpDir -> do @@ -43,14 +95,18 @@ main = withTempVaultBackend $ \vaultBackendConfig -> do -- instead of this one big-ass test talkToVault :: VaultAddress -> IO () talkToVault addr = do - health <- vaultHealth addr + manager <- defaultManager + + let unauthConn = unauthenticatedVaultConnection manager addr + + health <- vaultHealth unauthConn _VaultHealth_Initialized health @?= False - (unsealKeys, rootToken) <- vaultInit addr 4 2 + (unsealKeys, rootToken) <- vaultInit unauthConn 4 2 length unsealKeys @?= 4 - status0 <- vaultSealStatus addr + status0 <- vaultSealStatus unauthConn status0 @?= VaultSealStatus { _VaultSealStatus_Sealed = True , _VaultSealStatus_T = 2 @@ -58,7 +114,7 @@ talkToVault addr = do , _VaultSealStatus_Progress = 0 } - status1 <- vaultUnseal addr (VaultUnseal_Key (unsealKeys !! 0)) + status1 <- vaultUnseal unauthConn (VaultUnseal_Key (unsealKeys !! 0)) status1 @?= VaultSealStatus { _VaultSealStatus_Sealed = True , _VaultSealStatus_T = 2 @@ -66,7 +122,7 @@ talkToVault addr = do , _VaultSealStatus_Progress = 1 } - status2 <- vaultUnseal addr VaultUnseal_Reset + status2 <- vaultUnseal unauthConn VaultUnseal_Reset status2 @?= VaultSealStatus { _VaultSealStatus_Sealed = True , _VaultSealStatus_T = 2 @@ -74,7 +130,7 @@ talkToVault addr = do , _VaultSealStatus_Progress = 0 } - status3 <- vaultUnseal addr (VaultUnseal_Key (unsealKeys !! 1)) + status3 <- vaultUnseal unauthConn (VaultUnseal_Key (unsealKeys !! 1)) status3 @?= VaultSealStatus { _VaultSealStatus_Sealed = True , _VaultSealStatus_T = 2 @@ -82,7 +138,7 @@ talkToVault addr = do , _VaultSealStatus_Progress = 1 } - status4 <- vaultUnseal addr (VaultUnseal_Key (unsealKeys !! 2)) + status4 <- vaultUnseal unauthConn (VaultUnseal_Key (unsealKeys !! 2)) status4 @?= VaultSealStatus { _VaultSealStatus_Sealed = False , _VaultSealStatus_T = 2 @@ -90,102 +146,119 @@ talkToVault addr = do , _VaultSealStatus_Progress = 0 } - conn <- connectToVault addr rootToken - allMounts <- vaultMounts conn + let authConn = authenticatedVaultConnection manager addr rootToken + + vaultNewMount authConn "secret" VaultMount + { _VaultMount_Type = "kv" + , _VaultMount_Description = Just "key/value secret storage" + , _VaultMount_Config = Nothing + , _VaultMount_Options = Just VaultMountOptions { _VaultMountOptions_Version = Just 2 } + } + + allMounts <- vaultMounts authConn fmap _VaultMount_Type (lookup "cubbyhole/" allMounts) @?= Just "cubbyhole" fmap _VaultMount_Type (lookup "secret/" allMounts) @?= Just "kv" fmap _VaultMount_Type (lookup "sys/" allMounts) @?= Just "system" - _ <- vaultMountTune conn "cubbyhole" - _ <- vaultMountTune conn "secret" - _ <- vaultMountTune conn "sys" + _ <- vaultMountTune authConn "cubbyhole" + _ <- vaultMountTune authConn "secret" + _ <- vaultMountTune authConn "sys" - vaultNewMount conn "mymount" VaultMount + vaultNewMount authConn "mymount" VaultMount { _VaultMount_Type = "generic" , _VaultMount_Description = Just "blah blah blah" , _VaultMount_Config = Just VaultMountConfig { _VaultMountConfig_DefaultLeaseTtl = Just 42 , _VaultMountConfig_MaxLeaseTtl = Nothing } + , _VaultMount_Options = Nothing } - mounts2 <- vaultMounts conn + mounts2 <- vaultMounts authConn fmap _VaultMount_Description (lookup "mymount/" mounts2) @?= Just "blah blah blah" - t <- vaultMountTune conn "mymount" + t <- vaultMountTune authConn "mymount" _VaultMountConfig_DefaultLeaseTtl t @?= 42 - vaultMountSetTune conn "mymount" VaultMountConfig + vaultMountSetTune authConn "mymount" VaultMountConfig { _VaultMountConfig_DefaultLeaseTtl = Just 52 , _VaultMountConfig_MaxLeaseTtl = Nothing } - t2 <- vaultMountTune conn "mymount" + t2 <- vaultMountTune authConn "mymount" _VaultMountConfig_DefaultLeaseTtl t2 @?= 52 - vaultUnmount conn "mymount" + vaultUnmount authConn "mymount" - mounts3 <- vaultMounts conn + mounts3 <- vaultMounts authConn lookup "mymount/" mounts3 @?= Nothing - vaultWrite conn (VaultSecretPath "secret/big") (object ["A" .= 'a', "B" .= 'b']) + let pathBig = mkVaultSecretPath "big" + vaultWrite authConn pathBig (object ["A" .= 'a', "B" .= 'b']) - (_, r) <- vaultRead conn (VaultSecretPath "secret/big") - case r of - Left err -> assertFailure $ "Failed to parse secret/big: " ++ (show err) - Right x -> x @?= object ["A" .= 'a', "B" .= 'b'] + r <- vaultRead authConn pathBig + vsvData r @?= object ["A" .= 'a', "B" .= 'b'] - vaultWrite conn (VaultSecretPath "secret/fun") (FunStuff "fun" [1, 2, 3]) - (_, r2) <- vaultRead conn (VaultSecretPath "secret/fun") - case r2 of - Left err -> assertFailure $ "Failed to parse secret/big: " ++ (show err) - Right x -> x @?= (FunStuff "fun" [1, 2, 3]) + let pathFun = mkVaultSecretPath "fun" + vaultWrite authConn pathFun (FunStuff "fun" [1, 2, 3]) + r2 <- vaultRead authConn pathFun + vsvData r2 @?= (FunStuff "fun" [1, 2, 3]) - (_, r3) <- vaultRead conn (VaultSecretPath "secret/big") - case r3 of - Left (v, _) -> v @?= object ["A" .= 'a', "B" .= 'b'] - Right (x :: FunStuff) -> assertFailure $ "Somehow parsed an impossible value" ++ show x + throws (vaultRead authConn pathBig :: IO (VaultSecretVersion FunStuff)) >>= (@?= True) - vaultWrite conn (VaultSecretPath "secret/foo/bar/a") (object ["X" .= 'x']) - vaultWrite conn (VaultSecretPath "secret/foo/bar/b") (object ["X" .= 'x']) - vaultWrite conn (VaultSecretPath "secret/foo/bar/a/b/c/d/e/f/g") (object ["X" .= 'x']) - vaultWrite conn (VaultSecretPath "secret/foo/quack/duck") (object ["X" .= 'x']) + let pathFooBarA = mkVaultSecretPath "foo/bar/a" + pathFooBarB = mkVaultSecretPath "foo/bar/b" + pathFooBarABCDEFG = mkVaultSecretPath "foo/bar/a/b/c/d/e/f/g" + pathFooQuackDuck = mkVaultSecretPath "foo/quack/duck" - keys <- vaultList conn (VaultSecretPath "secret/") - assertBool "Secret in list" $ VaultSecretPath "secret/big" `elem` keys - vaultDelete conn (VaultSecretPath "secret/big") + vaultWrite authConn pathFooBarA (object ["X" .= 'x']) + vaultWrite authConn pathFooBarB (object ["X" .= 'x']) + vaultWrite authConn pathFooBarABCDEFG (object ["X" .= 'x']) + vaultWrite authConn pathFooQuackDuck (object ["X" .= 'x']) - keys2 <- vaultList conn (VaultSecretPath "secret") - assertBool "Secret not in list" $ not (VaultSecretPath "secret/big" `elem` keys2) + let emptySecretPath = mkVaultSecretPath "" + keys <- vaultList authConn emptySecretPath + assertBool "Secret in list" $ pathBig `elem` keys + vaultDelete authConn pathBig - keys3 <- vaultListRecursive conn (VaultSecretPath "secret/foo/") + keys2 <- vaultList authConn emptySecretPath + assertBool "Secret not in list" $ not (pathBig `elem` keys2) + + keys3 <- vaultListRecursive authConn (mkVaultSecretPath "foo") sort keys3 @?= sort - [ VaultSecretPath "secret/foo/bar/a" - , VaultSecretPath "secret/foo/bar/b" - , VaultSecretPath "secret/foo/bar/a/b/c/d/e/f/g" - , VaultSecretPath "secret/foo/quack/duck" + [ pathFooBarA + , pathFooBarB + , pathFooBarABCDEFG + , pathFooQuackDuck ] - vaultAuthEnable conn "approle" + let pathReadVersionTest = mkVaultSecretPath "read/version/secret" + vaultWrite authConn pathReadVersionTest (FunStuff "x" [1]) + vaultWrite authConn pathReadVersionTest (FunStuff "y" [2, 3]) + v1Resp <- vaultReadVersion authConn pathReadVersionTest (Just 1) + vsvData v1Resp @?= (FunStuff "x" [1]) + v2Resp <- vaultReadVersion authConn pathReadVersionTest Nothing + vsvData v2Resp @?= (FunStuff "y" [2, 3]) + + vaultAuthEnable authConn "approle" + + let pathSmall = mkVaultSecretPath "small" + vaultWrite authConn pathSmall (object ["X" .= 'x']) - vaultWrite conn (VaultSecretPath "secret/small") (object ["X" .= 'x']) + vaultPolicyCreate authConn "foo" "path \"secret/small\" { capabilities = [\"read\"] }" - vaultPolicyCreate conn "foo" "path \"secret/small\" { capabilities = [\"read\"] }" - vaultAppRoleCreate conn "foo-role" defaultVaultAppRoleParameters{_VaultAppRoleParameters_Policies=["foo"]} + vaultAppRoleCreate authConn "foo-role" defaultVaultAppRoleParameters{_VaultAppRoleParameters_Policies = ["foo"]} - roleId <- vaultAppRoleRoleIdRead conn "foo-role" - secretId <- _VaultAppRoleSecretIdGenerateResponse_SecretId <$> vaultAppRoleSecretIdGenerate conn "foo-role" "" + roleId <- vaultAppRoleRoleIdRead authConn "foo-role" + secretId <- _VaultAppRoleSecretIdGenerateResponse_SecretId <$> vaultAppRoleSecretIdGenerate authConn "foo-role" "" - arConn <- connectToVaultAppRole addr roleId secretId - (_, ar1) <- vaultRead conn (VaultSecretPath "secret/small") - case ar1 of - Left (v, _) -> v @?= object ["X" .= 'x'] - Right (x :: FunStuff) -> assertFailure $ "Somehow parsed an impossible value" ++ show x + arConn <- connectToVaultAppRole manager addr roleId secretId + throws (vaultRead arConn pathSmall :: IO (VaultSecretVersion FunStuff)) >>= (@?= True) - vaultSeal conn + vaultSeal authConn - status5 <- vaultSealStatus addr + status5 <- vaultSealStatus unauthConn status5 @?= VaultSealStatus { _VaultSealStatus_Sealed = True , _VaultSealStatus_T = 2 @@ -193,7 +266,7 @@ talkToVault addr = do , _VaultSealStatus_Progress = 0 } - health2 <- vaultHealth addr + health2 <- vaultHealth unauthConn _VaultHealth_Initialized health2 @?= True _VaultHealth_Sealed health2 @?= True @@ -205,3 +278,9 @@ data FunStuff = FunStuff instance FromJSON FunStuff instance ToJSON FunStuff + +mkVaultSecretPath :: Text -> VaultSecretPath +mkVaultSecretPath searchPath = VaultSecretPath (VaultMountedPath "secret", VaultSearchPath searchPath) + +throws :: IO a -> IO Bool +throws io = catch (io $> False) $ \(_e :: VaultException) -> pure True diff --git a/vault-tool-server/vault-tool-server.cabal b/vault-tool-server/vault-tool-server.cabal index c6d437a..63c0a13 100644 --- a/vault-tool-server/vault-tool-server.cabal +++ b/vault-tool-server/vault-tool-server.cabal @@ -41,9 +41,10 @@ test-suite test hs-source-dirs: test main-is: test.hs - build-depends: base >=4.8 && <4.11, + build-depends: base >=4.8 && <5, vault-tool >=0.1.0.1, vault-tool-server, aeson, tasty-hunit, - temporary + temporary, + text diff --git a/vault-tool/src/Network/VaultTool.hs b/vault-tool/src/Network/VaultTool.hs index 41b2078..703398b 100644 --- a/vault-tool/src/Network/VaultTool.hs +++ b/vault-tool/src/Network/VaultTool.hs @@ -13,12 +13,16 @@ module Network.VaultTool , VaultAppRoleSecretId(..) , VaultException(..) + , VaultConnection + , Unauthenticated + , Authenticated + , defaultManager + , authenticatedVaultConnection + , unauthenticatedVaultConnection + , VaultHealth(..) , vaultHealth - , VaultConnection - , connectToVault - , connectToVaultAppRole , vaultAuthEnable @@ -45,6 +49,8 @@ module Network.VaultTool , VaultMountConfig(..) , VaultMountConfigRead , VaultMountConfigWrite + , VaultMountOptions(..) + , VaultMountConfigOptions , vaultMounts , vaultMountTune , vaultMountSetTune @@ -54,64 +60,58 @@ module Network.VaultTool , 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 ( + FromJSON, + ToJSON, + Value (..), + (.:), + (.=), + (.:?), + encode, + object, + toJSON, + parseJSON, + withObject, + ) import Data.Aeson.Types (parseEither, Pair) import Data.List (sortOn) import Data.Text (Text) +import qualified Data.Text as T 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 - } +import Text.Read (readEither) + +import Network.VaultTool.Internal ( + newDeleteRequest, + newGetRequest, + newPostRequest, + newPutRequest, + runVaultRequestAuthenticated, + runVaultRequestAuthenticated_, + runVaultRequestUnauthenticated, + withStatusCodes, + ) +import Network.VaultTool.Types ( + Authenticated, + Unauthenticated, + VaultAddress (..), + VaultAppRoleId (..), + VaultAppRoleSecretId (..), + VaultAppRoleSecretIdAccessor (..), + VaultAuthToken (..), + VaultConnection, + VaultException (..), + VaultMountedPath (..), + VaultSearchPath (..), + VaultSecretPath (..), + VaultUnsealKey (..), + authenticatedVaultConnection, + unauthenticatedVaultConnection, + ) -- | -- @@ -126,49 +126,30 @@ data VaultHealth = VaultHealth deriving (Show, Eq, Ord) instance FromJSON VaultHealth where - parseJSON (Object v) = + parseJSON = withObject "VaultHealth" $ \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 -- | 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, 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 - } +vaultHealth :: VaultConnection a -> IO VaultHealth +vaultHealth conn = do + runVaultRequestUnauthenticated conn + . withStatusCodes [200, 429, 501, 503] + $ newGetRequest "/sys/health" + +defaultManager :: IO Manager +defaultManager = newManager tlsManagerSettings -- | 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 +connectToVaultAppRole :: Manager -> VaultAddress -> VaultAppRoleId -> VaultAppRoleSecretId -> IO (VaultConnection Authenticated) +connectToVaultAppRole manager addr roleId secretId = + authenticatedVaultConnection manager addr <$> + vaultAppRoleLogin (unauthenticatedVaultConnection manager addr) roleId secretId -- | -- @@ -180,28 +161,27 @@ data VaultInitResponse = VaultInitResponse deriving (Show, Eq, Ord) instance FromJSON VaultInitResponse where - parseJSON (Object v) = + parseJSON = withObject "VaultInitResponse" $ \v -> VaultInitResponse <$> v .: "keys" <*> v .: "root_token" - parseJSON _ = fail "Not an Object" -- | vaultInit - :: VaultAddress + :: VaultConnection a -> 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 +vaultInit conn 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] + rsp <- runVaultRequestUnauthenticated conn $ + newPutRequest "/sys/init" (Just reqBody) let VaultInitResponse{_VaultInitResponse_Keys, _VaultInitResponse_RootToken} = rsp pure (map VaultUnsealKey _VaultInitResponse_Keys, _VaultInitResponse_RootToken) @@ -217,18 +197,15 @@ data VaultSealStatus = VaultSealStatus deriving (Show, Eq, Ord) instance FromJSON VaultSealStatus where - parseJSON (Object v) = + parseJSON = withObject "VaultSealStatus" $ \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] +vaultSealStatus :: VaultConnection a -> IO VaultSealStatus +vaultSealStatus conn = runVaultRequestUnauthenticated conn (newGetRequest "/sys/seal-status") -- | -- @@ -242,13 +219,12 @@ data VaultAuth = VaultAuth deriving (Show, Eq, Ord) instance FromJSON VaultAuth where - parseJSON (Object v) = + parseJSON = withObject "VaultAuth" $ \v -> VaultAuth <$> v .: "renewable" <*> v .: "lease_duration" <*> v .: "policies" <*> v .: "client_token" - parseJSON _ = fail "Not an Object" -- | -- @@ -265,7 +241,7 @@ data VaultAppRoleResponse = VaultAppRoleResponse deriving (Show, Eq) instance FromJSON VaultAppRoleResponse where - parseJSON (Object v) = + parseJSON = withObject "VaultAppRoleResponse" $ \v -> VaultAppRoleResponse <$> v .:? "auth" <*> v .: "warnings" <*> @@ -274,15 +250,14 @@ instance FromJSON VaultAppRoleResponse where 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] +vaultAppRoleLogin :: VaultConnection a -> VaultAppRoleId -> VaultAppRoleSecretId -> IO VaultAuthToken +vaultAppRoleLogin conn roleId secretId = do + response <- + runVaultRequestUnauthenticated + conn + (newPostRequest "/auth/approle/login" $ Just reqBody) maybe failOnNullAuth (return . _VaultAuth_ClientToken) $ _VaultAppRoleResponse_Auth response where reqBody = object @@ -292,31 +267,32 @@ vaultAppRoleLogin addr manager roleId secretId = do 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 () +vaultAuthEnable :: VaultConnection Authenticated-> Text -> IO () +vaultAuthEnable conn authMethod = + runVaultRequestAuthenticated_ conn + . withStatusCodes [200, 204] + $ newPostRequest ("/sys/auth/" <> authMethod) (Just reqBody) 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 () +vaultPolicyCreate :: VaultConnection Authenticated -> Text -> Text -> IO () +vaultPolicyCreate conn policyName policy = + runVaultRequestAuthenticated_ conn + . withStatusCodes [200, 204] + $ newPutRequest + ("/sys/policies/acl/" <> policyName) + (Just reqBody) where reqBody = object [ "policy" .= policy ] - headers = [authTokenHeader _VaultConnection_AuthToken] -data VaultAppRoleListResponse = VaultAppRoleListResponse +newtype VaultAppRoleListResponse = VaultAppRoleListResponse { _VaultAppRoleListResponse_AppRoles :: [Text] } instance FromJSON VaultAppRoleListResponse where - parseJSON (Object v) = + parseJSON = withObject "VaultAppRoleListResponse" $ \v -> VaultAppRoleListResponse <$> v .: "keys" - parseJSON _ = fail "Not an Object" -- | -- @@ -349,7 +325,7 @@ instance ToJSON VaultAppRoleParameters where t .=? x = (t .=) <$> x instance FromJSON VaultAppRoleParameters where - parseJSON (Object v) = + parseJSON = withObject "VaultAppRoleParameters" $ \v -> VaultAppRoleParameters <$> v .: "bind_secret_id" <*> v .: "policies" <*> @@ -359,29 +335,25 @@ instance FromJSON VaultAppRoleParameters where 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] +vaultAppRoleCreate :: VaultConnection Authenticated -> Text -> VaultAppRoleParameters -> IO () +vaultAppRoleCreate conn appRoleName varp = + runVaultRequestAuthenticated_ conn + . withStatusCodes [200, 204] + $ newPostRequest ("/auth/approle/role/" <> appRoleName) (Just varp) -- | -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] +vaultAppRoleRoleIdRead :: VaultConnection Authenticated -> Text -> IO VaultAppRoleId +vaultAppRoleRoleIdRead conn appRoleName = do + response <- runVaultRequestAuthenticated conn $ newGetRequest ("/auth/approle/role/" <> appRoleName <> "/role-id") 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 + Left err -> throwIO $ VaultException_ParseBodyError "GET" ("/auth/approle/role/" <> appRoleName <> "/role-id") (encode d) (T.pack err) Right obj -> return obj - where - headers = [authTokenHeader _VaultConnection_AuthToken] data VaultAppRoleSecretIdGenerateResponse = VaultAppRoleSecretIdGenerateResponse { _VaultAppRoleSecretIdGenerateResponse_SecretIdAccessor :: VaultAppRoleSecretIdAccessor @@ -389,30 +361,27 @@ data VaultAppRoleSecretIdGenerateResponse = VaultAppRoleSecretIdGenerateResponse } instance FromJSON VaultAppRoleSecretIdGenerateResponse where - parseJSON (Object v) = + parseJSON = withObject "VaultAppRoleSecretIdGenerateResponse" $ \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] +vaultAppRoleSecretIdGenerate :: VaultConnection Authenticated -> Text -> Text -> IO VaultAppRoleSecretIdGenerateResponse +vaultAppRoleSecretIdGenerate conn appRoleName metadata = do + response <- runVaultRequestAuthenticated conn $ newPostRequest ("/auth/approle/role/" <> appRoleName <> "/secret-id") (Just reqBody) 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 + Left err -> throwIO $ VaultException_ParseBodyError "POST" ("/auth/approle/role/" <> appRoleName <> "/secret-id") (encode d) (T.pack 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] +vaultSeal :: VaultConnection Authenticated -> IO () +vaultSeal conn = + runVaultRequestAuthenticated_ conn + . withStatusCodes [200, 204] + $ newPutRequest "/sys/seal" (Nothing :: Maybe ()) -- | -- @@ -423,8 +392,8 @@ data VaultUnseal deriving (Show, Eq, Ord) -- | -vaultUnseal :: VaultAddress -> VaultUnseal -> IO VaultSealStatus -vaultUnseal addr unseal = do +vaultUnseal :: VaultConnection a -> VaultUnseal -> IO VaultSealStatus +vaultUnseal conn unseal = do let reqBody = case unseal of VaultUnseal_Key (VaultUnsealKey key) -> object [ "key" .= key @@ -432,35 +401,37 @@ vaultUnseal addr unseal = do VaultUnseal_Reset -> object [ "reset" .= True ] - manager <- newManager tlsManagerSettings - vaultRequestJSON manager "PUT" (vaultUrl addr "/sys/unseal") [] (Just reqBody) [200] + runVaultRequestUnauthenticated conn $ newPutRequest "/sys/unseal" (Just reqBody) -type VaultMountRead = VaultMount Text VaultMountConfigRead -type VaultMountWrite = VaultMount (Maybe Text) (Maybe VaultMountConfigWrite) +type VaultMountRead = VaultMount Text VaultMountConfigRead (Maybe VaultMountConfigOptions) +type VaultMountWrite = VaultMount (Maybe Text) (Maybe VaultMountConfigWrite) (Maybe VaultMountConfigOptions) type VaultMountConfigRead = VaultMountConfig Int type VaultMountConfigWrite = VaultMountConfig (Maybe Int) +type VaultMountConfigOptions = VaultMountOptions (Maybe Int) -- | -data VaultMount a b = VaultMount +data VaultMount a b c = VaultMount { _VaultMount_Type :: Text , _VaultMount_Description :: a , _VaultMount_Config :: b + , _VaultMount_Options :: c } deriving (Show, Eq, Ord) instance FromJSON VaultMountRead where - parseJSON (Object v) = + parseJSON = withObject "VaultMountRead" $ \v -> VaultMount <$> v .: "type" <*> v .: "description" <*> - v .: "config" - parseJSON _ = fail "Not an Object" + v .: "config" <*> + v .: "options" instance ToJSON VaultMountWrite where toJSON v = object [ "type" .= _VaultMount_Type v , "description" .= _VaultMount_Description v , "config" .= _VaultMount_Config v + , "options" .= _VaultMount_Options v ] -- | @@ -471,11 +442,10 @@ data VaultMountConfig a = VaultMountConfig deriving (Show, Eq, Ord) instance FromJSON VaultMountConfigRead where - parseJSON (Object v) = + parseJSON = withObject "VaultMountConfigRead" $ \v -> VaultMountConfig <$> v .: "default_lease_ttl" <*> v .: "max_lease_ttl" - parseJSON _ = fail "Not an Object" instance ToJSON VaultMountConfigWrite where toJSON v = object @@ -486,13 +456,28 @@ instance ToJSON VaultMountConfigWrite where formatSeconds :: Int -> String formatSeconds n = show n ++ "s" +newtype VaultMountOptions a = VaultMountOptions + { _VaultMountOptions_Version :: a + } + deriving (Show, Eq, Ord) + +instance FromJSON VaultMountConfigOptions where + parseJSON = withObject "VaultMountConfigOptions" $ \v -> + VaultMountOptions <$> (either fail pure . readEither <$> v .: "version") + +instance ToJSON VaultMountConfigOptions where + toJSON v = + object + [ "version" .= (show <$> _VaultMountOptions_Version v) + ] + -- | -- -- 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] +vaultMounts :: VaultConnection Authenticated -> IO [(Text, VaultMountRead)] +vaultMounts conn = do + let reqPath = "/sys/mounts" + rspObj <- runVaultRequestAuthenticated conn $ newGetRequest reqPath -- Vault 0.6.1 has a different format than previous versions. -- See @@ -503,169 +488,34 @@ vaultMounts VaultConnection{_VaultConnection_VaultAddress, _VaultConnection_Mana Just v -> v case parseEither parseJSON root of - Left err -> throwIO $ VaultException_ParseBodyError "GET" reqPath (encode rspObj) err + Left err -> throwIO $ VaultException_ParseBodyError "GET" reqPath (encode rspObj) (T.pack 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] +vaultMountTune :: VaultConnection Authenticated -> Text -> IO VaultMountConfigRead +vaultMountTune conn mountPoint = + runVaultRequestAuthenticated conn + . newGetRequest + $ "/sys/mounts/" <> mountPoint <> "/tune" -- | -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] +vaultMountSetTune :: VaultConnection Authenticated -> Text -> VaultMountConfigWrite -> IO () +vaultMountSetTune conn mountPoint mountConfig = + runVaultRequestAuthenticated_ conn + . withStatusCodes [200, 204] + $ newPostRequest ("/sys/mounts/" <> mountPoint <> "/tune") (Just mountConfig) -- | -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] +vaultNewMount :: VaultConnection Authenticated -> Text -> VaultMountWrite -> IO () +vaultNewMount conn mountPoint vaultMount = + runVaultRequestAuthenticated_ conn + . withStatusCodes [200, 204] + $ newPostRequest ("/sys/mounts/" <> mountPoint) (Just vaultMount) -- | -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 {- 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 (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) -- ^ 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 (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" - --- | --- --- 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 (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` '/' - - --- | Does the path end with a '/' character? --- --- Meant to be used on the results of 'vaultList' -isFolder :: VaultSecretPath -> Bool -isFolder (VaultSecretPath (_, VaultSearchPath searchPath)) - | T.null searchPath = False - | otherwise = T.last searchPath == '/' - --- | 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) +vaultUnmount :: VaultConnection Authenticated -> Text -> IO () +vaultUnmount conn mountPoint = + runVaultRequestAuthenticated_ conn + . withStatusCodes [200, 204] + . newDeleteRequest + $ "/sys/mounts/" <> mountPoint diff --git a/vault-tool/src/Network/VaultTool/Internal.hs b/vault-tool/src/Network/VaultTool/Internal.hs index 30679d7..e684a5f 100644 --- a/vault-tool/src/Network/VaultTool/Internal.hs +++ b/vault-tool/src/Network/VaultTool/Internal.hs @@ -1,38 +1,137 @@ -module Network.VaultTool.Internal where +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.VaultTool.Internal ( + VaultRequest, + runVaultRequestAuthenticated, + runVaultRequestAuthenticated_, + runVaultRequestUnauthenticated, + runVaultRequestUnauthenticated_, + newGetRequest, + newPostRequest, + newPutRequest, + newDeleteRequest, + newListRequest, + withStatusCodes, +) 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 Control.Monad (unless, void) +import Data.Aeson (FromJSON, ToJSON, eitherDecode', encode) import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Client ( + Manager, + RequestBody (..), + httpLbs, + method, + parseRequest, + requestBody, + requestHeaders, + responseBody, + responseStatus, + ) +import Network.HTTP.Types.Header (RequestHeaders) +import Network.HTTP.Types.Method (Method) +import Network.HTTP.Types.Status (statusCode) + +import Network.VaultTool.Types ( + Authenticated, + Unauthenticated, + VaultAddress (..), + VaultAuthToken (..), + VaultConnection (..), + VaultException (..), + ) + +data VaultRequest a = VaultRequest + { vrMethod :: Method + , vrPath :: Text + , vrBody :: Maybe a + , vrExpectedStatuses :: [Int] + } + +newRequest :: Method -> Text -> Maybe a -> VaultRequest a +newRequest method path mbBody = + VaultRequest + { vrMethod = method + , vrPath = path + , vrBody = mbBody + , vrExpectedStatuses = [200] + } + +newGetRequest :: Text -> VaultRequest () +newGetRequest path = newRequest "GET" path Nothing + +newPostRequest :: Text -> Maybe a -> VaultRequest a +newPostRequest = newRequest "POST" + +newPutRequest :: Text -> Maybe a -> VaultRequest a +newPutRequest = newRequest "PUT" + +newDeleteRequest :: Text -> VaultRequest () +newDeleteRequest path = newRequest "DELETE" path Nothing + +newListRequest :: Text -> VaultRequest () +newListRequest path = newRequest "LIST" path Nothing -import Network.VaultTool.Types +withStatusCodes :: [Int] -> VaultRequest a -> VaultRequest a +withStatusCodes statusCodes req = req{vrExpectedStatuses = statusCodes} -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_ +vaultConnectionManager :: VaultConnection a -> Manager +vaultConnectionManager (UnauthenticatedVaultConnection m _) = m +vaultConnectionManager (AuthenticatedVaultConnection m _ _) = m + +vaultAddress :: VaultConnection a -> VaultAddress +vaultAddress (UnauthenticatedVaultConnection _ a) = a +vaultAddress (AuthenticatedVaultConnection _ a _) = a + +vaultRequest :: ToJSON a => VaultConnection b -> VaultRequest a -> IO BL.ByteString +vaultRequest conn VaultRequest{vrMethod, vrPath, vrBody, vrExpectedStatuses} = do + initReq <- case parseRequest absolutePath of + Nothing -> throwIO $ VaultException_InvalidAddress vrMethod vrPath Just initReq -> pure initReq - let reqBody = case mbBody of - Nothing -> BL.empty - Just b -> encode b + let reqBody = maybe BL.empty encode vrBody req = initReq - { method = method_ + { method = vrMethod , requestBody = RequestBodyLBS reqBody - , requestHeaders = requestHeaders initReq ++ headers + , requestHeaders = requestHeaders initReq ++ authTokenHeader conn } - rsp <- httpLbs req manager + rsp <- httpLbs req (vaultConnectionManager conn) let s = statusCode (responseStatus rsp) - when (not (elem s expectedStatus)) $ do - throwIO $ VaultException_BadStatusCode method_ path_ reqBody s (responseBody rsp) + unless (s `elem` vrExpectedStatuses) $ do + throwIO $ VaultException_BadStatusCode vrMethod vrPath reqBody s (responseBody rsp) pure (responseBody rsp) + where + absolutePath = T.unpack $ T.intercalate "/" [unVaultAddress (vaultAddress conn), "v1", vrPath] + + authTokenHeader :: VaultConnection a -> RequestHeaders + authTokenHeader (UnauthenticatedVaultConnection _ _) = mempty + authTokenHeader (AuthenticatedVaultConnection _ _ (VaultAuthToken token)) = + [("X-Vault-Token", T.encodeUtf8 token)] + +runVaultRequestAuthenticated :: (FromJSON b, ToJSON a) => VaultConnection Authenticated -> VaultRequest a -> IO b +runVaultRequestAuthenticated = runVaultRequest -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 +runVaultRequestUnauthenticated :: (FromJSON b, ToJSON a) => VaultConnection c -> VaultRequest a -> IO b +runVaultRequestUnauthenticated conn = runVaultRequest (asUnathenticated conn) + +runVaultRequest :: (FromJSON b, ToJSON a) => VaultConnection c -> VaultRequest a -> IO b +runVaultRequest conn req@VaultRequest{vrMethod, vrPath} = do + rspBody <- vaultRequest conn req case eitherDecode' rspBody of - Left err -> throwIO $ VaultException_ParseBodyError method_ path_ rspBody err + Left err -> throwIO $ VaultException_ParseBodyError vrMethod vrPath rspBody (T.pack err) Right x -> pure x + +runVaultRequestAuthenticated_ :: (ToJSON a) => VaultConnection Authenticated -> VaultRequest a -> IO () +runVaultRequestAuthenticated_ conn = void . vaultRequest conn + +runVaultRequestUnauthenticated_ :: (ToJSON a) => VaultConnection a -> VaultRequest a -> IO () +runVaultRequestUnauthenticated_ conn = void . vaultRequest (asUnathenticated conn) + +asUnathenticated :: VaultConnection a -> VaultConnection Unauthenticated +asUnathenticated conn@(UnauthenticatedVaultConnection _ _) = conn +asUnathenticated (AuthenticatedVaultConnection m c _) = UnauthenticatedVaultConnection m c diff --git a/vault-tool/src/Network/VaultTool/KeyValueV2.hs b/vault-tool/src/Network/VaultTool/KeyValueV2.hs new file mode 100644 index 0000000..2fcffa9 --- /dev/null +++ b/vault-tool/src/Network/VaultTool/KeyValueV2.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | A library for working with Vault's KeyValue version 2 secrets engine + + Unless otherwise specified, all IO functions in this module may + potentially throw 'HttpException' or 'VaultException' +-} +module Network.VaultTool.KeyValueV2 ( + VaultSecretVersion (..), + VaultSecretVersionMetadata (..), + vaultWrite, + vaultRead, + vaultReadVersion, + vaultDelete, + vaultList, + isFolder, + vaultListRecursive, +) where + +import Control.Applicative (optional) +import Data.Aeson ( + FromJSON, + ToJSON, + object, + parseJSON, + toJSON, + withObject, + (.:), + (.=), + ) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) + +import Network.VaultTool.Internal ( + newDeleteRequest, + newGetRequest, + newListRequest, + newPostRequest, + runVaultRequestAuthenticated, + runVaultRequestAuthenticated_, + withStatusCodes, + ) +import Network.VaultTool.Types ( + VaultConnection, + Authenticated, + VaultMountedPath (..), + VaultSearchPath (..), + VaultSecretPath (..), + ) + +{- | +-} +data VaultSecretVersion a = VaultSecretVersion + { vsvData :: a + , vsvMetadata :: VaultSecretVersionMetadata + } + deriving (Show) + +instance FromJSON a => FromJSON (VaultSecretVersion a) where + parseJSON = withObject "VaultSecretVersion" $ \v -> + VaultSecretVersion + <$> v .: "data" + <*> v .: "metadata" + +{- | +-} +data VaultSecretVersionMetadata = VaultSecretVersionMetadata + { vsvmCreatedTime :: UTCTime + , vsvmDeletionTime :: Maybe UTCTime + , vsvmDestroyed :: Bool + , vsvmVersion :: Int + } + deriving (Show) + +instance FromJSON VaultSecretVersionMetadata where + parseJSON = withObject "VaultSecretVersionMetadata" $ \v -> + VaultSecretVersionMetadata + <$> v .: "created_time" + <*> optional (v .: "deletion_time") + <*> v .: "destroyed" + <*> v .: "version" + +vaultRead :: + FromJSON a => + VaultConnection Authenticated -> + VaultSecretPath -> + IO (VaultSecretVersion a) +vaultRead conn path = vaultReadVersion conn path Nothing + +vaultReadVersion :: + FromJSON a => + VaultConnection Authenticated -> + VaultSecretPath -> + Maybe Int -> + IO (VaultSecretVersion a) +vaultReadVersion conn (VaultSecretPath (mountedPath, searchPath)) version = + runVaultRequestAuthenticated conn (newGetRequest path) >>= \(DataWrapper x) -> pure x + where + path = vaultActionPath ReadSecretVersion mountedPath searchPath <> queryParams + queryParams = case version of + Nothing -> "" + Just n -> "?version=" <> T.pack (show n) + +newtype DataWrapper a = DataWrapper a + +instance ToJSON a => ToJSON (DataWrapper a) where + toJSON (DataWrapper x) = object ["data" .= x] + +instance FromJSON a => FromJSON (DataWrapper a) where + parseJSON = withObject "DataWrapper" $ fmap DataWrapper . (.: "data") + +{- | +-} +vaultWrite :: ToJSON a => VaultConnection Authenticated -> VaultSecretPath -> a -> IO () +vaultWrite conn (VaultSecretPath (mountedPath, searchPath)) = do + runVaultRequestAuthenticated_ conn + . withStatusCodes [200, 204] + . newPostRequest (vaultActionPath WriteSecret mountedPath searchPath) + . Just + . DataWrapper + +newtype VaultListResult = VaultListResult [Text] + +instance FromJSON VaultListResult where + parseJSON = withObject "VaultListResult" $ \v -> do + data_ <- v .: "data" + keys <- data_ .: "keys" + pure (VaultListResult keys) + +{- | + + 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 Authenticated -> VaultSecretPath -> IO [VaultSecretPath] +vaultList conn (VaultSecretPath (VaultMountedPath mountedPath, VaultSearchPath searchPath)) = do + let path = vaultActionPath ListSecrets (VaultMountedPath mountedPath) (VaultSearchPath searchPath) + VaultListResult keys <- + runVaultRequestAuthenticated conn $ + newListRequest path + pure $ map (VaultSecretPath . fullSecretPath) keys + where + fullSecretPath key = (VaultMountedPath mountedPath, VaultSearchPath (withTrailingSlash `T.append` key)) + withTrailingSlash + | T.null searchPath = "" + | T.last searchPath == '/' = searchPath + | otherwise = searchPath `T.snoc` '/' + +{- | 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 Authenticated -> VaultSecretPath -> IO [VaultSecretPath] +vaultListRecursive conn location = do + paths <- vaultList conn location + flip concatMapA paths $ \path -> do + if isFolder path + then vaultListRecursive conn path + else pure [path] + where + concatMapA f = fmap concat . traverse f + +{- | Does the path end with a '/' character? + + Meant to be used on the results of 'vaultList' +-} +isFolder :: VaultSecretPath -> Bool +isFolder (VaultSecretPath (_, VaultSearchPath searchPath)) + | T.null searchPath = False + | otherwise = T.last searchPath == '/' + +-- | +vaultDelete :: VaultConnection Authenticated -> VaultSecretPath -> IO () +vaultDelete conn (VaultSecretPath (mountedPath, searchPath)) = do + runVaultRequestAuthenticated_ conn + . withStatusCodes [204] + $ newDeleteRequest (vaultActionPath HardDeleteSecret mountedPath searchPath) + +data VaultAction + = WriteConfig + | ReadConfig + | ReadSecretVersion + | WriteSecret + | SoftDeleteLatestSecret + | SoftDeleteSecretVersions + | UndeleteSecretVersions + | DestroySecretVersions + | ListSecrets + | ReadSecretMetadata + | WriteSecreteMetadata + | HardDeleteSecret + +vaultActionPath :: VaultAction -> VaultMountedPath -> VaultSearchPath -> Text +vaultActionPath action (VaultMountedPath mountedPath) (VaultSearchPath searchPath) = + T.intercalate "/" [mountedPath, actionPrefix action, searchPath] + where + actionPrefix = \case + WriteConfig -> "config" + ReadConfig -> "config" + ReadSecretVersion -> "data" + WriteSecret -> "data" + SoftDeleteLatestSecret -> "data" + SoftDeleteSecretVersions -> "delete" + UndeleteSecretVersions -> "undelete" + DestroySecretVersions -> "destroy" + ListSecrets -> "metadata" + ReadSecretMetadata -> "metadata" + WriteSecreteMetadata -> "metadata" + HardDeleteSecret -> "metadata" diff --git a/vault-tool/src/Network/VaultTool/Types.hs b/vault-tool/src/Network/VaultTool/Types.hs index 2d34eba..dfdcc49 100644 --- a/vault-tool/src/Network/VaultTool/Types.hs +++ b/vault-tool/src/Network/VaultTool/Types.hs @@ -1,12 +1,49 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -module Network.VaultTool.Types where +module Network.VaultTool.Types ( + VaultAddress (..), + VaultAppRoleId (..), + VaultAppRoleSecretId (..), + VaultAppRoleSecretIdAccessor (..), + VaultAuthToken (..), + VaultConnection (..), + Authenticated, + Unauthenticated, + authenticatedVaultConnection, + unauthenticatedVaultConnection, + VaultException (..), + VaultMountedPath (..), + VaultSearchPath (..), + VaultSecretPath (..), + VaultUnsealKey (..), +) where import Control.Exception (Exception) -import Data.Aeson +import Data.Aeson (FromJSON, ToJSON, (.:), (.=), object, parseJSON, toJSON, withObject) import Data.ByteString (ByteString) import Data.Text (Text) import qualified Data.ByteString.Lazy as BL +import Network.HTTP.Client (Manager) + +-- | The APIs exported by this library expect a 'VaultConnection' which is used to know where a vault server is and how +-- to talk to it. The type parameter is used to distinguish between 'Unauthenticated' and 'Authenticated' requests. When +-- a function takes a polymorphic connection (VaultConnection a), either type of connection can be used. +data VaultConnection a where + UnauthenticatedVaultConnection :: Manager -> VaultAddress -> VaultConnection Unauthenticated + AuthenticatedVaultConnection :: Manager -> VaultAddress -> VaultAuthToken -> VaultConnection Authenticated + +-- | Used as a type argument when constructing a 'VaultConnection'. Designates an unauthenticated connection. +data Unauthenticated + +-- | Used as a type argument when constructing a 'VaultConnection'. Designates an authenticated connection. +data Authenticated + +authenticatedVaultConnection :: Manager -> VaultAddress -> VaultAuthToken -> VaultConnection Authenticated +authenticatedVaultConnection = AuthenticatedVaultConnection + +unauthenticatedVaultConnection :: Manager -> VaultAddress -> VaultConnection Unauthenticated +unauthenticatedVaultConnection = UnauthenticatedVaultConnection newtype VaultAddress = VaultAddress { unVaultAddress :: Text } deriving (Show, Eq, Ord) @@ -35,8 +72,8 @@ 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" + parseJSON = withObject "VaultAppRoleId" $ \v -> + VaultAppRoleId <$> v .: "role_id" instance ToJSON VaultAppRoleId where toJSON v = object [ "role_id" .= unVaultAppRoleId v ] @@ -65,9 +102,9 @@ instance ToJSON VaultAppRoleSecretIdAccessor where data VaultException = VaultException - | VaultException_InvalidAddress ByteString String - | VaultException_BadStatusCode ByteString String BL.ByteString Int BL.ByteString - | VaultException_ParseBodyError ByteString String BL.ByteString String + | VaultException_InvalidAddress ByteString Text + | VaultException_BadStatusCode ByteString Text BL.ByteString Int BL.ByteString + | VaultException_ParseBodyError ByteString Text BL.ByteString Text deriving (Show, Eq) instance Exception VaultException diff --git a/vault-tool/vault-tool.cabal b/vault-tool/vault-tool.cabal index 4032e8d..6ddc113 100644 --- a/vault-tool/vault-tool.cabal +++ b/vault-tool/vault-tool.cabal @@ -19,7 +19,8 @@ source-repository head location: https://github.com/bitc/hs-vault-tool.git library - exposed-modules: Network.VaultTool + exposed-modules: Network.VaultTool, + Network.VaultTool.KeyValueV2 other-modules: Network.VaultTool.Internal, Network.VaultTool.Types @@ -31,7 +32,8 @@ library http-types, http-client-tls, aeson, - unordered-containers + unordered-containers, + time hs-source-dirs: src default-language: Haskell2010