content: {-# 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.
    fakeSmtpServerAuth :: Maybe (String, String)
    -- | Whether to allow insecure login.
    , fakeSmtpServerAllowInsecureLogin :: Bool
    } deriving (Show, Eq)
  
  defaultFakeSmtpServerOptions :: FakeSmtpServerOptions
  defaultFakeSmtpServerOptions = FakeSmtpServerOptions {
    fakeSmtpServerAuth = Just ("user", "password")
    , fakeSmtpServerAllowInsecureLogin = True
    }
  
  -- | An email, as received by the server.
  data EmailInfo = EmailInfo {
    emailInfoAttachments :: A.Value
    , emailInfoText :: Text
    , emailInfoTextAsHtml :: Text
    , emailInfoSubject :: Text
    , emailInfoDate :: Maybe Text
    , emailInfoTo :: A.Value
    , emailInfoFrom :: A.Value
    , emailInfoMessageId :: Maybe Text
    , emailInfoHtml :: Text
    } deriving (Show, 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.
    fakeSmtpServerHostname :: HostName
    -- | The port on which the fake SMTP server is running.
    , fakeSmtpServerSmtpPort :: PortNumber
    -- | Callback to retrieve the emails the server has received.
    , fakeSmtpServerGetEmails :: forall m. (MonadLoggerIO m, MonadUnliftIO m) => m [EmailInfo]
    }
  
  fakeSmtpServer :: Label "fakeSmtpServer" FakeSmtpServer
  fakeSmtpServer = 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 = introduceFakeSmtpServerNix' 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' derivation options =
    introduceBinaryViaNixDerivation @"fake-smtp-server" derivation . introduceFakeSmtpServer 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 options = introduceWith "fake SMTP server" fakeSmtpServer (withFakeSMTPServer 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 (FakeSmtpServerOptions {..}) action = do
    folder <- getCurrentFolder >>= \case
      Nothing -> expectationFailure "withFakeSMTPServer must be run with a run root"
      Just x -> return x
  
    let httpPortFile = folder </> "http-port-file"
    let smtpPortFile = folder </> "smtp-port-file"
  
    fakeSmtpServerPath <- askFile @"fake-smtp-server"
  
    bracket (do
                let authFlag = case fakeSmtpServerAuth of
                      Just (username, password) -> ["--auth",  [i|#{username}:#{password}|]]
                      Nothing -> []
                let insecureLoginFlag = if fakeSmtpServerAllowInsecureLogin then "--allow-insecure-login" else ""
                createProcessWithLogging ((proc fakeSmtpServerPath ([insecureLoginFlag
                                                                    , "--smtp-port", "0"
                                                                    , "--smtp-port-file", smtpPortFile
                                                                    , "--http-port", "0"
                                                                    , "--http-port-file", httpPortFile
                                                                    ] <> authFlag)) {
                                             create_group = True
                                             })
            )
            (\p -> do
                void $ liftIO (interruptProcessGroupOf p >> waitForProcess p)
            )
            (\_ -> do
                let hostname = "localhost"
                httpPort <- waitForPortFile 120.0 httpPortFile
                smtpPort <- waitForPortFile 120.0 smtpPortFile
  
                let authPart = case fakeSmtpServerAuth of
                      Just (username, password) -> [i|#{username}:#{password}@|] :: Text
                      Nothing -> ""
  
                waitUntilStatusCodeWithTimeout (2, 0, 0) (1_000_000 * 60 * 2) YesVerify [i|http://#{authPart}#{hostname}:#{httpPort}/api/emails|]
  
                manager <- liftIO $ newManager defaultManagerSettings
                void $ action $ FakeSmtpServer {
                  fakeSmtpServerHostname = hostname
                  , fakeSmtpServerSmtpPort = smtpPort
                  , fakeSmtpServerGetEmails = getEmails manager authPart httpPort
                  }
            )
  
  
  waitForPortFile :: (MonadLoggerIO m) => Double -> FilePath -> m PortNumber
  waitForPortFile timeoutSeconds path = do
    let policy = limitRetriesByCumulativeDelay (round (timeoutSeconds * 1_000_000)) $ capDelay 1_000_000 $ exponentialBackoff 1000
    liftIO $ recoverAll policy $ \(RetryStatus {}) -> do
      unlessM (doesPathExist path) $
        expectationFailure [i|Port file '#{path}' didn't exist yet.|]
  
      contents <- System.IO.readFile path
      case readMaybe contents of
        Nothing -> expectationFailure [i|Couldn't read port number: '#{contents}'|]
        Just n -> pure n
  
  getEmails :: (
    MonadLoggerIO m, MonadUnliftIO m
    ) => Manager -> Text -> PortNumber -> m [EmailInfo]
  getEmails manager authPart httpPort = do
    req <- liftIO $ parseRequest [i|http://#{authPart}localhost:#{httpPort}/api/emails|]
    try (liftIO $ httpLbs req manager) >>= \case
      Left (err :: HttpException) -> expectationFailure [i|Failed to fetch emails: #{err}|]
      Right response ->
        case A.eitherDecode (responseBody response) of
          Left err -> expectationFailure [i|Couldn't decode emails: '#{err}'. Response body  '#{responseBody response}'. Response: '#{response}'.|]
          Right (emails :: [EmailInfo]) -> return emails
  