Added callstacks to exceptions thrown during config

Fixes #1503

Instead of:
```
RunProdServer: MErrVMissingCredentials
```

We now get:
```
*** Exception: MErrVMissingCredentials
CallStack (from HasCallStack):
  ConfigException, called at IHP/IHP/FrameworkConfig.hs:570:38 in main:IHP.FrameworkConfig
  configIO, called at IHP/IHP/FileStorage/Config.hs:75:12 in main:IHP.FileStorage.Config
  initMinioStorage, called at Config/Config.hs:18:5 in main:Config
```

IHP/FileStorage/Config.hs

@@ -39,12 +39,12 @@ import Control.Monad.Trans.Maybe
 -- >     option (AppHostname "localhost")
 -- >     initS3Storage "eu-central-1" "my-bucket-name"
 --
-initS3Storage :: Text -> Text -> State.StateT TMap.TMap IO ()
+initS3Storage :: HasCallStack => Text -> Text -> State.StateT TMap.TMap IO ()
 initS3Storage region bucket = do
     connectInfo <- awsCI
         |> setRegion region
         |> setCredsFrom [fromAWSEnv]
-        |> liftIO
+        |> configIO
 
     let baseUrl = "https://" <> bucket <> ".s3." <> region <> ".amazonaws.com/"
     option S3Storage { connectInfo, bucket, baseUrl }
@@ -66,13 +66,13 @@ initS3Storage region bucket = do
 -- >     option (AppHostname "localhost")
 -- >     initMinioStorage "https://minio.example.com" "my-bucket-name"
 --
-initMinioStorage :: Text -> Text -> State.StateT TMap.TMap IO ()
+initMinioStorage :: HasCallStack => Text -> Text -> State.StateT TMap.TMap IO ()
 initMinioStorage server bucket = do
     connectInfo <- server
         |> cs
         |> fromString
         |> setCredsFrom [fromMinioEnv]
-        |> liftIO
+        |> configIO
 
     let baseUrl = server <> "/" <> bucket <> "/"
     option S3Storage { connectInfo, bucket, baseUrl }
@@ -114,11 +114,11 @@ initStaticDirStorage = option StaticDirStorage
 -- >     option (AppHostname "localhost")
 -- >     initFilebaseStorage "my-bucket-name"
 --
-initFilebaseStorage :: Text -> State.StateT TMap.TMap IO ()
+initFilebaseStorage :: HasCallStack => Text -> State.StateT TMap.TMap IO ()
 initFilebaseStorage bucket = do
     connectInfo <- filebaseCI
         |> setCredsFrom [fromFilebaseEnv]
-        |> liftIO
+        |> configIO
 
     let baseUrl = "https://" <> bucket <> ".s3.filebase.com/"
     option S3Storage { connectInfo, bucket, baseUrl }

IHP/FrameworkConfig.hs

@@ -23,6 +23,9 @@ import Data.String.Interpolate.IsString (i)
 import qualified Control.Exception as Exception
 import IHP.ModelSupport
 
+import qualified Prelude
+import qualified GHC.Stack as Stack
+
 newtype AppHostname = AppHostname Text
 newtype AppPort = AppPort Int
 newtype BaseUrl = BaseUrl Text
@@ -104,13 +107,13 @@ ihpDefaultConfig = do
 
     environment <- findOption @Environment
 
-    defaultLogger <- liftIO (defaultLoggerForEnv environment)
+    defaultLogger <- configIO (defaultLoggerForEnv environment)
     option defaultLogger
     logger <- findOption @Logger
 
     requestLoggerIpAddrSource <- envOrDefault "IHP_REQUEST_LOGGER_IP_ADDR_SOURCE" RequestLogger.FromSocket
 
-    reqLoggerMiddleware <- liftIO $
+    reqLoggerMiddleware <- configIO $
             case environment of
                 Development -> do
                                     reqLogger <- (logger |> defaultRequestLogger)
@@ -126,7 +129,7 @@ ihpDefaultConfig = do
 
     option $ Sendmail
 
-    databaseUrl <- liftIO defaultDatabaseUrl
+    databaseUrl <- configIO defaultDatabaseUrl
 
     option $ DatabaseUrl databaseUrl
     option $ DBPoolIdleTime $
@@ -207,7 +210,7 @@ envOrDefault :: (MonadIO monad) => EnvVarReader result => ByteString -> result -
 envOrDefault name defaultValue = fromMaybe defaultValue <$> envOrNothing name
 
 envOrNothing :: (MonadIO monad) => EnvVarReader result => ByteString -> monad (Maybe result)
-envOrNothing name = liftIO $ fmap parseString <$> Posix.getEnv name
+envOrNothing name = configIO $ fmap parseString <$> Posix.getEnv name
     where
         parseString string = case envStringToValue string of
             Left errorMessage -> error [i|Env var '#{name}' is invalid: #{errorMessage}|]
@@ -486,13 +489,13 @@ data RootApplication = RootApplication deriving (Eq, Show)
 defaultPort :: Int
 defaultPort = 8000
 
-defaultDatabaseUrl :: IO ByteString
+defaultDatabaseUrl :: HasCallStack => IO ByteString
 defaultDatabaseUrl = do
     currentDirectory <- getCurrentDirectory
     let defaultDatabaseUrl = "postgresql:///app?host=" <> cs currentDirectory <> "/build/db"
     envOrDefault "DATABASE_URL" defaultDatabaseUrl
 
-defaultLoggerForEnv :: Environment -> IO Logger
+defaultLoggerForEnv :: HasCallStack => Environment -> IO Logger
 defaultLoggerForEnv = \case
     Development -> defaultLogger
     Production -> newLogger def { level = Info }
@@ -541,3 +544,27 @@ initModelContext FrameworkConfig { environment, dbPoolIdleTime, dbPoolMaxConnect
     modelContext <- createModelContext dbPoolIdleTime dbPoolMaxConnections databaseUrl logger
     pure modelContext
 
+-- | Wraps an Exception thrown during the config process, but adds a CallStack
+--
+-- Inspired by https://maksbotan.github.io/posts/2021-01-20-callstacks.html
+--
+data ConfigException where
+    ConfigException :: HasCallStack => SomeException -> ConfigException
+
+instance Prelude.Show ConfigException where
+    show (ConfigException inner) = Prelude.show inner <> "\n" <> Stack.prettyCallStack Stack.callStack
+
+instance Exception ConfigException
+
+-- | Runs IO inside the config process
+--
+-- It works like 'liftIO', but attaches a CallStack on error. Without this it would be hard to see where
+-- an error during the config setup comes from.
+--
+-- All call-sites of this function should also have a @HasCallStack@ constraint to provide helpful information in the call stack.
+--
+-- See /~https://github.com/digitallyinduced/ihp/issues/1503
+configIO :: (MonadIO monad, HasCallStack) => IO result -> monad result
+configIO action = liftIO (action `catch` catcher)
+    where
+        catcher exception = throwIO (ConfigException exception)

IHP/Prelude.hs

@@ -40,6 +40,7 @@ module IHP.Prelude
 , module Control.Monad.Fail
 , module Control.Concurrent.Async
 , module NeatInterpolation
+, module GHC.Stack
 )
 where
 
@@ -75,6 +76,7 @@ import Control.Exception (throw, throwIO, catch)
 import Control.Monad.Fail (fail)
 import Control.Concurrent.Async
 import NeatInterpolation (trimming)
+import GHC.Stack (HasCallStack, CallStack)
 
 -- Alias for haskell newcomers :)
 a ++ b = a <> b