Hide VaultConnection data constructors and expose constructor functio…

…ns instead

vault-tool-server/src/Network/VaultTool/VaultServerProcess.hs

@@ -220,7 +220,7 @@ shutdownVaultServerProcess vs = do
 
 vaultIsRunning :: VaultAddress -> IO Bool
 vaultIsRunning addr = do
-    conn <- flip UnauthenticatedVaultConnection addr <$> defaultManager
+    conn <- flip unauthenticatedVaultConnection addr <$> defaultManager
     (vaultHealth conn >> pure True) `catches`
         [ Handler $ \(_ :: HttpException) -> pure False
         , Handler $ \(_ :: VaultException) -> pure False

vault-tool-server/test/test.hs

@@ -16,7 +16,13 @@ import Test.Tasty.HUnit
 
 import Network.VaultTool
 import Network.VaultTool.KeyValueV2
-import Network.VaultTool.VaultServerProcess
+import Network.VaultTool.VaultServerProcess (
+    VaultBackendConfig,
+    vaultAddress,
+    vaultConfigDefaultAddress,
+    withVaultConfigFile,
+    withVaultServerProcess,
+ )
 
 withTempVaultBackend :: (VaultBackendConfig -> IO a) -> IO a
 withTempVaultBackend action = withSystemTempDirectory "hs_vault" $ \tmpDir -> do
@@ -49,7 +55,7 @@ talkToVault :: VaultAddress -> IO ()
 talkToVault addr = do
     manager <- defaultManager
 
-    let unauthConn = UnauthenticatedVaultConnection manager addr
+    let unauthConn = unauthenticatedVaultConnection manager addr
 
     health <- vaultHealth unauthConn
     _VaultHealth_Initialized health @?= False
@@ -98,7 +104,7 @@ talkToVault addr = do
         , _VaultSealStatus_Progress = 0
         }
 
-    let authConn = AuthenticatedVaultConnection manager addr rootToken
+    let authConn = authenticatedVaultConnection manager addr rootToken
 
     vaultNewMount authConn "secret" VaultMount
         { _VaultMount_Type = "kv"

vault-tool/src/Network/VaultTool.hs

@@ -13,7 +13,12 @@ module Network.VaultTool
     , VaultAppRoleSecretId(..)
     , VaultException(..)
 
+    , VaultConnection
+    , Unauthenticated
+    , Authenticated
     , defaultManager
+    , authenticatedVaultConnection
+    , unauthenticatedVaultConnection
 
     , VaultHealth(..)
     , vaultHealth
@@ -52,7 +57,6 @@ module Network.VaultTool
     , vaultNewMount
     , vaultUnmount
 
-    , VaultConnection (..)
     , VaultMountedPath(..)
     , VaultSearchPath(..)
     , VaultSecretPath(..)
@@ -107,8 +111,8 @@ defaultManager = newManager tlsManagerSettings
 -- and then calls `connectToVault`
 connectToVaultAppRole :: Manager -> VaultAddress -> VaultAppRoleId -> VaultAppRoleSecretId -> IO (VaultConnection Authenticated)
 connectToVaultAppRole manager addr roleId secretId =
-    AuthenticatedVaultConnection manager addr <$>
-        vaultAppRoleLogin (UnauthenticatedVaultConnection manager addr) roleId secretId
+    authenticatedVaultConnection manager addr <$>
+        vaultAppRoleLogin (unauthenticatedVaultConnection manager addr) roleId secretId
 
 -- | <https://www.vaultproject.io/docs/http/sys-init.html>
 --

vault-tool/src/Network/VaultTool/Internal.hs

@@ -24,7 +24,6 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Network.HTTP.Client
-import Network.HTTP.Types.Header
 import Network.HTTP.Types.Method
 import Network.HTTP.Types.Status
 
@@ -64,57 +63,48 @@ newListRequest path = newRequest "LIST" path Nothing
 withStatusCodes :: [Int] -> VaultRequest a -> VaultRequest a
 withStatusCodes statusCodes req = req{vrExpectedStatuses = statusCodes}
 
-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
+vaultRequest :: ToJSON a => Manager -> VaultAddress -> Maybe VaultAuthToken -> VaultRequest a -> IO BL.ByteString
+vaultRequest manager addr mbToken VaultRequest{vrMethod, vrPath, vrBody, vrExpectedStatuses} = do
     initReq <- case parseRequest absolutePath of
         Nothing -> throwIO $ VaultException_InvalidAddress vrMethod vrPath
         Just initReq -> pure initReq
     let reqBody = maybe BL.empty encode vrBody
         req = initReq
             { method = vrMethod
             , requestBody = RequestBodyLBS reqBody
-            , requestHeaders = requestHeaders initReq ++ authTokenHeader conn
+            , requestHeaders = requestHeaders initReq ++ authTokenHeader mbToken
             }
-    rsp <- httpLbs req (vaultConnectionManager conn)
+    rsp <- httpLbs req manager
     let s = statusCode (responseStatus 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]
+    absolutePath = T.unpack $ T.intercalate "/" [unVaultAddress addr, "v1", vrPath]
 
-    authTokenHeader :: VaultConnection a -> RequestHeaders
-    authTokenHeader (UnauthenticatedVaultConnection _ _) = mempty
-    authTokenHeader (AuthenticatedVaultConnection _ _ (VaultAuthToken token)) =
-        [("X-Vault-Token", T.encodeUtf8 token)]
+    authTokenHeader = maybe mempty toHeader
+      where
+        toHeader (VaultAuthToken token) = [("X-Vault-Token", T.encodeUtf8 token)]
 
 runVaultRequestAuthenticated :: (FromJSON b, ToJSON a) => VaultConnection Authenticated -> VaultRequest a -> IO b
-runVaultRequestAuthenticated = runVaultRequest
+runVaultRequestAuthenticated conn req =
+    runAuthenticatedVaultConnection (\m a t -> runVaultRequest m a (Just t) req) conn
 
 runVaultRequestUnauthenticated :: (FromJSON b, ToJSON a) => VaultConnection c -> VaultRequest a -> IO b
-runVaultRequestUnauthenticated conn = runVaultRequest (asUnathenticated conn)
+runVaultRequestUnauthenticated conn req =
+    runAnyVaultConnection (\m a -> runVaultRequest m a Nothing req) conn
 
-runVaultRequest :: (FromJSON b, ToJSON a) => VaultConnection c -> VaultRequest a -> IO b
-runVaultRequest conn req@VaultRequest{vrMethod, vrPath} = do
-    rspBody <- vaultRequest conn req
+runVaultRequest :: (FromJSON b, ToJSON a) => Manager -> VaultAddress -> Maybe VaultAuthToken -> VaultRequest a -> IO b
+runVaultRequest manager addr mbToken req@VaultRequest{vrMethod, vrPath} = do
+    rspBody <- vaultRequest manager addr mbToken req
     case eitherDecode' rspBody of
         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
+runVaultRequestAuthenticated_ conn req =
+    void $ runAuthenticatedVaultConnection (\m a t -> vaultRequest m a (Just t) req) 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
+runVaultRequestUnauthenticated_ conn req =
+    void $ runAnyVaultConnection (\m a -> vaultRequest m a Nothing req) conn

vault-tool/src/Network/VaultTool/Types.hs

@@ -7,9 +7,13 @@ module Network.VaultTool.Types (
     VaultAppRoleSecretId (..),
     VaultAppRoleSecretIdAccessor (..),
     VaultAuthToken (..),
-    VaultConnection (..),
+    VaultConnection,
     Authenticated,
     Unauthenticated,
+    authenticatedVaultConnection,
+    unauthenticatedVaultConnection,
+    runAnyVaultConnection,
+    runAuthenticatedVaultConnection,
     VaultException (..),
     VaultMountedPath (..),
     VaultSearchPath (..),
@@ -24,14 +28,32 @@ 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
+
+runAnyVaultConnection :: (Manager -> VaultAddress -> b) -> VaultConnection a -> b
+runAnyVaultConnection f (UnauthenticatedVaultConnection manager addr) = f manager addr
+runAnyVaultConnection f (AuthenticatedVaultConnection manager addr _) = f manager addr
+
+runAuthenticatedVaultConnection :: (Manager -> VaultAddress -> VaultAuthToken -> a) -> VaultConnection Authenticated -> a
+runAuthenticatedVaultConnection f (AuthenticatedVaultConnection manager addr token) = f manager addr token
+
 newtype VaultAddress = VaultAddress { unVaultAddress :: Text }
     deriving (Show, Eq, Ord)