{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Mail (testMail, Mail (..), MailSettings (..), sendMailTo, sendMailTo') where

import Data.Aeson (KeyValue ((.=)), ToJSON (toJSON))
import qualified Data.Aeson as Aeson
import Data.Functor ((<&>))
import Data.Text (Text)
import qualified Data.Text as Text
import Database (getConnection)
import Docs (logMessage)
import Docs.Hasql.Database (run)
import GHC.Generics (Generic)
import qualified Logging.Logs as Logs
import qualified Logging.Scope as Scope
import Network.Mail.Mime (Part, htmlPart, plainPart)
import Network.Mail.SMTP
    ( Address (Address)
    , sendMailWithLoginSTARTTLS'
    , simpleMail
    )
import Network.Socket (PortNumber)
import Parse (nonEmptyString, nonEmptyText)
import System.Environment (getEnv)

data Error
    = InvalidMailSettings MailSettings
    | ErrorSendingMail MailSettings Mail
    deriving ((forall x. Error -> Rep Error x)
-> (forall x. Rep Error x -> Error) -> Generic Error
forall x. Rep Error x -> Error
forall x. Error -> Rep Error x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Error -> Rep Error x
from :: forall x. Error -> Rep Error x
$cto :: forall x. Rep Error x -> Error
to :: forall x. Rep Error x -> Error
Generic)

instance ToJSON Error

data MailSettings = MailSettings
    { MailSettings -> String
host :: String
    , MailSettings -> PortNumber
port :: PortNumber
    , MailSettings -> String
username :: String
    , MailSettings -> Text
address :: Text
    , MailSettings -> String
password :: String
    }
    deriving (Int -> MailSettings -> ShowS
[MailSettings] -> ShowS
MailSettings -> String
(Int -> MailSettings -> ShowS)
-> (MailSettings -> String)
-> ([MailSettings] -> ShowS)
-> Show MailSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MailSettings -> ShowS
showsPrec :: Int -> MailSettings -> ShowS
$cshow :: MailSettings -> String
show :: MailSettings -> String
$cshowList :: [MailSettings] -> ShowS
showList :: [MailSettings] -> ShowS
Show)

instance ToJSON MailSettings where
    toJSON :: MailSettings -> Value
toJSON (MailSettings {String
Text
PortNumber
host :: MailSettings -> String
port :: MailSettings -> PortNumber
username :: MailSettings -> String
address :: MailSettings -> Text
password :: MailSettings -> String
host :: String
port :: PortNumber
username :: String
address :: Text
password :: String
..}) =
        [Pair] -> Value
Aeson.object
            [ Key
"host" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
host
            , Key
"port" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port
            , Key
"username" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
username
            , Key
"address" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
address
            , Key
"password" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Char
'*' Char -> ShowS
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String
password)
            ]

data Mail = Mail
    { Mail -> Address
receiver :: Address
    , Mail -> Text
subject :: Text
    , Mail -> [Part]
body :: [Part]
    }
    deriving (Int -> Mail -> ShowS
[Mail] -> ShowS
Mail -> String
(Int -> Mail -> ShowS)
-> (Mail -> String) -> ([Mail] -> ShowS) -> Show Mail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mail -> ShowS
showsPrec :: Int -> Mail -> ShowS
$cshow :: Mail -> String
show :: Mail -> String
$cshowList :: [Mail] -> ShowS
showList :: [Mail] -> ShowS
Show)

instance ToJSON Mail where
    toJSON :: Mail -> Value
toJSON (Mail {[Part]
Text
Address
receiver :: Mail -> Address
subject :: Mail -> Text
body :: Mail -> [Part]
receiver :: Address
subject :: Text
body :: [Part]
..}) =
        [Pair] -> Value
Aeson.object
            [ Key
"receiver" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Address -> String
forall a. Show a => a -> String
show Address
receiver
            , Key
"subject" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
subject
            , Key
"body" Key -> [String] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Part -> String
forall a. Show a => a -> String
show (Part -> String) -> [Part] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Part]
body)
            ]

-- | An IO action to send a testmail to a test mail address.
testMail :: IO ()
testMail :: IO ()
testMail =
    Mail -> IO ()
sendMailTo
        Mail
            { receiver :: Address
receiver = Maybe Text -> Text -> Address
Address (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Fick Anyhow") Text
"finn.evers@outlook.de"
            , subject :: Text
subject = Text
"Hallo, kennen Sie thiserror?"
            , body :: [Part]
body = [Text -> Part
plainPart Text
"email body", Text -> Part
htmlPart Text
"<h1>HTML</h1>"]
            }

-- | Sends the given mail. If the mail settings are invalid, an error will be logged in the database.
sendMailTo :: Mail -> IO ()
sendMailTo :: Mail -> IO ()
sendMailTo Mail
mail = do
    MailSettings
settings <- IO MailSettings
envSettings
    case MailSettings -> Maybe MailSettings
completeSettings MailSettings
settings of
        Just MailSettings
_ -> MailSettings -> Mail -> IO ()
sendMailTo' MailSettings
settings Mail
mail
        Maybe MailSettings
Nothing -> do
            Right Connection
db <- IO (Either ConnectionError Connection)
getConnection
            Either SessionError LogMessage
_ <-
                HasqlSession LogMessage
-> Connection -> IO (Either SessionError LogMessage)
forall a.
HasqlSession a -> Connection -> IO (Either SessionError a)
run
                    (Severity
-> Maybe UserID -> Scope -> Error -> HasqlSession LogMessage
forall (m :: * -> *) v.
(HasLogMessage m, ToJSON v) =>
Severity -> Maybe UserID -> Scope -> v -> m LogMessage
logMessage Severity
Logs.Error Maybe UserID
forall a. Maybe a
Nothing Scope
Scope.email (Error -> HasqlSession LogMessage)
-> Error -> HasqlSession LogMessage
forall a b. (a -> b) -> a -> b
$ MailSettings -> Error
InvalidMailSettings MailSettings
settings)
                    Connection
db
            () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Helper to send mails
sendMailTo' :: MailSettings -> Mail -> IO ()
sendMailTo' :: MailSettings -> Mail -> IO ()
sendMailTo' MailSettings
settings Mail
mail = do
    MailSettings -> IO ()
forall a. Show a => a -> IO ()
print MailSettings
settings
    Mail -> IO ()
forall a. Show a => a -> IO ()
print Mail
mail
    String -> PortNumber -> String -> String -> Mail -> IO ()
sendMailWithLoginSTARTTLS'
        (MailSettings -> String
host MailSettings
settings)
        (MailSettings -> PortNumber
port MailSettings
settings)
        (MailSettings -> String
username MailSettings
settings)
        (MailSettings -> String
password MailSettings
settings)
        Mail
mail'
  where
    from :: Address
from = Maybe Text -> Text -> Address
Address (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Der Fachprüfungsordner") (MailSettings -> Text
address MailSettings
settings)
    to :: [Address]
to = [Mail -> Address
receiver Mail
mail]
    -- body = plainPart "email body"
    -- html = htmlPart "<h1>HTML</h1>"
    mail' :: Mail
mail' = Address
-> [Address] -> [Address] -> [Address] -> Text -> [Part] -> Mail
simpleMail Address
from [Address]
to [] [] (Mail -> Text
subject Mail
mail) (Mail -> [Part]
body Mail
mail)

-- | Validates and checks the given setting to be non-empty
completeSettings :: MailSettings -> Maybe MailSettings
completeSettings :: MailSettings -> Maybe MailSettings
completeSettings x :: MailSettings
x@(MailSettings {String
Text
PortNumber
host :: MailSettings -> String
port :: MailSettings -> PortNumber
username :: MailSettings -> String
address :: MailSettings -> Text
password :: MailSettings -> String
host :: String
port :: PortNumber
username :: String
address :: Text
password :: String
..}) = do
    String
_ <- String -> Maybe String
nonEmptyString String
host
    Text
_ <- Text -> Maybe Text
nonEmptyText Text
address
    String
_ <- String -> Maybe String
nonEmptyString String
username
    String
_ <- String -> Maybe String
nonEmptyString String
password
    MailSettings -> Maybe MailSettings
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MailSettings
x

-- | Loads the mail settings from the environment by reading the associated environment
-- variables.
envSettings :: IO MailSettings
envSettings :: IO MailSettings
envSettings = do
    String
host' <- String -> IO String
getEnv String
"MAIL_HOST"
    PortNumber
port' <- String -> IO String
getEnv String
"MAIL_PORT" IO String -> (String -> PortNumber) -> IO PortNumber
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> PortNumber
forall a. Read a => String -> a
read
    String
address' <- String -> IO String
getEnv String
"MAIL_ADDRESS"
    String
username' <- String -> IO String
getEnv String
"MAIL_USERNAME"
    String
password' <- String -> IO String
getEnv String
"MAIL_PASSWORD"
    MailSettings -> IO MailSettings
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MailSettings -> IO MailSettings)
-> MailSettings -> IO MailSettings
forall a b. (a -> b) -> a -> b
$
        MailSettings
            { host :: String
host = String
host'
            , port :: PortNumber
port = PortNumber
port'
            , username :: String
username = String
username'
            , address :: Text
address = String -> Text
Text.pack String
address'
            , password :: String
password = String
password'
            }