diff --git a/vault-tool-server/src/Network/VaultTool/VaultServerProcess.hs b/vault-tool-server/src/Network/VaultTool/VaultServerProcess.hs index c9c48b1..43399d2 100644 --- a/vault-tool-server/src/Network/VaultTool/VaultServerProcess.hs +++ b/vault-tool-server/src/Network/VaultTool/VaultServerProcess.hs @@ -220,7 +220,8 @@ shutdownVaultServerProcess vs = do vaultIsRunning :: VaultAddress -> IO Bool vaultIsRunning addr = do - (vaultHealth addr >> pure True) `catches` + conn <- flip UnauthenticatedVaultConnection addr <$> defaultManager + (vaultHealth conn >> pure True) `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 08d4712..4b1839a 100644 --- a/vault-tool-server/test/test.hs +++ b/vault-tool-server/test/test.hs @@ -47,14 +47,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 @@ -62,7 +66,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 @@ -70,7 +74,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 @@ -78,7 +82,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 @@ -86,7 +90,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 @@ -94,26 +98,26 @@ talkToVault addr = do , _VaultSealStatus_Progress = 0 } - conn <- connectToVault addr rootToken + let authConn = AuthenticatedVaultConnection manager addr rootToken - vaultNewMount conn "secret" VaultMount + 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 conn + 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 @@ -123,57 +127,57 @@ talkToVault addr = do , _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 let pathBig = mkVaultSecretPath "big" - vaultWrite conn pathBig (object ["A" .= 'a', "B" .= 'b']) + vaultWrite authConn pathBig (object ["A" .= 'a', "B" .= 'b']) - r <- vaultRead conn pathBig + r <- vaultRead authConn pathBig vsvData r @?= object ["A" .= 'a', "B" .= 'b'] let pathFun = mkVaultSecretPath "fun" - vaultWrite conn pathFun (FunStuff "fun" [1, 2, 3]) - r2 <- vaultRead conn pathFun + vaultWrite authConn pathFun (FunStuff "fun" [1, 2, 3]) + r2 <- vaultRead authConn pathFun vsvData r2 @?= (FunStuff "fun" [1, 2, 3]) - throws (vaultRead conn pathBig :: IO (VaultSecretVersion FunStuff)) >>= (@?= True) + throws (vaultRead authConn pathBig :: IO (VaultSecretVersion FunStuff)) >>= (@?= True) 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" - vaultWrite conn pathFooBarA (object ["X" .= 'x']) - vaultWrite conn pathFooBarB (object ["X" .= 'x']) - vaultWrite conn pathFooBarABCDEFG (object ["X" .= 'x']) - vaultWrite conn pathFooQuackDuck (object ["X" .= 'x']) + vaultWrite authConn pathFooBarA (object ["X" .= 'x']) + vaultWrite authConn pathFooBarB (object ["X" .= 'x']) + vaultWrite authConn pathFooBarABCDEFG (object ["X" .= 'x']) + vaultWrite authConn pathFooQuackDuck (object ["X" .= 'x']) let emptySecretPath = mkVaultSecretPath "" - keys <- vaultList conn emptySecretPath + keys <- vaultList authConn emptySecretPath assertBool "Secret in list" $ pathBig `elem` keys - vaultDelete conn pathBig + vaultDelete authConn pathBig - keys2 <- vaultList conn emptySecretPath + keys2 <- vaultList authConn emptySecretPath assertBool "Secret not in list" $ not (pathBig `elem` keys2) - keys3 <- vaultListRecursive conn (mkVaultSecretPath "foo") + keys3 <- vaultListRecursive authConn (mkVaultSecretPath "foo") sort keys3 @?= sort [ pathFooBarA , pathFooBarB @@ -181,24 +185,24 @@ talkToVault addr = do , pathFooQuackDuck ] - vaultAuthEnable conn "approle" + vaultAuthEnable authConn "approle" let pathSmall = mkVaultSecretPath "small" - vaultWrite conn pathSmall (object ["X" .= 'x']) + vaultWrite authConn pathSmall (object ["X" .= 'x']) - vaultPolicyCreate conn "foo" "path \"secret/small\" { capabilities = [\"read\"] }" + vaultPolicyCreate authConn "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 + 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 @@ -206,7 +210,7 @@ talkToVault addr = do , _VaultSealStatus_Progress = 0 } - health2 <- vaultHealth addr + health2 <- vaultHealth unauthConn _VaultHealth_Initialized health2 @?= True _VaultHealth_Sealed health2 @?= True diff --git a/vault-tool/src/Network/VaultTool.hs b/vault-tool/src/Network/VaultTool.hs index d8ae448..d093e5a 100644 --- a/vault-tool/src/Network/VaultTool.hs +++ b/vault-tool/src/Network/VaultTool.hs @@ -13,11 +13,11 @@ module Network.VaultTool , VaultAppRoleSecretId(..) , VaultException(..) + , defaultManager + , VaultHealth(..) , vaultHealth - , connectToVault - , connectToVaultAppRole , vaultAuthEnable @@ -52,6 +52,7 @@ module Network.VaultTool , vaultNewMount , vaultUnmount + , VaultConnection (..) , VaultMountedPath(..) , VaultSearchPath(..) , VaultSecretPath(..) @@ -93,30 +94,21 @@ instance FromJSON VaultHealth where v .: "standby" -- | https://www.vaultproject.io/docs/http/sys-health.html -vaultHealth :: VaultAddress -> IO VaultHealth -vaultHealth addr = do - manager <- newManager tlsManagerSettings - runVaultRequest (mkUnauthenticatedVaultConnection addr manager) - . withStatusCodes expectedStatusCodes +vaultHealth :: VaultConnection a -> IO VaultHealth +vaultHealth conn = do + runVaultRequestUnauthenticated conn + . withStatusCodes [200, 429, 501, 503] $ newGetRequest "/sys/health" - 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 $ mkAuthenticatedVaultConnection addr manager authToken +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 -- | -- @@ -135,20 +127,19 @@ instance FromJSON VaultInitResponse where -- | 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 <- runVaultRequest (mkUnauthenticatedVaultConnection addr manager) $ + rsp <- runVaultRequestUnauthenticated conn $ newPutRequest "/sys/init" (Just reqBody) let VaultInitResponse{_VaultInitResponse_Keys, _VaultInitResponse_RootToken} = rsp pure (map VaultUnsealKey _VaultInitResponse_Keys, _VaultInitResponse_RootToken) @@ -172,10 +163,8 @@ instance FromJSON VaultSealStatus where v .: "n" <*> v .: "progress" -vaultSealStatus :: VaultAddress -> IO VaultSealStatus -vaultSealStatus addr = do - manager <- newManager tlsManagerSettings - runVaultRequest (mkUnauthenticatedVaultConnection addr manager) (newGetRequest "/sys/seal-status") +vaultSealStatus :: VaultConnection a -> IO VaultSealStatus +vaultSealStatus conn = runVaultRequestUnauthenticated conn (newGetRequest "/sys/seal-status") -- | -- @@ -222,11 +211,11 @@ instance FromJSON VaultAppRoleResponse where v .: "lease_id" -- | -vaultAppRoleLogin :: VaultAddress -> Manager -> VaultAppRoleId -> VaultAppRoleSecretId -> IO VaultAuthToken -vaultAppRoleLogin addr manager roleId secretId = do +vaultAppRoleLogin :: VaultConnection a -> VaultAppRoleId -> VaultAppRoleSecretId -> IO VaultAuthToken +vaultAppRoleLogin conn roleId secretId = do response <- - runVaultRequest - (mkUnauthenticatedVaultConnection addr manager) + runVaultRequestUnauthenticated + conn (newPostRequest "/auth/approle/login" $ Just reqBody) maybe failOnNullAuth (return . _VaultAuth_ClientToken) $ _VaultAppRoleResponse_Auth response where @@ -237,18 +226,18 @@ vaultAppRoleLogin addr manager roleId secretId = do failOnNullAuth = fail "Auth on login is null" -- | -vaultAuthEnable :: VaultConnection -> Text -> IO () +vaultAuthEnable :: VaultConnection Authenticated-> Text -> IO () vaultAuthEnable conn authMethod = - runVaultRequest_ conn + runVaultRequestAuthenticated_ conn . withStatusCodes [200, 204] $ newPostRequest ("/sys/auth/" <> authMethod) (Just reqBody) where reqBody = object [ "type" .= authMethod ] -- | -vaultPolicyCreate :: VaultConnection -> Text -> Text -> IO () +vaultPolicyCreate :: VaultConnection Authenticated -> Text -> Text -> IO () vaultPolicyCreate conn policyName policy = - runVaultRequest_ conn + runVaultRequestAuthenticated_ conn . withStatusCodes [200, 204] $ newPutRequest ("/sys/policies/acl/" <> policyName) @@ -310,16 +299,16 @@ defaultVaultAppRoleParameters :: VaultAppRoleParameters defaultVaultAppRoleParameters = VaultAppRoleParameters True [] Nothing Nothing Nothing Nothing Nothing Nothing -- | -vaultAppRoleCreate :: VaultConnection -> Text -> VaultAppRoleParameters -> IO () +vaultAppRoleCreate :: VaultConnection Authenticated -> Text -> VaultAppRoleParameters -> IO () vaultAppRoleCreate conn appRoleName varp = - runVaultRequest_ conn + runVaultRequestAuthenticated_ conn . withStatusCodes [200, 204] $ newPostRequest ("/auth/approle/role/" <> appRoleName) (Just varp) -- | -vaultAppRoleRoleIdRead :: VaultConnection -> Text -> IO VaultAppRoleId +vaultAppRoleRoleIdRead :: VaultConnection Authenticated -> Text -> IO VaultAppRoleId vaultAppRoleRoleIdRead conn appRoleName = do - response <- runVaultRequest conn $ newGetRequest ("/auth/approle/role/" <> appRoleName <> "/role-id") + 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/" <> appRoleName <> "/role-id") (encode d) (T.pack err) @@ -337,9 +326,9 @@ instance FromJSON VaultAppRoleSecretIdGenerateResponse where v .: "secret_id" -- | -vaultAppRoleSecretIdGenerate :: VaultConnection -> Text -> Text -> IO VaultAppRoleSecretIdGenerateResponse +vaultAppRoleSecretIdGenerate :: VaultConnection Authenticated -> Text -> Text -> IO VaultAppRoleSecretIdGenerateResponse vaultAppRoleSecretIdGenerate conn appRoleName metadata = do - response <- runVaultRequest conn $ newPostRequest ("/auth/approle/role/" <> appRoleName <> "/secret-id") (Just reqBody) + 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/" <> appRoleName <> "/secret-id") (encode d) (T.pack err) @@ -347,9 +336,9 @@ vaultAppRoleSecretIdGenerate conn appRoleName metadata = do where reqBody = object[ "metadata" .= metadata ] -vaultSeal :: VaultConnection -> IO () +vaultSeal :: VaultConnection Authenticated -> IO () vaultSeal conn = - runVaultRequest_ conn + runVaultRequestAuthenticated_ conn . withStatusCodes [200, 204] $ newPutRequest "/sys/seal" (Nothing :: Maybe ()) @@ -362,8 +351,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 @@ -371,9 +360,7 @@ vaultUnseal addr unseal = do VaultUnseal_Reset -> object [ "reset" .= True ] - manager <- newManager tlsManagerSettings - runVaultRequest (mkUnauthenticatedVaultConnection addr manager) $ - newPutRequest "/sys/unseal" (Just reqBody) + runVaultRequestUnauthenticated conn $ newPutRequest "/sys/unseal" (Just reqBody) type VaultMountRead = VaultMount Text VaultMountConfigRead (Maybe VaultMountConfigOptions) type VaultMountWrite = VaultMount (Maybe Text) (Maybe VaultMountConfigWrite) (Maybe VaultMountConfigOptions) @@ -446,10 +433,10 @@ instance ToJSON VaultMountConfigOptions where -- | -- -- For your convenience, the results are returned sorted (by the mount point) -vaultMounts :: VaultConnection -> IO [(Text, VaultMountRead)] +vaultMounts :: VaultConnection Authenticated -> IO [(Text, VaultMountRead)] vaultMounts conn = do let reqPath = "/sys/mounts" - rspObj <- runVaultRequest conn $ newGetRequest reqPath + rspObj <- runVaultRequestAuthenticated conn $ newGetRequest reqPath -- Vault 0.6.1 has a different format than previous versions. -- See @@ -464,30 +451,30 @@ vaultMounts conn = do Right obj -> pure $ sortOn fst (H.toList obj) -- | -vaultMountTune :: VaultConnection -> Text -> IO VaultMountConfigRead +vaultMountTune :: VaultConnection Authenticated -> Text -> IO VaultMountConfigRead vaultMountTune conn mountPoint = - runVaultRequest conn + runVaultRequestAuthenticated conn . newGetRequest $ "/sys/mounts/" <> mountPoint <> "/tune" -- | -vaultMountSetTune :: VaultConnection -> Text -> VaultMountConfigWrite -> IO () +vaultMountSetTune :: VaultConnection Authenticated -> Text -> VaultMountConfigWrite -> IO () vaultMountSetTune conn mountPoint mountConfig = - runVaultRequest_ conn + runVaultRequestAuthenticated_ conn . withStatusCodes [200, 204] $ newPostRequest ("/sys/mounts/" <> mountPoint <> "/tune") (Just mountConfig) -- | -vaultNewMount :: VaultConnection -> Text -> VaultMountWrite -> IO () +vaultNewMount :: VaultConnection Authenticated -> Text -> VaultMountWrite -> IO () vaultNewMount conn mountPoint vaultMount = - runVaultRequest_ conn + runVaultRequestAuthenticated_ conn . withStatusCodes [200, 204] $ newPostRequest ("/sys/mounts/" <> mountPoint) (Just vaultMount) -- | -vaultUnmount :: VaultConnection -> Text -> IO () +vaultUnmount :: VaultConnection Authenticated -> Text -> IO () vaultUnmount conn mountPoint = - runVaultRequest_ conn + 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 3eae801..7941598 100644 --- a/vault-tool/src/Network/VaultTool/Internal.hs +++ b/vault-tool/src/Network/VaultTool/Internal.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Network.VaultTool.Internal ( VaultRequest, - runVaultRequest, - runVaultRequest_, + runVaultRequestAuthenticated, + runVaultRequestAuthenticated_, + runVaultRequestUnauthenticated, + runVaultRequestUnauthenticated_, newGetRequest, newPostRequest, newPutRequest, @@ -61,12 +64,15 @@ newListRequest path = newRequest "LIST" path Nothing withStatusCodes :: [Int] -> VaultRequest a -> VaultRequest a withStatusCodes statusCodes req = req{vrExpectedStatuses = statusCodes} -authTokenHeader :: VaultConnection -> RequestHeaders -authTokenHeader = maybe mempty mkAuthTokenHeader . vaultAuthToken - where - mkAuthTokenHeader (VaultAuthToken token) = [("X-Vault-Token", T.encodeUtf8 token)] +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 -> VaultRequest a -> IO BL.ByteString +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 @@ -85,12 +91,30 @@ vaultRequest conn VaultRequest{vrMethod, vrPath, vrBody, vrExpectedStatuses} = d where absolutePath = T.unpack $ T.intercalate "/" [unVaultAddress (vaultAddress conn), "v1", vrPath] -runVaultRequest :: (FromJSON b, ToJSON a) => VaultConnection -> VaultRequest a -> IO b + 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 + +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 vrMethod vrPath rspBody (T.pack err) Right x -> pure x -runVaultRequest_ :: (ToJSON a) => VaultConnection -> VaultRequest a -> IO () -runVaultRequest_ conn = void . vaultRequest conn +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 index e5ed7df..ac01705 100644 --- a/vault-tool/src/Network/VaultTool/KeyValueV2.hs +++ b/vault-tool/src/Network/VaultTool/KeyValueV2.hs @@ -39,12 +39,13 @@ import Network.VaultTool.Internal ( newGetRequest, newListRequest, newPostRequest, - runVaultRequest, - runVaultRequest_, + runVaultRequestAuthenticated, + runVaultRequestAuthenticated_, withStatusCodes, ) import Network.VaultTool.Types ( VaultConnection, + Authenticated, VaultMountedPath (..), VaultSearchPath (..), VaultSecretPath (..), @@ -96,19 +97,19 @@ instance FromJSON VaultSecretVersionMetadata where vaultRead :: FromJSON a => - VaultConnection -> + VaultConnection Authenticated -> VaultSecretPath -> IO (VaultSecretVersion a) vaultRead conn path = vaultReadVersion conn path Nothing vaultReadVersion :: FromJSON a => - VaultConnection -> + VaultConnection Authenticated -> VaultSecretPath -> Maybe Int -> IO (VaultSecretVersion a) vaultReadVersion conn (VaultSecretPath (mountedPath, searchPath)) version = - runVaultRequest conn (newGetRequest path) >>= \(DataWrapper x) -> pure x + runVaultRequestAuthenticated conn (newGetRequest path) >>= \(DataWrapper x) -> pure x where path = vaultActionPath ReadSecretVersion mountedPath searchPath <> queryParams queryParams = case version of @@ -127,9 +128,9 @@ instance FromJSON a => FromJSON (DataWrapper a) where The value that you give must encode as a JSON object -} -vaultWrite :: ToJSON a => VaultConnection -> VaultSecretPath -> a -> IO () +vaultWrite :: ToJSON a => VaultConnection Authenticated -> VaultSecretPath -> a -> IO () vaultWrite conn (VaultSecretPath (mountedPath, searchPath)) = do - runVaultRequest_ conn + runVaultRequestAuthenticated_ conn . withStatusCodes [200, 204] . newPostRequest (vaultActionPath WriteSecret mountedPath searchPath) . Just @@ -156,11 +157,11 @@ instance FromJSON VaultListResult where To recursively retrieve all of the secrets use 'vaultListRecursive' -} -vaultList :: VaultConnection -> VaultSecretPath -> IO [VaultSecretPath] +vaultList :: VaultConnection Authenticated -> VaultSecretPath -> IO [VaultSecretPath] vaultList conn (VaultSecretPath (VaultMountedPath mountedPath, VaultSearchPath searchPath)) = do let path = vaultActionPath ListSecrets (VaultMountedPath mountedPath) (VaultSearchPath searchPath) VaultListResult keys <- - runVaultRequest conn $ + runVaultRequestAuthenticated conn $ newListRequest path pure $ map (VaultSecretPath . fullSecretPath) keys where @@ -177,7 +178,7 @@ vaultList conn (VaultSecretPath (VaultMountedPath mountedPath, VaultSearchPath s The order of the results is unspecified. -} -vaultListRecursive :: VaultConnection -> VaultSecretPath -> IO [VaultSecretPath] +vaultListRecursive :: VaultConnection Authenticated -> VaultSecretPath -> IO [VaultSecretPath] vaultListRecursive conn location = do paths <- vaultList conn location flip concatMapM paths $ \path -> do @@ -197,9 +198,9 @@ isFolder (VaultSecretPath (_, VaultSearchPath searchPath)) | otherwise = T.last searchPath == '/' -- | -vaultDelete :: VaultConnection -> VaultSecretPath -> IO () +vaultDelete :: VaultConnection Authenticated -> VaultSecretPath -> IO () vaultDelete conn (VaultSecretPath (mountedPath, searchPath)) = do - runVaultRequest_ conn + runVaultRequestAuthenticated_ conn . withStatusCodes [204] $ newDeleteRequest (vaultActionPath HardDeleteSecret mountedPath searchPath) diff --git a/vault-tool/src/Network/VaultTool/Types.hs b/vault-tool/src/Network/VaultTool/Types.hs index f4b6e08..d5baa62 100644 --- a/vault-tool/src/Network/VaultTool/Types.hs +++ b/vault-tool/src/Network/VaultTool/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Network.VaultTool.Types ( @@ -6,17 +7,14 @@ module Network.VaultTool.Types ( VaultAppRoleSecretId (..), VaultAppRoleSecretIdAccessor (..), VaultAuthToken (..), - VaultConnection, + VaultConnection (..), + Authenticated, + Unauthenticated, VaultException (..), VaultMountedPath (..), VaultSearchPath (..), VaultSecretPath (..), VaultUnsealKey (..), - mkAuthenticatedVaultConnection, - mkUnauthenticatedVaultConnection, - vaultAddress, - vaultAuthToken, - vaultConnectionManager, ) where import Control.Exception (Exception) @@ -26,27 +24,13 @@ import Data.Text (Text) import qualified Data.ByteString.Lazy as BL import Network.HTTP.Client (Manager) -data VaultConnection - = AuthenticatedVaultConnection VaultAddress Manager VaultAuthToken - | UnauthenticatedVaultConnection VaultAddress Manager +data VaultConnection a where + UnauthenticatedVaultConnection :: Manager -> VaultAddress -> VaultConnection Unauthenticated + AuthenticatedVaultConnection :: Manager -> VaultAddress -> VaultAuthToken -> VaultConnection Authenticated -mkAuthenticatedVaultConnection :: VaultAddress -> Manager -> VaultAuthToken -> VaultConnection -mkAuthenticatedVaultConnection = AuthenticatedVaultConnection +data Unauthenticated -mkUnauthenticatedVaultConnection :: VaultAddress -> Manager -> VaultConnection -mkUnauthenticatedVaultConnection = UnauthenticatedVaultConnection - -vaultAddress :: VaultConnection -> VaultAddress -vaultAddress (AuthenticatedVaultConnection addr _ _) = addr -vaultAddress (UnauthenticatedVaultConnection addr _) = addr - -vaultConnectionManager :: VaultConnection -> Manager -vaultConnectionManager (AuthenticatedVaultConnection _ mgr _) = mgr -vaultConnectionManager (UnauthenticatedVaultConnection _ mgr) = mgr - -vaultAuthToken :: VaultConnection -> Maybe VaultAuthToken -vaultAuthToken (AuthenticatedVaultConnection _ _ token) = Just token -vaultAuthToken (UnauthenticatedVaultConnection _ _) = Nothing +data Authenticated newtype VaultAddress = VaultAddress { unVaultAddress :: Text } deriving (Show, Eq, Ord)