From 08c879f629e7a55b95b9965e2a8584bc5e37808a Mon Sep 17 00:00:00 2001
From: Michael Dunn <michael@bitnomial.com>
Date: Thu, 15 Feb 2018 13:50:15 -0600
Subject: [PATCH] Added AppRole types and functions to allow connecting to
 vault via AppRole credentials.

---
 vault-tool/src/Network/VaultTool.hs       | 63 ++++++++++++++++++++++-
 vault-tool/src/Network/VaultTool/Types.hs |  6 +++
 2 files changed, 68 insertions(+), 1 deletion(-)

diff --git a/vault-tool/src/Network/VaultTool.hs b/vault-tool/src/Network/VaultTool.hs
index 9fbed66..398e1b1 100644
--- a/vault-tool/src/Network/VaultTool.hs
+++ b/vault-tool/src/Network/VaultTool.hs
@@ -9,6 +9,8 @@ module Network.VaultTool
     ( VaultAddress(..)
     , VaultUnsealKey(..)
     , VaultAuthToken(..)
+    , VaultAppRoleId(..)
+    , VaultAppRoleSecretId(..)
     , VaultException(..)
 
     , VaultHealth(..)
@@ -17,6 +19,8 @@ module Network.VaultTool
     , VaultConnection
     , connectToVault
 
+    , connectToVaultAppRole
+
     , vaultInit
     , VaultSealStatus(..)
     , vaultSealStatus
@@ -56,6 +60,7 @@ 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 qualified Data.Text.Encoding as TE
 
 import Network.VaultTool.Internal
 import Network.VaultTool.Types
@@ -111,6 +116,14 @@ connectToVault addr authToken = do
             , _VaultConnection_Manager = manager
             }
 
+-- | Initializes the 'VaultConnection' objects using approle credentials to retrieve an authtoken,
+-- and then calls `connectToVault`
+connectToVaultAppRole :: VaultAddress -> VaultAppRoleId -> VaultAppRoleSecretId -> IO VaultConnection
+connectToVaultAppRole addr roleId secretId = do
+    manager <- newManager tlsManagerSettings
+    authToken <- vaultAppRoleLogin addr manager roleId secretId
+    connectToVault addr authToken
+
 -- | <https://www.vaultproject.io/docs/http/sys-init.html>
 --
 -- See 'vaultInit'
@@ -171,6 +184,55 @@ vaultSealStatus addr = do
     manager <- newManager tlsManagerSettings
     vaultRequestJSON manager "GET" (vaultUrl addr "/sys/seal-status") [] (Nothing :: Maybe ()) [200]
 
+-- | <https://www.vaultproject.io/api/auth/approle/index.html>
+--
+-- See 'sample-response-7'
+data VaultAuth = VaultAuth
+    { _VaultAuth_Renewable :: Bool
+    , _VaultAuth_LeaseDuration :: Int
+    , _VaultAuth_Policies :: [Text]
+    , _VaultAuth_ClientToken :: VaultAuthToken
+    }
+    deriving (Show, Eq, Ord)
+
+instance FromJSON VaultAuth where
+    parseJSON (Object v) =
+        VaultAuth <$>
+            v .: "renewable" <*>
+            v .: "lease_duration" <*>
+            v .: "policies" <*>
+            v .: "client_token"
+    parseJSON _ = fail "Not an Object"
+
+-- | <https://www.vaultproject.io/api/auth/approle/index.html>
+--
+-- See 'sample-response-7'
+data VaultAppRoleAuthResponse = VaultAppRoleAuthResponse
+    { _VaultAppRoleAuthResponse_Auth :: VaultAuth
+    , _VaultAppRoleAuthResponse_LeaseDuration :: Int
+    , _VaultAppRoleAuthResponse_Renewable :: Bool
+    }
+    deriving (Show, Eq, Ord)
+
+instance FromJSON VaultAppRoleAuthResponse where
+    parseJSON (Object v) =
+        VaultAppRoleAuthResponse <$>
+            v .: "auth" <*>
+            v .: "lease_duration" <*>
+            v .: "renewable"
+    parseJSON _ = fail "Not an Object"
+
+-- | <https://www.vaultproject.io/docs/auth/approle.html>
+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]
+    return . _VaultAuth_ClientToken $ _VaultAppRoleAuthResponse_Auth response
+  where
+    reqBody = object
+        [ "role_id" .= TE.decodeUtf8 (unVaultAppRoleId roleId),
+          "secret_id" .= TE.decodeUtf8 (unVaultAppRoleSecretId secretId)
+        ]
+
 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]
@@ -199,7 +261,6 @@ vaultUnseal addr unseal = do
     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
diff --git a/vault-tool/src/Network/VaultTool/Types.hs b/vault-tool/src/Network/VaultTool/Types.hs
index a394e5a..78c61cf 100644
--- a/vault-tool/src/Network/VaultTool/Types.hs
+++ b/vault-tool/src/Network/VaultTool/Types.hs
@@ -24,6 +24,12 @@ instance FromJSON VaultAuthToken where
 newtype VaultSecretPath = VaultSecretPath { unVaultSecretPath :: Text }
     deriving (Show, Eq, Ord)
 
+newtype VaultAppRoleId = VaultAppRoleId { unVaultAppRoleId :: ByteString }
+    deriving (Show, Eq, Ord)
+
+newtype VaultAppRoleSecretId = VaultAppRoleSecretId { unVaultAppRoleSecretId :: ByteString }
+    deriving (Show, Eq, Ord)
+
 data VaultException
     = VaultException
     | VaultException_InvalidAddress ByteString String