From d4db915925f2445cf991a7558a76f03eb9a366e3 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Tue, 11 Feb 2020 16:11:07 +0100
Subject: [PATCH 01/18] Checkpoint: De-ExceptT requestMountInfo

---
 app/Main.hs  | 69 +++++++++++++++++++++++++++++-----------------------
 package.yaml |  2 +-
 2 files changed, 40 insertions(+), 31 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index e4ae42f..95a7100 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 import Control.Applicative    ((<|>))
+import Control.Exception      (Exception, throw)
 import Control.Monad          (forM)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Aeson             (FromJSON, (.:))
@@ -171,6 +172,9 @@ data VaultError
   | InvalidUrl String
   | DuplicateVar String
   | Unspecified Int LBS.ByteString
+  deriving Show
+
+instance Exception VaultError
 
 -- | Retry configuration to use for network requests to Vault.
 -- We use a limited exponential backoff with the policy
@@ -208,9 +212,11 @@ main = do
                         , cHttpManager = httpManager
                         }
 
-  runExceptT (vaultEnv context) >>= \case
-    Left err -> Exit.die (vaultErrorLogMessage err)
-    Right newEnv -> runCommand cliAndEnvAndEnvFileOptions newEnv
+  envVars <- vaultEnv context
+  print envVars
+  --case envVars of
+    --Left err -> Exit.die (vaultErrorLogMessage err)
+    --Right newEnv -> runCommand cliAndEnvAndEnvFileOptions newEnv
 
 
 -- | This function returns either a manager for plain HTTP or
@@ -237,9 +243,11 @@ getHttpManager opts = newManager managerSettings
 --
 -- Signals failure through a value of type VaultError, but can also
 -- throw HTTP exceptions.
-vaultEnv :: Context -> ExceptT VaultError IO [EnvVar]
+vaultEnv :: Context -> IO [EnvVar]
 vaultEnv context = do
   mountInfo <- requestMountInfo context
+  return []
+  {-
   secrets <- mapExceptT (fmap $ first SecretFileError) $ readSecretList secretFile
   secretEnv <- requestSecrets context mountInfo secrets
   checkNoDuplicates (buildEnv secretEnv)
@@ -271,6 +279,7 @@ vaultEnv context = do
         where
           inheritEnvBlacklist = getOptionsValue oInheritEnvBlacklist . cCliOptions $ context
           removeBlacklistedVars = filter (not . flip elem inheritEnvBlacklist . fst)
+          -}
 
 
 runCommand :: Options Validated Completed -> [EnvVar] -> IO a
@@ -286,7 +295,7 @@ runCommand options env =
     executeFile command searchPath args env'
 
 -- | Look up what mounts are available and what type they have.
-requestMountInfo :: Context -> ExceptT VaultError IO MountInfo
+requestMountInfo :: Context -> IO MountInfo
 requestMountInfo context =
   let
     cliOptions = cCliOptions context
@@ -305,8 +314,10 @@ requestMountInfo context =
               (getOptionsValue  oConnectTls cliOptions)
         $ defaultRequest
   in do
-    resp <- withExceptT ServerUnreachable (httpLBS request)
-    withExceptT BadJSONResp (liftEither $ Aeson.eitherDecode' (getResponseBody resp))
+    resp <- httpLBS request
+    case Aeson.eitherDecode' (getResponseBody resp) of
+      Left error -> throw $ BadJSONResp error
+      Right result -> return result
 
 -- | Request all the data associated with a secret from the vault.
 requestSecret :: Context -> String -> ExceptT VaultError IO VaultData
@@ -323,34 +334,32 @@ requestSecret context secretPath =
         $ setRequestSecure  (getOptionsValue oConnectTls cliOptions)
         $ defaultRequest
 
-    -- Only retry on connection related failures
-    shouldRetry :: Applicative f => Retry.RetryStatus -> VaultError -> f Bool
-    --shouldRetry _retryStatus _ =I--
-    shouldRetry _retryStatus res = pure $ case res of
-      ServerError _ -> True
-      ServerUnavailable _ -> True
-      ServerUnreachable _ -> True
-      Unspecified _ _ -> True
-      BadJSONResp _ -> True
-
-      -- Errors where we don't retry
-      BadRequest _ -> False
-      Forbidden -> False
-      InvalidUrl _ -> False
-      SecretNotFound _ -> False
-
-
-      -- Errors that cannot occur at this point, but we list for
-      -- exhaustiveness checking.
-      KeyNotFound _ -> False
-      DuplicateVar _ -> False
-      SecretFileError _ -> False
-
     retryAction :: Retry.RetryStatus -> ExceptT VaultError IO VaultData
     retryAction _retryStatus = doRequest secretPath request
   in
     retryingExceptT (vaultRetryPolicy cliOptions) shouldRetry retryAction
 
+-- | Determine whether to retry
+shouldRetry :: Applicative f => Retry.RetryStatus -> VaultError -> f Bool
+shouldRetry _retryStatus res = pure $ case res of
+  ServerError _ -> True
+  ServerUnavailable _ -> True
+  ServerUnreachable _ -> True
+  Unspecified _ _ -> True
+  BadJSONResp _ -> True
+
+  -- Errors where we don't retry
+  BadRequest _ -> False
+  Forbidden -> False
+  InvalidUrl _ -> False
+  SecretNotFound _ -> False
+
+  -- Errors that cannot occur at this point, but we list for
+  -- exhaustiveness checking.
+  KeyNotFound _ -> False
+  DuplicateVar _ -> False
+  SecretFileError _ -> False
+
 -- |
 -- Like 'Retry.retrying', but using 'ExceptT' instead of return values. The
 -- predicate also only gets the error, not the return value.
diff --git a/package.yaml b/package.yaml
index 04e16fa..ae95993 100644
--- a/package.yaml
+++ b/package.yaml
@@ -28,7 +28,7 @@ dependencies:
   - utf8-string
   - optparse-applicative
 
-ghc-options: -Wall -Werror
+# ghc-options: -Wall -Werror
 
 library:
   source-dirs: src

From fd58aaec90f1101fb7deaa4e1938eae0e09ae8e9 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Tue, 11 Feb 2020 16:46:20 +0100
Subject: [PATCH 02/18] Remove remaining uses of ExceptT

---
 app/Main.hs        | 51 +++++++++++++++++++++-------------------------
 src/SecretsFile.hs |  4 +++-
 2 files changed, 26 insertions(+), 29 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 95a7100..d2fc2f2 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -39,7 +39,7 @@ import qualified System.Exit                as Exit
 import Config (Options(..), parseOptions, unMilliSeconds,
                LogLevel(..), readConfigFromEnvFiles, getOptionsValue,
                Validated, Completed)
-import SecretsFile (Secret(..), SFError(..), readSecretList)
+import SecretsFile (Secret(..), SFError(..), readSecretList, readSecretsFile)
 
 -- | Make a HTTP URL path from a secret. This is the path that Vault expects.
 secretRequestPath :: MountInfo -> Secret -> String
@@ -213,10 +213,9 @@ main = do
                         }
 
   envVars <- vaultEnv context
-  print envVars
-  --case envVars of
-    --Left err -> Exit.die (vaultErrorLogMessage err)
-    --Right newEnv -> runCommand cliAndEnvAndEnvFileOptions newEnv
+  case envVars of
+    Left err -> Exit.die (vaultErrorLogMessage err)
+    Right newEnv -> runCommand cliAndEnvAndEnvFileOptions newEnv
 
 
 -- | This function returns either a manager for plain HTTP or
@@ -243,17 +242,20 @@ getHttpManager opts = newManager managerSettings
 --
 -- Signals failure through a value of type VaultError, but can also
 -- throw HTTP exceptions.
-vaultEnv :: Context -> IO [EnvVar]
+vaultEnv :: Context -> IO (Either VaultError [EnvVar])
 vaultEnv context = do
   mountInfo <- requestMountInfo context
-  return []
-  {-
-  secrets <- mapExceptT (fmap $ first SecretFileError) $ readSecretList secretFile
-  secretEnv <- requestSecrets context mountInfo secrets
-  checkNoDuplicates (buildEnv secretEnv)
+  secrets <- readSecretsFile secretFile
+  case secrets of
+    Left error -> throw error
+    Right secrets' -> do
+      secretEnv <- requestSecrets context mountInfo secrets'
+      case secretEnv of
+        Left error -> throw error
+        Right secretEnv' -> return $ checkNoDuplicates (buildEnv secretEnv')
     where
       secretFile = getOptionsValue oSecretFile (cCliOptions context)
-      checkNoDuplicates :: MonadError VaultError m => [EnvVar] -> m [EnvVar]
+      checkNoDuplicates :: [EnvVar] -> Either VaultError [EnvVar]
       checkNoDuplicates e =
         either (throwError . DuplicateVar) (return . const e) $ dups (map fst e)
 
@@ -279,7 +281,6 @@ vaultEnv context = do
         where
           inheritEnvBlacklist = getOptionsValue oInheritEnvBlacklist . cCliOptions $ context
           removeBlacklistedVars = filter (not . flip elem inheritEnvBlacklist . fst)
-          -}
 
 
 runCommand :: Options Validated Completed -> [EnvVar] -> IO a
@@ -320,7 +321,7 @@ requestMountInfo context =
       Right result -> return result
 
 -- | Request all the data associated with a secret from the vault.
-requestSecret :: Context -> String -> ExceptT VaultError IO VaultData
+requestSecret :: Context -> String -> IO (Either VaultError VaultData)
 requestSecret context secretPath =
   let
     cliOptions = cCliOptions context
@@ -334,10 +335,8 @@ requestSecret context secretPath =
         $ setRequestSecure  (getOptionsValue oConnectTls cliOptions)
         $ defaultRequest
 
-    retryAction :: Retry.RetryStatus -> ExceptT VaultError IO VaultData
-    retryAction _retryStatus = doRequest secretPath request
   in
-    retryingExceptT (vaultRetryPolicy cliOptions) shouldRetry retryAction
+    doRequest secretPath request
 
 -- | Determine whether to retry
 shouldRetry :: Applicative f => Retry.RetryStatus -> VaultError -> f Bool
@@ -379,11 +378,11 @@ retryingExceptT policy predicate action =
 -- | Request all the supplied secrets from the vault, but just once, even if
 -- multiple keys are specified for a single secret. This is an optimization in
 -- order to avoid unnecessary round trips and DNS requets.
-requestSecrets :: Context -> MountInfo -> [Secret] -> ExceptT VaultError IO [EnvVar]
+requestSecrets :: Context -> MountInfo -> [Secret] -> IO (Either VaultError [EnvVar])
 requestSecrets context mountInfo secrets = do
   let secretPaths = Foldable.foldMap (\x -> Map.singleton x x) $ fmap (secretRequestPath mountInfo) secrets
-  secretData <- liftIO (Async.mapConcurrently (runExceptT . (requestSecret context)) secretPaths)
-  either throwError return $ sequence secretData >>= lookupSecrets mountInfo secrets
+  secretData <- liftIO (Async.mapConcurrently (requestSecret context) secretPaths)
+  return $ sequence secretData >>= lookupSecrets mountInfo secrets
 
 -- | Look for the requested keys in the secret data that has been previously fetched.
 lookupSecrets :: MountInfo -> [Secret] -> Map.Map String VaultData -> Either VaultError [EnvVar]
@@ -394,20 +393,16 @@ lookupSecrets mountInfo secrets vaultData = forM secrets $ \secret ->
   in maybe (Left $ KeyNotFound secret) (Right . toEnvVar) $ secretValue
 
 -- | Send a request for secrets to the vault and parse the response.
-doRequest :: String -> Request -> ExceptT VaultError IO VaultData
+doRequest :: String -> Request -> IO (Either VaultError VaultData)
 doRequest secretPath request = do
-  resp <- withExceptT exToErr (httpLBS request)
-  parseResponse secretPath resp
-  where
-    exToErr :: HttpException -> VaultError
-    exToErr e@(HttpExceptionRequest _ _) = ServerUnreachable e
-    exToErr (InvalidUrlException _ _) = InvalidUrl secretPath
+  resp <- httpLBS request
+  return $ parseResponse secretPath resp
 
 --
 -- HTTP response handling
 --
 
-parseResponse :: (Monad m) => String -> Response LBS.ByteString -> ExceptT VaultError m VaultData
+parseResponse :: String -> Response LBS.ByteString -> Either VaultError VaultData
 parseResponse secretPath response =
   let
     responseBody = getResponseBody response
diff --git a/src/SecretsFile.hs b/src/SecretsFile.hs
index a47c9ab..ac276af 100644
--- a/src/SecretsFile.hs
+++ b/src/SecretsFile.hs
@@ -22,7 +22,7 @@ If you are user, please see the README for more information.
 module SecretsFile where
 
 import Control.Applicative.Combinators (some, option, optional)
-import Control.Exception (try, displayException)
+import Control.Exception (Exception, try, displayException)
 import Control.Monad.Except (MonadError, MonadIO, liftEither, liftIO)
 import Data.Char (toUpper, isSpace, isControl)
 import Data.Functor (void)
@@ -57,6 +57,8 @@ instance Show SFError where
     IOErr ioErr -> displayException ioErr
     ParseErr pe -> MP.errorBundlePretty pe
 
+instance Exception SFError
+
 -- | Helper for ExceptT stuff that we use in app/Main.hs
 readSecretList :: (MonadError SFError m, MonadIO m) => FilePath -> m [Secret]
 readSecretList fp = liftEither =<< (liftIO $ readSecretsFile fp)

From b54dd5abab83ef100c479125122352614b32d1ec Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Tue, 11 Feb 2020 17:52:03 +0100
Subject: [PATCH 03/18] Re-add retrying logic for getting MountInfo

---
 app/Main.hs | 45 ++++++++++++++++++++++++++++++++-------------
 1 file changed, 32 insertions(+), 13 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index d2fc2f2..aa5adeb 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,14 +1,16 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 import Control.Applicative    ((<|>))
-import Control.Exception      (Exception, throw)
+import Control.Exception      (Exception, throw, catch)
 import Control.Monad          (forM)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Aeson             (FromJSON, (.:))
 import Data.Aeson.Types       (parseMaybe)
 import Data.Bifunctor         (first)
+import Data.Either            (isLeft)
 import Data.HashMap.Strict    (HashMap, lookupDefault, mapMaybe)
 import Data.List              (nubBy)
 import Data.Monoid            ((<>))
@@ -244,16 +246,31 @@ getHttpManager opts = newManager managerSettings
 -- throw HTTP exceptions.
 vaultEnv :: Context -> IO (Either VaultError [EnvVar])
 vaultEnv context = do
-  mountInfo <- requestMountInfo context
-  secrets <- readSecretsFile secretFile
-  case secrets of
-    Left error -> throw error
-    Right secrets' -> do
-      secretEnv <- requestSecrets context mountInfo secrets'
-      case secretEnv of
+  mountInfo <- Retry.retrying retryPolicy isFailure getMountInfo
+  case mountInfo of
+    Left error -> return $ Left error
+    Right mountInfo' -> do
+      secrets <- readSecretsFile secretFile
+      case secrets of
         Left error -> throw error
-        Right secretEnv' -> return $ checkNoDuplicates (buildEnv secretEnv')
+        Right secrets' -> do
+          secretEnv <- requestSecrets context mountInfo' secrets'
+          case secretEnv of
+            Left error -> return $ Left error
+            Right secretEnv' -> return $ checkNoDuplicates (buildEnv secretEnv')
     where
+      retryPolicy = vaultRetryPolicy (cCliOptions context)
+
+      getMountInfo _retryStatus = catch (requestMountInfo context) httpErrorHandler
+
+      -- | Indicator function for retrying to retry on VaultErrors (Lefts)
+      isFailure :: Retry.RetryStatus -> Either VaultError MountInfo -> IO Bool
+      isFailure _retryStatus x = pure $ isLeft x
+
+      -- | "Handle" a HttpException by wrapping it in a Left VaultError.
+      -- TODO: Sanitize the contained request to not contain the Vault token.
+      httpErrorHandler (e :: HttpException) = return $ Left $ ServerUnreachable e
+
       secretFile = getOptionsValue oSecretFile (cCliOptions context)
       checkNoDuplicates :: [EnvVar] -> Either VaultError [EnvVar]
       checkNoDuplicates e =
@@ -296,7 +313,7 @@ runCommand options env =
     executeFile command searchPath args env'
 
 -- | Look up what mounts are available and what type they have.
-requestMountInfo :: Context -> IO MountInfo
+requestMountInfo :: Context -> IO (Either VaultError MountInfo)
 requestMountInfo context =
   let
     cliOptions = cCliOptions context
@@ -316,9 +333,11 @@ requestMountInfo context =
         $ defaultRequest
   in do
     resp <- httpLBS request
-    case Aeson.eitherDecode' (getResponseBody resp) of
-      Left error -> throw $ BadJSONResp error
-      Right result -> return result
+    let decodeResult = Aeson.eitherDecode' (getResponseBody resp) :: Either String MountInfo
+
+    case decodeResult of
+      Left error -> return $ Left $ BadJSONResp error
+      Right result -> return $ Right result
 
 -- | Request all the data associated with a secret from the vault.
 requestSecret :: Context -> String -> IO (Either VaultError VaultData)

From 4cc1e1e49ae6c23997f98081de5b3a499c6cb896 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Tue, 11 Feb 2020 18:11:02 +0100
Subject: [PATCH 04/18] Wrap SecretFileErrors properly

---
 app/Main.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/app/Main.hs b/app/Main.hs
index aa5adeb..8d4292c 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -252,7 +252,7 @@ vaultEnv context = do
     Right mountInfo' -> do
       secrets <- readSecretsFile secretFile
       case secrets of
-        Left error -> throw error
+        Left error -> return $ Left $ SecretFileError error
         Right secrets' -> do
           secretEnv <- requestSecrets context mountInfo' secrets'
           case secretEnv of

From fac30a5461d465740fb87affc946652213ff93d7 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Tue, 11 Feb 2020 18:17:17 +0100
Subject: [PATCH 05/18] Enable retrying fetching secrets as well

---
 app/Main.hs | 27 ++++++++++++++++++++-------
 1 file changed, 20 insertions(+), 7 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 8d4292c..43c967d 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -254,7 +254,15 @@ vaultEnv context = do
       case secrets of
         Left error -> return $ Left $ SecretFileError error
         Right secrets' -> do
-          secretEnv <- requestSecrets context mountInfo' secrets'
+          -- NOTE: This retries fetching all the secrets if fetching one of the
+          -- secrets fails due to an error we should retry on. We would ideally
+          -- keep the secrets that were successfully fetched in memory and only
+          -- retry getting the ones we couldn't get yet, as this makes it less
+          -- likely to get a 'thundering herd' of Vaultenv processes all trying
+          -- and failing to get all of their secrets.
+          -- This would then need to happen in requestSecrets, but I don't want
+          -- to touch that right now.
+          secretEnv <- Retry.retrying retryPolicy isFailure (getSecrets mountInfo' secrets')
           case secretEnv of
             Left error -> return $ Left error
             Right secretEnv' -> return $ checkNoDuplicates (buildEnv secretEnv')
@@ -262,19 +270,24 @@ vaultEnv context = do
       retryPolicy = vaultRetryPolicy (cCliOptions context)
 
       getMountInfo _retryStatus = catch (requestMountInfo context) httpErrorHandler
+      getSecrets mountInfo secrets _retryStatus = catch (requestSecrets context mountInfo secrets) httpErrorHandler
 
-      -- | Indicator function for retrying to retry on VaultErrors (Lefts)
-      isFailure :: Retry.RetryStatus -> Either VaultError MountInfo -> IO Bool
-      isFailure _retryStatus x = pure $ isLeft x
+      -- | Indicator function for retrying to retry on VaultErrors (Lefts) that
+      -- shouldRetry thinks we should retry on.
+      isFailure :: Retry.RetryStatus -> Either VaultError a -> IO Bool
+      isFailure _retryStatus (Right _) = pure False
+      isFailure retryStatus (Left err) = shouldRetry retryStatus err
 
       -- | "Handle" a HttpException by wrapping it in a Left VaultError.
       -- TODO: Sanitize the contained request to not contain the Vault token.
       httpErrorHandler (e :: HttpException) = return $ Left $ ServerUnreachable e
 
       secretFile = getOptionsValue oSecretFile (cCliOptions context)
+
       checkNoDuplicates :: [EnvVar] -> Either VaultError [EnvVar]
-      checkNoDuplicates e =
-        either (throwError . DuplicateVar) (return . const e) $ dups (map fst e)
+      checkNoDuplicates vars = case dups (map fst vars) of
+        Right () -> Right vars
+        Left var -> Left $ DuplicateVar var
 
       -- We need to check duplicates in the environment and fail if
       -- there are any. `dups` runs in O(n^2),
@@ -396,7 +409,7 @@ retryingExceptT policy predicate action =
 
 -- | Request all the supplied secrets from the vault, but just once, even if
 -- multiple keys are specified for a single secret. This is an optimization in
--- order to avoid unnecessary round trips and DNS requets.
+-- order to avoid unnecessary round trips and DNS requests.
 requestSecrets :: Context -> MountInfo -> [Secret] -> IO (Either VaultError [EnvVar])
 requestSecrets context mountInfo secrets = do
   let secretPaths = Foldable.foldMap (\x -> Map.singleton x x) $ fmap (secretRequestPath mountInfo) secrets

From 00937aa9d4af66c6c2269844029cb256732d6f6a Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Wed, 12 Feb 2020 11:44:22 +0100
Subject: [PATCH 06/18] Remove use of Control.Monad.Except from SecretsFile.hs

---
 src/SecretsFile.hs | 5 -----
 1 file changed, 5 deletions(-)

diff --git a/src/SecretsFile.hs b/src/SecretsFile.hs
index ac276af..b2cffe1 100644
--- a/src/SecretsFile.hs
+++ b/src/SecretsFile.hs
@@ -23,7 +23,6 @@ module SecretsFile where
 
 import Control.Applicative.Combinators (some, option, optional)
 import Control.Exception (Exception, try, displayException)
-import Control.Monad.Except (MonadError, MonadIO, liftEither, liftIO)
 import Data.Char (toUpper, isSpace, isControl)
 import Data.Functor (void)
 import Data.List (intercalate)
@@ -59,10 +58,6 @@ instance Show SFError where
 
 instance Exception SFError
 
--- | Helper for ExceptT stuff that we use in app/Main.hs
-readSecretList :: (MonadError SFError m, MonadIO m) => FilePath -> m [Secret]
-readSecretList fp = liftEither =<< (liftIO $ readSecretsFile fp)
-
 -- | Read a list of secrets from a file
 readSecretsFile :: FilePath -> IO (Either SFError [Secret])
 readSecretsFile fp = do

From 53b29eceb978207b4cdfe9443b2ad30b3c14067f Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Wed, 12 Feb 2020 11:45:26 +0100
Subject: [PATCH 07/18] Re-enable -Wall, fix messages, remove now-dead code

---
 app/Main.hs  | 47 ++++++++++++++---------------------------------
 package.yaml |  2 +-
 2 files changed, 15 insertions(+), 34 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 43c967d..3472f43 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -4,13 +4,12 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 import Control.Applicative    ((<|>))
-import Control.Exception      (Exception, throw, catch)
+import Control.Exception      (Exception, catch)
 import Control.Monad          (forM)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Aeson             (FromJSON, (.:))
 import Data.Aeson.Types       (parseMaybe)
 import Data.Bifunctor         (first)
-import Data.Either            (isLeft)
 import Data.HashMap.Strict    (HashMap, lookupDefault, mapMaybe)
 import Data.List              (nubBy)
 import Data.Monoid            ((<>))
@@ -25,8 +24,6 @@ import Network.HTTP.Simple    (HttpException(..), Request, Response,
                                getResponseStatusCode)
 import System.Environment     (getEnvironment)
 import System.Posix.Process   (executeFile)
-import Control.Monad.Except   (ExceptT (..), MonadError, runExceptT, mapExceptT,
-                               throwError, liftEither, withExceptT)
 
 import qualified Control.Concurrent.Async   as Async
 import qualified Control.Retry              as Retry
@@ -41,7 +38,7 @@ import qualified System.Exit                as Exit
 import Config (Options(..), parseOptions, unMilliSeconds,
                LogLevel(..), readConfigFromEnvFiles, getOptionsValue,
                Validated, Completed)
-import SecretsFile (Secret(..), SFError(..), readSecretList, readSecretsFile)
+import SecretsFile (Secret(..), SFError(..), readSecretsFile)
 
 -- | Make a HTTP URL path from a secret. This is the path that Vault expects.
 secretRequestPath :: MountInfo -> Secret -> String
@@ -141,7 +138,7 @@ instance FromJSON VaultData where
 instance FromJSON MountInfo where
   parseJSON =
     let
-      getType = Aeson.withObject "MountSpec" $ \o -> do
+      getType = Aeson.withObject "MountSpec" $ \o ->
         o .: "type" >>= (Aeson.withText "mount type" $ (\case
           "kv" -> do
             options <- o .: "options"
@@ -153,7 +150,7 @@ instance FromJSON MountInfo where
                 _ -> fail "unknown version number") options
           _ -> fail "expected a KV type"))
     in
-      Aeson.withObject "MountResp" $ \obj -> do
+      Aeson.withObject "MountResp" $ \obj ->
         pure $ MountInfo (mapMaybe (\v -> parseMaybe getType v) obj)
 
 -- | Error modes of this program.
@@ -248,11 +245,11 @@ vaultEnv :: Context -> IO (Either VaultError [EnvVar])
 vaultEnv context = do
   mountInfo <- Retry.retrying retryPolicy isFailure getMountInfo
   case mountInfo of
-    Left error -> return $ Left error
+    Left vaultError -> return $ Left vaultError
     Right mountInfo' -> do
       secrets <- readSecretsFile secretFile
       case secrets of
-        Left error -> return $ Left $ SecretFileError error
+        Left sfError -> return $ Left $ SecretFileError sfError
         Right secrets' -> do
           -- NOTE: This retries fetching all the secrets if fetching one of the
           -- secrets fails due to an error we should retry on. We would ideally
@@ -264,7 +261,7 @@ vaultEnv context = do
           -- to touch that right now.
           secretEnv <- Retry.retrying retryPolicy isFailure (getSecrets mountInfo' secrets')
           case secretEnv of
-            Left error -> return $ Left error
+            Left vaultError -> return $ Left vaultError
             Right secretEnv' -> return $ checkNoDuplicates (buildEnv secretEnv')
     where
       retryPolicy = vaultRetryPolicy (cCliOptions context)
@@ -349,7 +346,7 @@ requestMountInfo context =
     let decodeResult = Aeson.eitherDecode' (getResponseBody resp) :: Either String MountInfo
 
     case decodeResult of
-      Left error -> return $ Left $ BadJSONResp error
+      Left errorMsg -> return $ Left $ BadJSONResp errorMsg
       Right result -> return $ Right result
 
 -- | Request all the data associated with a secret from the vault.
@@ -391,22 +388,6 @@ shouldRetry _retryStatus res = pure $ case res of
   DuplicateVar _ -> False
   SecretFileError _ -> False
 
--- |
--- Like 'Retry.retrying', but using 'ExceptT' instead of return values. The
--- predicate also only gets the error, not the return value.
-retryingExceptT
-  :: MonadIO m
-  => Retry.RetryPolicyM m
-  -> (Retry.RetryStatus -> e -> m Bool)
-  -> (Retry.RetryStatus -> ExceptT e m a)
-  -> ExceptT e m a
-retryingExceptT policy predicate action =
-  ExceptT $ Retry.retrying policy predicate' action'
-  where
-    predicate' _ (Right _) = pure False
-    predicate' s (Left e)  = predicate s e
-    action' = runExceptT . action
-
 -- | Request all the supplied secrets from the vault, but just once, even if
 -- multiple keys are specified for a single secret. This is an optimization in
 -- order to avoid unnecessary round trips and DNS requests.
@@ -440,12 +421,12 @@ parseResponse secretPath response =
     responseBody = getResponseBody response
     statusCode = getResponseStatusCode response
   in case statusCode of
-    200 -> liftEither (parseSuccessResponse responseBody)
-    403 -> throwError Forbidden
-    404 -> throwError $ SecretNotFound secretPath
-    500 -> throwError $ ServerError responseBody
-    503 -> throwError $ ServerUnavailable responseBody
-    _   -> throwError $ Unspecified statusCode responseBody
+    200 -> parseSuccessResponse responseBody
+    403 -> Left Forbidden
+    404 -> Left $ SecretNotFound secretPath
+    500 -> Left $ ServerError responseBody
+    503 -> Left $ ServerUnavailable responseBody
+    _   -> Left $ Unspecified statusCode responseBody
 
 
 parseSuccessResponse :: LBS.ByteString -> Either VaultError VaultData
diff --git a/package.yaml b/package.yaml
index ae95993..04e16fa 100644
--- a/package.yaml
+++ b/package.yaml
@@ -28,7 +28,7 @@ dependencies:
   - utf8-string
   - optparse-applicative
 
-# ghc-options: -Wall -Werror
+ghc-options: -Wall -Werror
 
 library:
   source-dirs: src

From 41813b4451573cb04cbcd38c07bc8943ec64a173 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Wed, 12 Feb 2020 13:50:37 +0100
Subject: [PATCH 08/18] Remove unnecessarily added Exception instances

---
 app/Main.hs        | 4 +---
 src/SecretsFile.hs | 4 +---
 2 files changed, 2 insertions(+), 6 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 3472f43..9f55301 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -4,7 +4,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 import Control.Applicative    ((<|>))
-import Control.Exception      (Exception, catch)
+import Control.Exception      (catch)
 import Control.Monad          (forM)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Aeson             (FromJSON, (.:))
@@ -173,8 +173,6 @@ data VaultError
   | Unspecified Int LBS.ByteString
   deriving Show
 
-instance Exception VaultError
-
 -- | Retry configuration to use for network requests to Vault.
 -- We use a limited exponential backoff with the policy
 -- fullJitterBackoff that comes with the Retry package.
diff --git a/src/SecretsFile.hs b/src/SecretsFile.hs
index b2cffe1..9b54fcc 100644
--- a/src/SecretsFile.hs
+++ b/src/SecretsFile.hs
@@ -22,7 +22,7 @@ If you are user, please see the README for more information.
 module SecretsFile where
 
 import Control.Applicative.Combinators (some, option, optional)
-import Control.Exception (Exception, try, displayException)
+import Control.Exception (try, displayException)
 import Data.Char (toUpper, isSpace, isControl)
 import Data.Functor (void)
 import Data.List (intercalate)
@@ -56,8 +56,6 @@ instance Show SFError where
     IOErr ioErr -> displayException ioErr
     ParseErr pe -> MP.errorBundlePretty pe
 
-instance Exception SFError
-
 -- | Read a list of secrets from a file
 readSecretsFile :: FilePath -> IO (Either SFError [Secret])
 readSecretsFile fp = do

From 13b7f357994260e8b90d5e1a560bb44a0cdcf95a Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Wed, 12 Feb 2020 13:53:00 +0100
Subject: [PATCH 09/18] Clean up vaultEnv function a bit, add more comments

---
 app/Main.hs | 29 ++++++++++++++++++++---------
 1 file changed, 20 insertions(+), 9 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 9f55301..28d42ea 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -241,7 +241,7 @@ getHttpManager opts = newManager managerSettings
 -- throw HTTP exceptions.
 vaultEnv :: Context -> IO (Either VaultError [EnvVar])
 vaultEnv context = do
-  mountInfo <- Retry.retrying retryPolicy isFailure getMountInfo
+  mountInfo <- doWithRetries getMountInfo
   case mountInfo of
     Left vaultError -> return $ Left vaultError
     Right mountInfo' -> do
@@ -257,28 +257,34 @@ vaultEnv context = do
           -- and failing to get all of their secrets.
           -- This would then need to happen in requestSecrets, but I don't want
           -- to touch that right now.
-          secretEnv <- Retry.retrying retryPolicy isFailure (getSecrets mountInfo' secrets')
+          secretEnv <- doWithRetries (getSecrets mountInfo' secrets')
           case secretEnv of
             Left vaultError -> return $ Left vaultError
             Right secretEnv' -> return $ checkNoDuplicates (buildEnv secretEnv')
     where
+      doWithRetries :: (Retry.RetryStatus -> IO (Either VaultError a)) -> IO (Either VaultError a)
+      doWithRetries = Retry.retrying retryPolicy isRetryableFailure
+
+      -- | Indicator function for retrying to retry on VaultErrors (Lefts) that
+      -- shouldRetry thinks we should retry on. Needs to be in IO because the
+      -- actions to perform are in IO as well.
+      isRetryableFailure :: Retry.RetryStatus -> Either VaultError a -> IO Bool
+      isRetryableFailure _retryStatus (Right _) = pure False
+      isRetryableFailure retryStatus (Left err) = shouldRetry retryStatus err
+
       retryPolicy = vaultRetryPolicy (cCliOptions context)
 
       getMountInfo _retryStatus = catch (requestMountInfo context) httpErrorHandler
       getSecrets mountInfo secrets _retryStatus = catch (requestSecrets context mountInfo secrets) httpErrorHandler
 
-      -- | Indicator function for retrying to retry on VaultErrors (Lefts) that
-      -- shouldRetry thinks we should retry on.
-      isFailure :: Retry.RetryStatus -> Either VaultError a -> IO Bool
-      isFailure _retryStatus (Right _) = pure False
-      isFailure retryStatus (Left err) = shouldRetry retryStatus err
-
       -- | "Handle" a HttpException by wrapping it in a Left VaultError.
       -- TODO: Sanitize the contained request to not contain the Vault token.
       httpErrorHandler (e :: HttpException) = return $ Left $ ServerUnreachable e
 
       secretFile = getOptionsValue oSecretFile (cCliOptions context)
 
+      -- | Check that the given list of EnvVars contains no duplicate
+      -- variables, return a DuplicateVar error if it does.
       checkNoDuplicates :: [EnvVar] -> Either VaultError [EnvVar]
       checkNoDuplicates vars = case dups (map fst vars) of
         Right () -> Right vars
@@ -297,6 +303,11 @@ vaultEnv context = do
 
       isDup x = foldr (\y acc -> acc || x == y) False
 
+      -- | Build the resulting environment for the process to start, given the
+      -- list of environment variables that were retrieved from Vault.  Return
+      -- either only the retrieved secrets (if --no-inherit-env is used), or
+      -- merge the retrieved variables with the environment where Vaultenv was
+      -- called and apply the blacklist.
       buildEnv :: [EnvVar] -> [EnvVar]
       buildEnv secretsEnv =
         if getOptionsValue oInheritEnv . cCliOptions $ context
@@ -365,7 +376,7 @@ requestSecret context secretPath =
   in
     doRequest secretPath request
 
--- | Determine whether to retry
+-- | Determine whether a request that resulted in the given VaultError should be retried.
 shouldRetry :: Applicative f => Retry.RetryStatus -> VaultError -> f Bool
 shouldRetry _retryStatus res = pure $ case res of
   ServerError _ -> True

From faaaf502f9b68e8e6ccaf445e62042c1fdb8846a Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Wed, 12 Feb 2020 14:17:17 +0100
Subject: [PATCH 10/18] Sanitize HttpExceptions to not contain the Vault root
 token

---
 app/Main.hs | 14 ++++++++++++--
 1 file changed, 12 insertions(+), 2 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 28d42ea..14194e8 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -278,8 +278,18 @@ vaultEnv context = do
       getSecrets mountInfo secrets _retryStatus = catch (requestSecrets context mountInfo secrets) httpErrorHandler
 
       -- | "Handle" a HttpException by wrapping it in a Left VaultError.
-      -- TODO: Sanitize the contained request to not contain the Vault token.
-      httpErrorHandler (e :: HttpException) = return $ Left $ ServerUnreachable e
+      -- We also edit the Request contained in the exception to remove the
+      -- Vault token, as it would otherwise get printed to stderr if we error
+      -- out.
+      httpErrorHandler (e :: HttpException) = case e of
+        (HttpExceptionRequest request reason) ->
+          let sanitizedRequest = sanitizeRequest request
+          in return $ Left $ ServerUnreachable (HttpExceptionRequest sanitizedRequest reason)
+        (InvalidUrlException url _reason) -> return $ Left $ InvalidUrl url
+
+        where
+          sanitizeRequest :: Request -> Request
+          sanitizeRequest = setRequestHeader "x-vault-token" ["**removed**"]
 
       secretFile = getOptionsValue oSecretFile (cCliOptions context)
 

From e8cc69395c308e69d8ff65ccf119aa7c2986274a Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Mon, 17 Feb 2020 11:41:26 +0100
Subject: [PATCH 11/18] Address review comments

- Replace new uses of `return` with `pure`
- Add notes that httpLBS throws exceptions in IO
- Add link to issue on granular retries
- Add type signatures for `getMountInfo`, `getSecrets` in `vaultEnv`
- Rewrite docstring of `vaultEnv`
---
 app/Main.hs | 45 ++++++++++++++++++++++++++++-----------------
 1 file changed, 28 insertions(+), 17 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 14194e8..bb61285 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -231,23 +231,26 @@ getHttpManager opts = newManager managerSettings
                 , settingUseServerName = True
                 }
 
--- | Main logic of our application. Reads a list of secrets, fetches
--- each of them from Vault, checks for duplicates, and then yields
--- the list of environment variables to make available to the process
--- we want to run eventually. It either scrubs the environment that
--- already existed or keeps it.
+-- | Main logic of our application.
 --
--- Signals failure through a value of type VaultError, but can also
--- throw HTTP exceptions.
+-- We first retrieve the mount information from Vault, as this is needed to
+-- construct the URLs of the secrets to fetch.
+-- With this information we fetch the secrets from Vault, check for duplicates,
+-- and then yield the list of environment variables to make available to the
+-- process we want to run eventually.
+-- Based on the settings in the context we either scrub the environment that
+-- already existed or keep it (applying the inheritance blacklist if it exists).
+--
+-- Signals failure through a value of type VaultError.
 vaultEnv :: Context -> IO (Either VaultError [EnvVar])
 vaultEnv context = do
   mountInfo <- doWithRetries getMountInfo
   case mountInfo of
-    Left vaultError -> return $ Left vaultError
+    Left vaultError -> pure $ Left vaultError
     Right mountInfo' -> do
       secrets <- readSecretsFile secretFile
       case secrets of
-        Left sfError -> return $ Left $ SecretFileError sfError
+        Left sfError -> pure $ Left $ SecretFileError sfError
         Right secrets' -> do
           -- NOTE: This retries fetching all the secrets if fetching one of the
           -- secrets fails due to an error we should retry on. We would ideally
@@ -257,10 +260,11 @@ vaultEnv context = do
           -- and failing to get all of their secrets.
           -- This would then need to happen in requestSecrets, but I don't want
           -- to touch that right now.
+          -- Issue: https://github.com/channable/vaultenv/issues/90
           secretEnv <- doWithRetries (getSecrets mountInfo' secrets')
           case secretEnv of
-            Left vaultError -> return $ Left vaultError
-            Right secretEnv' -> return $ checkNoDuplicates (buildEnv secretEnv')
+            Left vaultError -> pure $ Left vaultError
+            Right secretEnv' -> pure $ checkNoDuplicates (buildEnv secretEnv')
     where
       doWithRetries :: (Retry.RetryStatus -> IO (Either VaultError a)) -> IO (Either VaultError a)
       doWithRetries = Retry.retrying retryPolicy isRetryableFailure
@@ -274,7 +278,10 @@ vaultEnv context = do
 
       retryPolicy = vaultRetryPolicy (cCliOptions context)
 
+      getMountInfo :: Retry.RetryStatus -> IO (Either VaultError MountInfo)
       getMountInfo _retryStatus = catch (requestMountInfo context) httpErrorHandler
+
+      getSecrets :: MountInfo -> [Secret] -> Retry.RetryStatus -> IO (Either VaultError [EnvVar])
       getSecrets mountInfo secrets _retryStatus = catch (requestSecrets context mountInfo secrets) httpErrorHandler
 
       -- | "Handle" a HttpException by wrapping it in a Left VaultError.
@@ -284,8 +291,8 @@ vaultEnv context = do
       httpErrorHandler (e :: HttpException) = case e of
         (HttpExceptionRequest request reason) ->
           let sanitizedRequest = sanitizeRequest request
-          in return $ Left $ ServerUnreachable (HttpExceptionRequest sanitizedRequest reason)
-        (InvalidUrlException url _reason) -> return $ Left $ InvalidUrl url
+          in pure $ Left $ ServerUnreachable (HttpExceptionRequest sanitizedRequest reason)
+        (InvalidUrlException url _reason) -> pure $ Left $ InvalidUrl url
 
         where
           sanitizeRequest :: Request -> Request
@@ -361,12 +368,14 @@ requestMountInfo context =
               (getOptionsValue  oConnectTls cliOptions)
         $ defaultRequest
   in do
+    -- 'httpLBS' throws an IO Exception ('HttpException') if it fails to complete the request.
+    -- We intentionally don't capture this here, but handle it with the retries in 'vaultEnv' instead.
     resp <- httpLBS request
     let decodeResult = Aeson.eitherDecode' (getResponseBody resp) :: Either String MountInfo
 
     case decodeResult of
-      Left errorMsg -> return $ Left $ BadJSONResp errorMsg
-      Right result -> return $ Right result
+      Left errorMsg -> pure $ Left $ BadJSONResp errorMsg
+      Right result -> pure $ Right result
 
 -- | Request all the data associated with a secret from the vault.
 requestSecret :: Context -> String -> IO (Either VaultError VaultData)
@@ -414,7 +423,7 @@ requestSecrets :: Context -> MountInfo -> [Secret] -> IO (Either VaultError [Env
 requestSecrets context mountInfo secrets = do
   let secretPaths = Foldable.foldMap (\x -> Map.singleton x x) $ fmap (secretRequestPath mountInfo) secrets
   secretData <- liftIO (Async.mapConcurrently (requestSecret context) secretPaths)
-  return $ sequence secretData >>= lookupSecrets mountInfo secrets
+  pure $ sequence secretData >>= lookupSecrets mountInfo secrets
 
 -- | Look for the requested keys in the secret data that has been previously fetched.
 lookupSecrets :: MountInfo -> [Secret] -> Map.Map String VaultData -> Either VaultError [EnvVar]
@@ -427,8 +436,10 @@ lookupSecrets mountInfo secrets vaultData = forM secrets $ \secret ->
 -- | Send a request for secrets to the vault and parse the response.
 doRequest :: String -> Request -> IO (Either VaultError VaultData)
 doRequest secretPath request = do
+  -- As in 'requestMountInfo': 'httpLBS' throws a 'HttpException' in IO if it
+  -- fails to complete the request, this is handled in 'vaultEnv' by the retry logic.
   resp <- httpLBS request
-  return $ parseResponse secretPath resp
+  pure $ parseResponse secretPath resp
 
 --
 -- HTTP response handling

From d80b1e60dcb914f6f8b55fc654b71cb4139aac69 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Mon, 17 Feb 2020 11:59:51 +0100
Subject: [PATCH 12/18] Drop dependency on `mtl`

---
 package.yaml  | 1 -
 src/Config.hs | 9 ++++-----
 2 files changed, 4 insertions(+), 6 deletions(-)

diff --git a/package.yaml b/package.yaml
index 04e16fa..550850d 100644
--- a/package.yaml
+++ b/package.yaml
@@ -18,7 +18,6 @@ dependencies:
   - http-conduit
   - http-client
   - megaparsec
-  - mtl
   - optparse-applicative
   - parser-combinators
   - retry
diff --git a/src/Config.hs b/src/Config.hs
index 755571d..b77bf8a 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -21,7 +21,6 @@ module Config
 
 import Control.Applicative ((<*>), (<|>))
 import Control.Monad(when, unless)
-import Control.Monad.Except (runExcept, throwError)
 import Data.List (intercalate, isPrefixOf)
 import Data.Maybe (fromJust, fromMaybe, isNothing, isJust)
 import Data.Monoid ((<>))
@@ -188,15 +187,15 @@ instance Show OptionsError where
 validateCopyAddr :: String -> Options UnValidated completed -> Either OptionsError (Options Validated completed)
 validateCopyAddr source opts
   | isNothing (oVaultAddr opts) = Right (castOptions opts)
-  | otherwise = runExcept $ do
+  | otherwise = do
     let addr = fromMaybe
                 (errorWithoutStackTrace "Addr not a Just in validation")
                 (oVaultAddr opts)
         (mStrScheme, addrHost, addrStrPort) = splitAddress addr
     unless (all isDigit addrStrPort && not (null addrStrPort))
-        (throwError $ NonNumericPort addrStrPort)
+        (Left $ NonNumericPort addrStrPort)
     unless (isJust mStrScheme)
-        (throwError $ UnknownScheme addrHost)
+        (Left $ UnknownScheme addrHost)
     let mHost = oVaultHost opts
         mPort = oVaultPort opts
         mUseTLS = oConnectTls opts
@@ -211,7 +210,7 @@ validateCopyAddr source opts
             ||
             (isJust mUseTLS && addrTLS /= mUseTLS) -- Is the UseTLS set and the same
     when doesAddrDiffer
-      (throwError $ HostPortSchemeAddrMismatch
+      (Left $ HostPortSchemeAddrMismatch
           source
           mUseTLS
           mHost

From 2c5bd0bb9a8b27ff7dcbf39b867063011d66c4c4 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Mon, 17 Feb 2020 15:38:08 +0100
Subject: [PATCH 13/18] Address more review comments

---
 app/Main.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index bb61285..e50211c 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -209,8 +209,7 @@ main = do
                         , cHttpManager = httpManager
                         }
 
-  envVars <- vaultEnv context
-  case envVars of
+  vaultEnv context >>= \case
     Left err -> Exit.die (vaultErrorLogMessage err)
     Right newEnv -> runCommand cliAndEnvAndEnvFileOptions newEnv
 
@@ -288,6 +287,7 @@ vaultEnv context = do
       -- We also edit the Request contained in the exception to remove the
       -- Vault token, as it would otherwise get printed to stderr if we error
       -- out.
+      httpErrorHandler :: HttpException -> IO (Either VaultError b)
       httpErrorHandler (e :: HttpException) = case e of
         (HttpExceptionRequest request reason) ->
           let sanitizedRequest = sanitizeRequest request

From b9449601e440329943e80766b07802f0c48f3652 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Tue, 18 Feb 2020 16:05:16 +0100
Subject: [PATCH 14/18] Add integration test for retry behaviour

---
 test/integration/retry_tests.py | 194 ++++++++++++++++++++++++++++++++
 test/integration/tap.py         |  31 +++++
 test/integration_test.sh        |   2 +
 3 files changed, 227 insertions(+)
 create mode 100755 test/integration/retry_tests.py
 create mode 100644 test/integration/tap.py

diff --git a/test/integration/retry_tests.py b/test/integration/retry_tests.py
new file mode 100755
index 0000000..9b69528
--- /dev/null
+++ b/test/integration/retry_tests.py
@@ -0,0 +1,194 @@
+#!/usr/bin/python3.7
+"""
+Tests whether the retry mechanism in Vaultenv works correctly by starting Vaultenv
+before the Vault server is ready. Runs after the rest of the tests in
+integration_test.sh, and requires that there is no Vault server running.
+
+Requires these environment variables (should all be set by integration_test.sh):
+  - VAULT_ADDR, VAULT_HOST, VAULT_PORT, VAULT_TOKEN: Credentials to connect to development Vault
+  - VAULT_SEEDS, VAULT_SEEDS_V2: Paths to a V1 and V2 secrets file
+"""
+
+import os
+import signal
+import subprocess
+from pathlib import Path
+from time import sleep
+from typing import Set
+
+import tap
+
+
+def main() -> None:
+    v1_secrets_file = Path(os.environ["VAULT_SEEDS"])
+    v2_secrets_file = Path(os.environ["VAULT_SEEDS_V2"])
+
+    tap.plan(4)
+
+    tap.diagnose("Starting Vaultenv processes")
+    v1_handle = run_vaultenv(v1_secrets_file)
+    v2_handle = run_vaultenv(v2_secrets_file)
+
+    sleep(5)
+    tap.diagnose("Pausing Vaultenv processes")
+    v1_handle.send_signal(signal.SIGSTOP)
+    v2_handle.send_signal(signal.SIGSTOP)
+
+    tap.diagnose("Starting Vault server")
+    vault_server = run_vault_server()
+    sleep(5)
+
+    tap.diagnose("Resuming Vaultenv processes")
+    v1_handle.send_signal(signal.SIGCONT)
+    v2_handle.send_signal(signal.SIGCONT)
+
+    check_vaultenv_result(v1_handle, secrets_version=1, api_version=1)
+    check_vaultenv_result(v2_handle, secrets_version=2, api_version=1)
+
+    # We need to kill and restart the server or the kernel will accept the TCP
+    # connections while the Vault server is paused.
+    vault_server.terminate()
+    vault_server.wait(timeout=5)
+
+    tap.diagnose("Starting Vaultenv processes")
+    v1_handle = run_vaultenv(v1_secrets_file)
+    v2_handle = run_vaultenv(v2_secrets_file)
+    sleep(5)
+
+    tap.diagnose("Pausing Vaultenv processes")
+    v1_handle.send_signal(signal.SIGSTOP)
+    v2_handle.send_signal(signal.SIGSTOP)
+
+    tap.diagnose("Starting Vault server")
+    vault_server = run_vault_server()
+    sleep(5)
+
+    tap.diagnose("Resuming Vaultenv processes")
+    v1_handle.send_signal(signal.SIGCONT)
+    v2_handle.send_signal(signal.SIGCONT)
+
+    check_vaultenv_result(v1_handle, secrets_version=1, api_version=2)
+    check_vaultenv_result(v2_handle, secrets_version=2, api_version=2)
+
+    tap.diagnose("Killing Vault server")
+    vault_server.terminate()
+    vault_server.wait(timeout=10)
+
+def run_vaultenv(secrets_file: Path) -> subprocess.Popen:
+    """
+    Run Vaultenv with the secrets file from the given path.
+
+    Return a subprocess.Popen-handle to the running process.
+    """
+    return subprocess.Popen(
+        [
+            "stack",
+            "run",
+            "--",
+            "vaultenv",
+            "--no-connect-tls",
+            "--host",
+            os.environ["VAULT_HOST"],
+            "--port",
+            os.environ["VAULT_PORT"],
+            "--secrets-file",
+            str(secrets_file),
+            "/usr/bin/env",
+        ],
+        stdin=subprocess.DEVNULL,
+        stdout=subprocess.PIPE,
+        stderr=None,  # Inherit calling process's stderr
+        text=True,
+    )
+
+
+def check_vaultenv_result(
+    process_handle: subprocess.Popen, secrets_version: int, api_version: int
+) -> None:
+    """
+    Check the return code and output of the Vaultenv process under the given
+    process_handle.
+
+    Emit an appropriate TAP message for the result of the test.
+    """
+
+    description = f"v{secrets_version} secrets/v{api_version} API"
+
+    return_code = process_handle.wait()
+    if return_code != 0:
+        tap.not_ok(f"{description} returned with code {return_code}")
+        return
+
+    expected_env: Set[str]
+    if secrets_version == 1:
+        expected_env = {
+            "TESTING_KEY=testing42",
+            "TESTING_OTHERKEY=testing8",
+            "TESTING2_FOO=val1",
+            "TESTING2_BAR=val2",
+            "TEST_TEST=testing42",
+            "TEST__TEST=testing42",
+            "_TEST__TEST=testing42",
+        }
+    elif secrets_version == 2:
+        expected_env = {
+            "SECRET_TESTING_KEY=testing42",
+            "SECRET_TESTING_OTHERKEY=testing8",
+            "SECRET_TESTING2_FOO=val1",
+            "SECRET_TESTING2_BAR=val2",
+        }
+
+    actual_env = set(line.strip() for line in process_handle.stdout.readlines())
+
+    if not expected_env <= actual_env:
+        missing = ", ".join(expected_env - actual_env)
+        tap.not_ok(f"{description} missing vars {missing}")
+        breakpoint()
+        return
+
+    tap.ok(description)
+
+
+def run_vault_server() -> subprocess.Popen:
+    """
+    Run the Vault dev server and seed it with a known set of secrets.
+    """
+    env = {
+        "VAULT_TOKEN": "integration",
+        "VAULT_HOST": "localhost",
+        "VAULT_PORT": "8200",
+        "VAULT_ADDR": "http://localhost:8200",
+    }
+
+    vault_server = subprocess.Popen(
+        ["vault", "server", "-dev", "-dev-root-token-id=integration"],
+        stdin=subprocess.DEVNULL,
+        stdout=subprocess.DEVNULL,
+        stderr=subprocess.DEVNULL,
+    )
+    sleep(1)  # As in integration_test.sh
+
+    subprocess.run(["vault", "secrets", "disable", "secret"], check=True, env=env)
+    subprocess.run(
+        ["vault", "secrets", "enable", "-path=secret", "-version=1", "kv"],
+        check=True,
+        env=env,
+    )
+    subprocess.run(
+        ["vault", "kv", "put", "secret/testing", "key=testing42", "otherkey=testing8"],
+        check=True,
+        stdout=subprocess.DEVNULL,
+        stderr=subprocess.DEVNULL,
+        env=env,
+    )
+    subprocess.run(
+        ["vault", "kv", "put", "secret/testing2", "foo=val1", "bar=val2"],
+        check=True,
+        stdout=subprocess.DEVNULL,
+        stderr=subprocess.DEVNULL,
+    )
+    return vault_server
+
+
+if __name__ == "__main__":
+    main()
diff --git a/test/integration/tap.py b/test/integration/tap.py
new file mode 100644
index 0000000..2fc5624
--- /dev/null
+++ b/test/integration/tap.py
@@ -0,0 +1,31 @@
+"""
+Module for producing output according to the Test Anything Protocol.
+The program prove(1) can process this output.
+"""
+
+
+_test_number = 0
+
+
+def plan(n: int) -> None:
+    """Print the number of tests that are to be run."""
+    print(f"1..{n}")
+
+
+def ok(message: str) -> None:
+    """Report that the current test succeeded."""
+    global _test_number
+    _test_number += 1
+    print(f"ok {_test_number} - {message}")
+
+
+def not_ok(message: str) -> None:
+    """Report that the current test failed."""
+    global _test_number
+    _test_number += 1
+    print(f"not ok {_test_number} - {message}")
+
+
+def diagnose(message: str) -> None:
+    """Print debug output."""
+    print(f"# {message}")
diff --git a/test/integration_test.sh b/test/integration_test.sh
index d096d28..e4a5ab2 100755
--- a/test/integration_test.sh
+++ b/test/integration_test.sh
@@ -88,3 +88,5 @@ fi
 
 # Cleanup the vault dev server
 kill %%
+
+PYTHONUNBUFFERED=1 prove --comments integration/retry_tests.py

From e04f1336843331e481f4e0c04b71f4f999e7556c Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Wed, 19 Feb 2020 10:36:29 +0100
Subject: [PATCH 15/18] test: Add more comments on the retry test

---
 test/integration/retry_tests.py | 28 +++++++++++++++++++++++++---
 1 file changed, 25 insertions(+), 3 deletions(-)

diff --git a/test/integration/retry_tests.py b/test/integration/retry_tests.py
index 9b69528..cfbc132 100755
--- a/test/integration/retry_tests.py
+++ b/test/integration/retry_tests.py
@@ -20,6 +20,26 @@
 
 
 def main() -> None:
+    """
+    Test whether the retry behaviour in Vaultenv works as expected.
+
+    We do this by:
+      - Starting two Vaultenv processes (one for each version of the secrets file
+        format) and letting them run for 5 seconds (during which they should retry)
+      - Suspending the Vaultenv processes with the SIGSTOP signal
+      - Setting up a Vault server process with the appropriate secrets
+      - Resuming the Vaultenv processes with the SIGCONT signal
+      - Checking whether the Vaultenv processes exited with code 0 and got the right
+        secrets (by having them run /usr/bin/env)
+      - Killing the Vault server
+
+    We do this twice, once for version 1 of Vault's KV secret store API and once for
+    version 2 of the API.
+
+    The SIGSTOP/SIGCONT signals are necessary to prevent the Vaultenv processes from
+    contacting the Vault server while it is up, but does not yet contain the right
+    secrets (which causes a non-retryable error by design).
+    """
     v1_secrets_file = Path(os.environ["VAULT_SEEDS"])
     v2_secrets_file = Path(os.environ["VAULT_SEEDS_V2"])
 
@@ -78,7 +98,7 @@ def run_vaultenv(secrets_file: Path) -> subprocess.Popen:
     """
     Run Vaultenv with the secrets file from the given path.
 
-    Return a subprocess.Popen-handle to the running process.
+    Return a subprocess.Popen-handle to the running Vaultenv process.
     """
     return subprocess.Popen(
         [
@@ -143,7 +163,6 @@ def check_vaultenv_result(
     if not expected_env <= actual_env:
         missing = ", ".join(expected_env - actual_env)
         tap.not_ok(f"{description} missing vars {missing}")
-        breakpoint()
         return
 
     tap.ok(description)
@@ -151,7 +170,10 @@ def check_vaultenv_result(
 
 def run_vault_server() -> subprocess.Popen:
     """
-    Run the Vault dev server and seed it with a known set of secrets.
+    Run the Vault dev server and seed it with the same set of secrets as in
+    test_integration.sh.
+
+    Return a handle to the Vault server process.
     """
     env = {
         "VAULT_TOKEN": "integration",

From 10c2959e98d6689c9e227888853e7ae49d725d40 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Wed, 19 Feb 2020 11:39:12 +0100
Subject: [PATCH 16/18] Move retrying of secret fetching to requestSecret

---
 app/Main.hs | 119 +++++++++++++++++++++++++---------------------------
 1 file changed, 58 insertions(+), 61 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index e50211c..9ad5699 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -173,6 +173,21 @@ data VaultError
   | Unspecified Int LBS.ByteString
   deriving Show
 
+-- | "Handle" a HttpException by wrapping it in a Left VaultError.
+-- We also edit the Request contained in the exception to remove the
+-- Vault token, as it would otherwise get printed to stderr if we error
+-- out.
+httpErrorHandler :: HttpException -> IO (Either VaultError b)
+httpErrorHandler (e :: HttpException) = case e of
+  (HttpExceptionRequest request reason) ->
+    let sanitizedRequest = sanitizeRequest request
+    in pure $ Left $ ServerUnreachable (HttpExceptionRequest sanitizedRequest reason)
+  (InvalidUrlException url _reason) -> pure $ Left $ InvalidUrl url
+
+  where
+    sanitizeRequest :: Request -> Request
+    sanitizeRequest = setRequestHeader "x-vault-token" ["**removed**"]
+
 -- | Retry configuration to use for network requests to Vault.
 -- We use a limited exponential backoff with the policy
 -- fullJitterBackoff that comes with the Retry package.
@@ -184,6 +199,39 @@ vaultRetryPolicy opts = Retry.fullJitterBackoff (unMilliSeconds
                           getOptionsValue oRetryAttempts opts
                         )
 
+-- | Perform the given action according to our retry policy.
+doWithRetries :: Retry.RetryPolicyM IO -> (Retry.RetryStatus -> IO (Either VaultError a)) -> IO (Either VaultError a)
+doWithRetries retryPolicy = Retry.retrying retryPolicy isRetryableFailure
+  where
+    -- | Indicator function for retrying to retry on VaultErrors (Lefts) that
+    -- shouldRetry thinks we should retry on. Needs to be in IO because the
+    -- actions to perform are in IO as well.
+    isRetryableFailure :: Retry.RetryStatus -> Either VaultError a -> IO Bool
+    isRetryableFailure _retryStatus (Right _) = pure False
+    isRetryableFailure retryStatus (Left err) = shouldRetry retryStatus err
+
+    -- | Determine whether a request that resulted in the given VaultError
+    -- should be retried.
+    shouldRetry :: Applicative f => Retry.RetryStatus -> VaultError -> f Bool
+    shouldRetry _retryStatus res = pure $ case res of
+      ServerError _ -> True
+      ServerUnavailable _ -> True
+      ServerUnreachable _ -> True
+      Unspecified _ _ -> True
+      BadJSONResp _ -> True
+
+      -- Errors where we don't retry
+      BadRequest _ -> False
+      Forbidden -> False
+      InvalidUrl _ -> False
+      SecretNotFound _ -> False
+
+      -- Errors that cannot occur at this point, but we list for
+      -- exhaustiveness checking.
+      KeyNotFound _ -> False
+      DuplicateVar _ -> False
+      SecretFileError _ -> False
+
 --
 -- IO
 --
@@ -243,7 +291,7 @@ getHttpManager opts = newManager managerSettings
 -- Signals failure through a value of type VaultError.
 vaultEnv :: Context -> IO (Either VaultError [EnvVar])
 vaultEnv context = do
-  mountInfo <- doWithRetries getMountInfo
+  mountInfo <- doWithRetries retryPolicy getMountInfo
   case mountInfo of
     Left vaultError -> pure $ Left vaultError
     Right mountInfo' -> do
@@ -251,53 +299,16 @@ vaultEnv context = do
       case secrets of
         Left sfError -> pure $ Left $ SecretFileError sfError
         Right secrets' -> do
-          -- NOTE: This retries fetching all the secrets if fetching one of the
-          -- secrets fails due to an error we should retry on. We would ideally
-          -- keep the secrets that were successfully fetched in memory and only
-          -- retry getting the ones we couldn't get yet, as this makes it less
-          -- likely to get a 'thundering herd' of Vaultenv processes all trying
-          -- and failing to get all of their secrets.
-          -- This would then need to happen in requestSecrets, but I don't want
-          -- to touch that right now.
-          -- Issue: https://github.com/channable/vaultenv/issues/90
-          secretEnv <- doWithRetries (getSecrets mountInfo' secrets')
+          secretEnv <- requestSecrets context mountInfo' secrets'
           case secretEnv of
             Left vaultError -> pure $ Left vaultError
             Right secretEnv' -> pure $ checkNoDuplicates (buildEnv secretEnv')
     where
-      doWithRetries :: (Retry.RetryStatus -> IO (Either VaultError a)) -> IO (Either VaultError a)
-      doWithRetries = Retry.retrying retryPolicy isRetryableFailure
-
-      -- | Indicator function for retrying to retry on VaultErrors (Lefts) that
-      -- shouldRetry thinks we should retry on. Needs to be in IO because the
-      -- actions to perform are in IO as well.
-      isRetryableFailure :: Retry.RetryStatus -> Either VaultError a -> IO Bool
-      isRetryableFailure _retryStatus (Right _) = pure False
-      isRetryableFailure retryStatus (Left err) = shouldRetry retryStatus err
-
       retryPolicy = vaultRetryPolicy (cCliOptions context)
 
       getMountInfo :: Retry.RetryStatus -> IO (Either VaultError MountInfo)
       getMountInfo _retryStatus = catch (requestMountInfo context) httpErrorHandler
 
-      getSecrets :: MountInfo -> [Secret] -> Retry.RetryStatus -> IO (Either VaultError [EnvVar])
-      getSecrets mountInfo secrets _retryStatus = catch (requestSecrets context mountInfo secrets) httpErrorHandler
-
-      -- | "Handle" a HttpException by wrapping it in a Left VaultError.
-      -- We also edit the Request contained in the exception to remove the
-      -- Vault token, as it would otherwise get printed to stderr if we error
-      -- out.
-      httpErrorHandler :: HttpException -> IO (Either VaultError b)
-      httpErrorHandler (e :: HttpException) = case e of
-        (HttpExceptionRequest request reason) ->
-          let sanitizedRequest = sanitizeRequest request
-          in pure $ Left $ ServerUnreachable (HttpExceptionRequest sanitizedRequest reason)
-        (InvalidUrlException url _reason) -> pure $ Left $ InvalidUrl url
-
-        where
-          sanitizeRequest :: Request -> Request
-          sanitizeRequest = setRequestHeader "x-vault-token" ["**removed**"]
-
       secretFile = getOptionsValue oSecretFile (cCliOptions context)
 
       -- | Check that the given list of EnvVars contains no duplicate
@@ -378,10 +389,14 @@ requestMountInfo context =
       Right result -> pure $ Right result
 
 -- | Request all the data associated with a secret from the vault.
+--
+-- This function automatically retries the request if it fails according to the
+-- retryPolicy set in the given context.
 requestSecret :: Context -> String -> IO (Either VaultError VaultData)
 requestSecret context secretPath =
   let
     cliOptions = cCliOptions context
+    retryPolicy = vaultRetryPolicy (cCliOptions context)
     request
         = setRequestManager
             (cHttpManager context)
@@ -392,29 +407,11 @@ requestSecret context secretPath =
         $ setRequestSecure  (getOptionsValue oConnectTls cliOptions)
         $ defaultRequest
 
+    getSecret :: Retry.RetryStatus -> IO (Either VaultError VaultData)
+    getSecret _retryStatus = catch (doRequest secretPath request) httpErrorHandler
+
   in
-    doRequest secretPath request
-
--- | Determine whether a request that resulted in the given VaultError should be retried.
-shouldRetry :: Applicative f => Retry.RetryStatus -> VaultError -> f Bool
-shouldRetry _retryStatus res = pure $ case res of
-  ServerError _ -> True
-  ServerUnavailable _ -> True
-  ServerUnreachable _ -> True
-  Unspecified _ _ -> True
-  BadJSONResp _ -> True
-
-  -- Errors where we don't retry
-  BadRequest _ -> False
-  Forbidden -> False
-  InvalidUrl _ -> False
-  SecretNotFound _ -> False
-
-  -- Errors that cannot occur at this point, but we list for
-  -- exhaustiveness checking.
-  KeyNotFound _ -> False
-  DuplicateVar _ -> False
-  SecretFileError _ -> False
+    doWithRetries retryPolicy getSecret
 
 -- | Request all the supplied secrets from the vault, but just once, even if
 -- multiple keys are specified for a single secret. This is an optimization in

From e663371291a7bfa439ab65c28ac1ddf20ee1e9b2 Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Wed, 19 Feb 2020 13:48:34 +0100
Subject: [PATCH 17/18] Merge shouldRetry into isRetryableFailure

---
 app/Main.hs | 7 +------
 1 file changed, 1 insertion(+), 6 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 9ad5699..cd65a8f 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -208,12 +208,7 @@ doWithRetries retryPolicy = Retry.retrying retryPolicy isRetryableFailure
     -- actions to perform are in IO as well.
     isRetryableFailure :: Retry.RetryStatus -> Either VaultError a -> IO Bool
     isRetryableFailure _retryStatus (Right _) = pure False
-    isRetryableFailure retryStatus (Left err) = shouldRetry retryStatus err
-
-    -- | Determine whether a request that resulted in the given VaultError
-    -- should be retried.
-    shouldRetry :: Applicative f => Retry.RetryStatus -> VaultError -> f Bool
-    shouldRetry _retryStatus res = pure $ case res of
+    isRetryableFailure _retryStatus (Left err) = pure $ case err of
       ServerError _ -> True
       ServerUnavailable _ -> True
       ServerUnreachable _ -> True

From ebd8ff52db98f69d6b143b99fedffa6e3ad5283c Mon Sep 17 00:00:00 2001
From: Maarten van den Berg <maarten@channable.com>
Date: Wed, 19 Feb 2020 13:48:52 +0100
Subject: [PATCH 18/18] Use LambdaCase to eliminate single-use names in pattern
 match

---
 app/Main.hs | 17 +++++++----------
 1 file changed, 7 insertions(+), 10 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index cd65a8f..818e92f 100755
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -285,19 +285,16 @@ getHttpManager opts = newManager managerSettings
 --
 -- Signals failure through a value of type VaultError.
 vaultEnv :: Context -> IO (Either VaultError [EnvVar])
-vaultEnv context = do
-  mountInfo <- doWithRetries retryPolicy getMountInfo
-  case mountInfo of
+vaultEnv context =
+  doWithRetries retryPolicy getMountInfo >>= \case
     Left vaultError -> pure $ Left vaultError
-    Right mountInfo' -> do
-      secrets <- readSecretsFile secretFile
-      case secrets of
+    Right mountInfo ->
+      readSecretsFile secretFile >>= \case
         Left sfError -> pure $ Left $ SecretFileError sfError
-        Right secrets' -> do
-          secretEnv <- requestSecrets context mountInfo' secrets'
-          case secretEnv of
+        Right secrets ->
+          requestSecrets context mountInfo secrets >>= \case
             Left vaultError -> pure $ Left vaultError
-            Right secretEnv' -> pure $ checkNoDuplicates (buildEnv secretEnv')
+            Right secretEnv -> pure $ checkNoDuplicates (buildEnv secretEnv)
     where
       retryPolicy = vaultRetryPolicy (cCliOptions context)