aboutsummaryrefslogtreecommitdiff
path: root/src/executable/haskell/Service/MailService.hs
blob: a59dddf84500c891eafbc3db47ec8d12a23d0c6e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
module Service.MailService
  ( send
  ) where

import           Control.Arrow          (left)
import           Control.Exception      (SomeException, try)
import qualified Control.Logging        as Logging
import           Data.Text              (Text)
import qualified Data.Text              as T
import qualified Data.Text.Lazy         as LT
import           Data.Text.Lazy.Builder (fromText, toLazyText)
import qualified Network.Mail.Mime      as Mime

import           Model.Mail             (Mail)
import qualified Model.Mail             as Mail

send :: Bool -> Mail -> IO (Either Text ())
send isMock mail =
  if isMock then do
    Logging.log $ T.concat [ "MOCK sending mail ", T.pack . show $ mail ]
    return . Right $ ()
  else do
    result <-
      left (T.pack . show) <$>
        (try (Mime.renderSendMailCustom "sendmail" ["-t"] . getMimeMail $ mail) :: IO (Either SomeException ()))
    case result of
      Left err ->
        Logging.loggingLogger Logging.LevelError "" . T.concat $
          [ "Error sending the following email ("
          , T.pack . show $ mail
          , ":\n"
          , err
          ]
      Right _ ->
        return ()
    return result

getMimeMail :: Mail -> Mime.Mail
getMimeMail mail =
  let fromMail = Mime.emptyMail . address . Mail.from $ mail
  in  fromMail
        { Mime.mailTo = map address . Mail.to $ mail
        , Mime.mailParts =
            [ [ Mime.plainPart . strictToLazy . Mail.plainBody $ mail ]
            ]
        , Mime.mailHeaders = [("Subject", Mail.subject mail)]
        }

address :: Text -> Mime.Address
address addressEmail =
  Mime.Address
    { Mime.addressName = Nothing
    , Mime.addressEmail = addressEmail
    }

strictToLazy :: Text -> LT.Text
strictToLazy = toLazyText . fromText