{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

{-|

This module provides functions for introducing a mock SMTP server, represented by 'FakeSmtpServer'.

If you send emails to this server, you can read them out to confirm they were received correctly.

-}

module Test.Sandwich.Contexts.FakeSmtpServer (
  -- * Introduce a fake SMTP server
  introduceFakeSmtpServerNix
  , introduceFakeSmtpServerNix'
  , introduceFakeSmtpServer

  -- * Bracket-style version
  , withFakeSMTPServer

  -- * Nix derivation
  , fakeSmtpServerDerivation

  -- * Types
  , fakeSmtpServer
  , FakeSmtpServerOptions(..)
  , defaultFakeSmtpServerOptions
  , FakeSmtpServer(..)
  , EmailInfo(..)
  ) where

import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Retry
import qualified Data.Aeson as A
import qualified Data.Aeson.TH as A
import Data.String.Interpolate
import GHC.TypeLits
import Network.HTTP.Client
import Network.Socket (HostName, PortNumber)
import Relude
import System.FilePath
import System.IO
import System.Process
import Test.Sandwich
import Test.Sandwich.Contexts.FakeSmtpServer.Derivation
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.HttpWaits
import Test.Sandwich.Contexts.Nix
import Test.Sandwich.Contexts.Util.Aeson
import UnliftIO.Directory
import UnliftIO.Exception


-- * Types

data FakeSmtpServerOptions = FakeSmtpServerOptions {
  -- | Username and password. If not provided, the server will not be configured with authentication.
  FakeSmtpServerOptions -> Maybe (String, String)
fakeSmtpServerAuth :: Maybe (String, String)
  -- | Whether to allow insecure login.
  , FakeSmtpServerOptions -> Bool
fakeSmtpServerAllowInsecureLogin :: Bool
  } deriving (Int -> FakeSmtpServerOptions -> ShowS
[FakeSmtpServerOptions] -> ShowS
FakeSmtpServerOptions -> String
(Int -> FakeSmtpServerOptions -> ShowS)
-> (FakeSmtpServerOptions -> String)
-> ([FakeSmtpServerOptions] -> ShowS)
-> Show FakeSmtpServerOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FakeSmtpServerOptions -> ShowS
showsPrec :: Int -> FakeSmtpServerOptions -> ShowS
$cshow :: FakeSmtpServerOptions -> String
show :: FakeSmtpServerOptions -> String
$cshowList :: [FakeSmtpServerOptions] -> ShowS
showList :: [FakeSmtpServerOptions] -> ShowS
Show, FakeSmtpServerOptions -> FakeSmtpServerOptions -> Bool
(FakeSmtpServerOptions -> FakeSmtpServerOptions -> Bool)
-> (FakeSmtpServerOptions -> FakeSmtpServerOptions -> Bool)
-> Eq FakeSmtpServerOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FakeSmtpServerOptions -> FakeSmtpServerOptions -> Bool
== :: FakeSmtpServerOptions -> FakeSmtpServerOptions -> Bool
$c/= :: FakeSmtpServerOptions -> FakeSmtpServerOptions -> Bool
/= :: FakeSmtpServerOptions -> FakeSmtpServerOptions -> Bool
Eq)

defaultFakeSmtpServerOptions :: FakeSmtpServerOptions
defaultFakeSmtpServerOptions :: FakeSmtpServerOptions
defaultFakeSmtpServerOptions = FakeSmtpServerOptions {
  fakeSmtpServerAuth :: Maybe (String, String)
fakeSmtpServerAuth = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"user", String
"password")
  , fakeSmtpServerAllowInsecureLogin :: Bool
fakeSmtpServerAllowInsecureLogin = Bool
True
  }

-- | An email, as received by the server.
data EmailInfo = EmailInfo {
  EmailInfo -> Value
emailInfoAttachments :: A.Value
  , EmailInfo -> Text
emailInfoText :: Text
  , EmailInfo -> Text
emailInfoTextAsHtml :: Text
  , EmailInfo -> Text
emailInfoSubject :: Text
  , EmailInfo -> Maybe Text
emailInfoDate :: Maybe Text
  , EmailInfo -> Value
emailInfoTo :: A.Value
  , EmailInfo -> Value
emailInfoFrom :: A.Value
  , EmailInfo -> Maybe Text
emailInfoMessageId :: Maybe Text
  , EmailInfo -> Text
emailInfoHtml :: Text
  } deriving (Int -> EmailInfo -> ShowS
[EmailInfo] -> ShowS
EmailInfo -> String
(Int -> EmailInfo -> ShowS)
-> (EmailInfo -> String)
-> ([EmailInfo] -> ShowS)
-> Show EmailInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EmailInfo -> ShowS
showsPrec :: Int -> EmailInfo -> ShowS
$cshow :: EmailInfo -> String
show :: EmailInfo -> String
$cshowList :: [EmailInfo] -> ShowS
showList :: [EmailInfo] -> ShowS
Show, EmailInfo -> EmailInfo -> Bool
(EmailInfo -> EmailInfo -> Bool)
-> (EmailInfo -> EmailInfo -> Bool) -> Eq EmailInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EmailInfo -> EmailInfo -> Bool
== :: EmailInfo -> EmailInfo -> Bool
$c/= :: EmailInfo -> EmailInfo -> Bool
/= :: EmailInfo -> EmailInfo -> Bool
Eq)
-- These Aeson options need to match the return values from fake_smtp_server
$(A.deriveJSON (A.defaultOptions { A.fieldLabelModifier = dropNAndCamelCase (length ("emailInfo" :: String)) }) ''EmailInfo)

data FakeSmtpServer = FakeSmtpServer {
  -- | The hostname of the fake SMTP server.
  FakeSmtpServer -> String
fakeSmtpServerHostname :: HostName
  -- | The port on which the fake SMTP server is running.
  , FakeSmtpServer -> PortNumber
fakeSmtpServerSmtpPort :: PortNumber
  -- | Callback to retrieve the emails the server has received.
  , FakeSmtpServer
-> forall (m :: * -> *).
   (MonadLoggerIO m, MonadUnliftIO m) =>
   m [EmailInfo]
fakeSmtpServerGetEmails :: forall m. (MonadLoggerIO m, MonadUnliftIO m) => m [EmailInfo]
  }

fakeSmtpServer :: Label "fakeSmtpServer" FakeSmtpServer
fakeSmtpServer :: Label "fakeSmtpServer" FakeSmtpServer
fakeSmtpServer = Label "fakeSmtpServer" FakeSmtpServer
forall {k} (l :: Symbol) (a :: k). Label l a
Label

-- * Functions

type BaseMonad context m = (HasBaseContext context, MonadUnliftIO m)

type FakeSmtpServerContext context =
  LabelValue "fakeSmtpServer" FakeSmtpServer
  :> LabelValue (AppendSymbol "file-" "fake-smtp-server") (EnvironmentFile "fake-smtp-server")
  :> context

-- | Introduce a fake SMTP server using a Nix derivation hardcoded into this package as 'fakeSmtpServerDerivation'.
introduceFakeSmtpServerNix :: (
  BaseMonad context m, HasNixContext context
  )
  -- | Options
  => FakeSmtpServerOptions
  -- | Child spec
  -> SpecFree (FakeSmtpServerContext context) m ()
  -- | Parent spec
  -> SpecFree context m ()
introduceFakeSmtpServerNix :: forall context (m :: * -> *).
(BaseMonad context m, HasNixContext context) =>
FakeSmtpServerOptions
-> SpecFree (FakeSmtpServerContext context) m ()
-> SpecFree context m ()
introduceFakeSmtpServerNix = Text
-> FakeSmtpServerOptions
-> SpecFree (FakeSmtpServerContext context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(BaseMonad context m, HasNixContext context) =>
Text
-> FakeSmtpServerOptions
-> SpecFree (FakeSmtpServerContext context) m ()
-> SpecFree context m ()
introduceFakeSmtpServerNix' Text
fakeSmtpServerDerivation

-- | Same as 'introduceFakeSmtpServerNix', but allows you to specify the derivation.
introduceFakeSmtpServerNix' :: (
  BaseMonad context m, HasNixContext context
  )
  -- | Nix derivation
  => Text
  -- | Options
  -> FakeSmtpServerOptions
  -- | Child spec
  -> SpecFree (FakeSmtpServerContext context) m ()
  -- | Parent spec
  -> SpecFree context m ()
introduceFakeSmtpServerNix' :: forall context (m :: * -> *).
(BaseMonad context m, HasNixContext context) =>
Text
-> FakeSmtpServerOptions
-> SpecFree (FakeSmtpServerContext context) m ()
-> SpecFree context m ()
introduceFakeSmtpServerNix' Text
derivation FakeSmtpServerOptions
options =
  forall (a :: Symbol) context (m :: * -> *).
(HasBaseContext context, HasNixContext context, MonadUnliftIO m,
 KnownSymbol a) =>
Text
-> SpecFree
     (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a)
      :> context)
     m
     ()
-> SpecFree context m ()
introduceBinaryViaNixDerivation @"fake-smtp-server" Text
derivation (Free
   (SpecCommand
      (LabelValue
         "file-fake-smtp-server" (EnvironmentFile "fake-smtp-server")
       :> context)
      m)
   ()
 -> SpecFree context m ())
-> (SpecFree
      (LabelValue "fakeSmtpServer" FakeSmtpServer
       :> (LabelValue
             "file-fake-smtp-server" (EnvironmentFile "fake-smtp-server")
           :> context))
      m
      ()
    -> Free
         (SpecCommand
            (LabelValue
               "file-fake-smtp-server" (EnvironmentFile "fake-smtp-server")
             :> context)
            m)
         ())
-> SpecFree
     (LabelValue "fakeSmtpServer" FakeSmtpServer
      :> (LabelValue
            "file-fake-smtp-server" (EnvironmentFile "fake-smtp-server")
          :> context))
     m
     ()
-> SpecFree context m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FakeSmtpServerOptions
-> SpecFree
     (LabelValue "fakeSmtpServer" FakeSmtpServer
      :> (LabelValue
            "file-fake-smtp-server" (EnvironmentFile "fake-smtp-server")
          :> context))
     m
     ()
-> Free
     (SpecCommand
        (LabelValue
           "file-fake-smtp-server" (EnvironmentFile "fake-smtp-server")
         :> context)
        m)
     ()
forall context (m :: * -> *).
(BaseMonad context m, HasFile context "fake-smtp-server") =>
FakeSmtpServerOptions
-> SpecFree
     (LabelValue "fakeSmtpServer" FakeSmtpServer :> context) m ()
-> SpecFree context m ()
introduceFakeSmtpServer FakeSmtpServerOptions
options

-- | Introduce a fake SMTP server given a binary already available via 'HasFile'.
introduceFakeSmtpServer :: (
  BaseMonad context m, HasFile context "fake-smtp-server"
  )
  -- | Options
  => FakeSmtpServerOptions
  -> SpecFree (LabelValue "fakeSmtpServer" FakeSmtpServer :> context) m ()
  -> SpecFree context m ()
introduceFakeSmtpServer :: forall context (m :: * -> *).
(BaseMonad context m, HasFile context "fake-smtp-server") =>
FakeSmtpServerOptions
-> SpecFree
     (LabelValue "fakeSmtpServer" FakeSmtpServer :> context) m ()
-> SpecFree context m ()
introduceFakeSmtpServer FakeSmtpServerOptions
options = String
-> Label "fakeSmtpServer" FakeSmtpServer
-> ((HasCallStack => FakeSmtpServer -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree
     (LabelValue "fakeSmtpServer" FakeSmtpServer :> context) m ()
-> SpecFree context m ()
forall (l :: Symbol) intro context (m :: * -> *).
HasCallStack =>
String
-> Label l intro
-> ((HasCallStack => intro -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduceWith String
"fake SMTP server" Label "fakeSmtpServer" FakeSmtpServer
fakeSmtpServer (FakeSmtpServerOptions
-> (FakeSmtpServer -> ExampleT context m [Result])
-> ExampleT context m ()
forall context (m :: * -> *).
(BaseMonad context m, MonadReader context m, MonadLoggerIO m,
 HasFile context "fake-smtp-server") =>
FakeSmtpServerOptions -> (FakeSmtpServer -> m [Result]) -> m ()
withFakeSMTPServer FakeSmtpServerOptions
options)

-- | Bracket-style version of 'introduceFakeSmtpServer'.
withFakeSMTPServer :: (
  BaseMonad context m, MonadReader context m, MonadLoggerIO m, HasFile context "fake-smtp-server"
  )
  -- | Options
  => FakeSmtpServerOptions
  -> (FakeSmtpServer -> m [Result])
  -> m ()
withFakeSMTPServer :: forall context (m :: * -> *).
(BaseMonad context m, MonadReader context m, MonadLoggerIO m,
 HasFile context "fake-smtp-server") =>
FakeSmtpServerOptions -> (FakeSmtpServer -> m [Result]) -> m ()
withFakeSMTPServer (FakeSmtpServerOptions {Bool
Maybe (String, String)
fakeSmtpServerAuth :: FakeSmtpServerOptions -> Maybe (String, String)
fakeSmtpServerAllowInsecureLogin :: FakeSmtpServerOptions -> Bool
fakeSmtpServerAuth :: Maybe (String, String)
fakeSmtpServerAllowInsecureLogin :: Bool
..}) FakeSmtpServer -> m [Result]
action = do
  String
folder <- m (Maybe String)
forall context (m :: * -> *).
HasBaseContextMonad context m =>
m (Maybe String)
getCurrentFolder m (Maybe String) -> (Maybe String -> m String) -> m String
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> String -> m String
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure String
"withFakeSMTPServer must be run with a run root"
    Just String
x -> String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
x

  let httpPortFile :: String
httpPortFile = String
folder String -> ShowS
</> String
"http-port-file"
  let smtpPortFile :: String
smtpPortFile = String
folder String -> ShowS
</> String
"smtp-port-file"

  String
fakeSmtpServerPath <- forall (a :: Symbol) context (m :: * -> *).
(MonadReader context m, HasFile context a) =>
m String
askFile @"fake-smtp-server"

  m ProcessHandle
-> (ProcessHandle -> m ()) -> (ProcessHandle -> m ()) -> m ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (do
              let authFlag :: [String]
authFlag = case Maybe (String, String)
fakeSmtpServerAuth of
                    Just (String
username, String
password) -> [String
"--auth",  [i|#{username}:#{password}|]]
                    Maybe (String, String)
Nothing -> []
              let insecureLoginFlag :: String
insecureLoginFlag = if Bool
fakeSmtpServerAllowInsecureLogin then String
"--allow-insecure-login" else String
""
              CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging ((String -> [String] -> CreateProcess
proc String
fakeSmtpServerPath ([String
insecureLoginFlag
                                                                  , String
"--smtp-port", String
"0"
                                                                  , String
"--smtp-port-file", String
smtpPortFile
                                                                  , String
"--http-port", String
"0"
                                                                  , String
"--http-port-file", String
httpPortFile
                                                                  ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
authFlag)) {
                                           create_group = True
                                           })
          )
          (\ProcessHandle
p -> do
              m ExitCode -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ExitCode -> m ()) -> m ExitCode -> m ()
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> m ExitCode
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
p IO () -> IO ExitCode -> IO ExitCode
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p)
          )
          (\ProcessHandle
_ -> do
              let hostname :: String
hostname = String
"localhost"
              PortNumber
httpPort <- Double -> String -> m PortNumber
forall (m :: * -> *).
MonadLoggerIO m =>
Double -> String -> m PortNumber
waitForPortFile Double
120.0 String
httpPortFile
              PortNumber
smtpPort <- Double -> String -> m PortNumber
forall (m :: * -> *).
MonadLoggerIO m =>
Double -> String -> m PortNumber
waitForPortFile Double
120.0 String
smtpPortFile

              let authPart :: Text
authPart = case Maybe (String, String)
fakeSmtpServerAuth of
                    Just (String
username, String
password) -> [i|#{username}:#{password}@|] :: Text
                    Maybe (String, String)
Nothing -> Text
""

              (Int, Int, Int) -> Int -> VerifyCerts -> String -> m ()
forall (m :: * -> *).
WaitConstraints m =>
(Int, Int, Int) -> Int -> VerifyCerts -> String -> m ()
waitUntilStatusCodeWithTimeout (Int
2, Int
0, Int
0) (Int
1_000_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) VerifyCerts
YesVerify [i|http://#{authPart}#{hostname}:#{httpPort}/api/emails|]

              Manager
manager <- IO Manager -> m Manager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
              m [Result] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [Result] -> m ()) -> m [Result] -> m ()
forall a b. (a -> b) -> a -> b
$ FakeSmtpServer -> m [Result]
action (FakeSmtpServer -> m [Result]) -> FakeSmtpServer -> m [Result]
forall a b. (a -> b) -> a -> b
$ FakeSmtpServer {
                fakeSmtpServerHostname :: String
fakeSmtpServerHostname = String
hostname
                , fakeSmtpServerSmtpPort :: PortNumber
fakeSmtpServerSmtpPort = PortNumber
smtpPort
                , fakeSmtpServerGetEmails :: forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
m [EmailInfo]
fakeSmtpServerGetEmails = Manager -> Text -> PortNumber -> m [EmailInfo]
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
Manager -> Text -> PortNumber -> m [EmailInfo]
getEmails Manager
manager Text
authPart PortNumber
httpPort
                }
          )


waitForPortFile :: (MonadLoggerIO m) => Double -> FilePath -> m PortNumber
waitForPortFile :: forall (m :: * -> *).
MonadLoggerIO m =>
Double -> String -> m PortNumber
waitForPortFile Double
timeoutSeconds String
path = do
  let policy :: RetryPolicyM IO
policy = Int -> RetryPolicyM IO -> RetryPolicyM IO
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
timeoutSeconds Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1_000_000)) (RetryPolicyM IO -> RetryPolicyM IO)
-> RetryPolicyM IO -> RetryPolicyM IO
forall a b. (a -> b) -> a -> b
$ Int -> RetryPolicyM IO -> RetryPolicyM IO
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay Int
1_000_000 (RetryPolicyM IO -> RetryPolicyM IO)
-> RetryPolicyM IO -> RetryPolicyM IO
forall a b. (a -> b) -> a -> b
$ Int -> RetryPolicyM IO
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
exponentialBackoff Int
1000
  IO PortNumber -> m PortNumber
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PortNumber -> m PortNumber) -> IO PortNumber -> m PortNumber
forall a b. (a -> b) -> a -> b
$ RetryPolicyM IO -> (RetryStatus -> IO PortNumber) -> IO PortNumber
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll RetryPolicyM IO
policy ((RetryStatus -> IO PortNumber) -> IO PortNumber)
-> (RetryStatus -> IO PortNumber) -> IO PortNumber
forall a b. (a -> b) -> a -> b
$ \(RetryStatus {}) -> do
    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesPathExist String
path) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Port file '#{path}' didn't exist yet.|]

    String
contents <- String -> IO String
System.IO.readFile String
path
    case String -> Maybe PortNumber
forall a. Read a => String -> Maybe a
readMaybe String
contents of
      Maybe PortNumber
Nothing -> String -> IO PortNumber
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Couldn't read port number: '#{contents}'|]
      Just PortNumber
n -> PortNumber -> IO PortNumber
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PortNumber
n

getEmails :: (
  MonadLoggerIO m, MonadUnliftIO m
  ) => Manager -> Text -> PortNumber -> m [EmailInfo]
getEmails :: forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
Manager -> Text -> PortNumber -> m [EmailInfo]
getEmails Manager
manager Text
authPart PortNumber
httpPort = do
  Request
req <- IO Request -> m Request
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest [i|http://#{authPart}localhost:#{httpPort}/api/emails|]
  m (Response ByteString)
-> m (Either HttpException (Response ByteString))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO (Response ByteString) -> m (Response ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
manager) m (Either HttpException (Response ByteString))
-> (Either HttpException (Response ByteString) -> m [EmailInfo])
-> m [EmailInfo]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (HttpException
err :: HttpException) -> String -> m [EmailInfo]
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Failed to fetch emails: #{err}|]
    Right Response ByteString
response ->
      case ByteString -> Either String [EmailInfo]
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response) of
        Left String
err -> String -> m [EmailInfo]
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Couldn't decode emails: '#{err}'. Response body  '#{responseBody response}'. Response: '#{response}'.|]
        Right ([EmailInfo]
emails :: [EmailInfo]) -> [EmailInfo] -> m [EmailInfo]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [EmailInfo]
emails