fcmtp-client/src/Network/FCMTP/Client.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.FCMTP.Client (DebugOption(..), sendEmail) where

import Network.DNS (Domain)
import qualified Network.DNS.Lookup as DNS
import Network.DNS.Resolver (makeResolvSeed, defaultResolvConf, withResolver)
import qualified Data.List as List
import System.Random(randomIO)
import Control.Exception
import Control.Monad.Trans.Interruptible
import Control.Monad.Trans.SafeIO
import Control.Monad.Trans.Either
import Control.Lens
import Data.Function (on)
import Text.Regex.TDFA ((=~))

import Text.StringConvert
import Network.FCMTP.Relay
import Network.FCMTP.ClientError
import Data.FCMTP.Constants
import Data.FCMTP.Host
import Data.FCMTP.Account (Account, HostName(..))
import qualified Data.FCMTP.Account as Ac
--import Data.FCMTP.Address (Address(..))
import Data.FCMTP.ResponseCode
import Data.FCMTP.Response (Response)
import qualified Data.FCMTP.Mime as Mime
--import qualified Data.FCMTP.Address as Add
import Network.FCMTP.SendingState
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import System.IO (hPutStrLn, stderr)
import System.IO.Uniform (TlsSettings, SomeIO(..))
import qualified System.IO.Uniform as U
import System.IO.Uniform.Std
import System.IO.Uniform.Network

--fetchResource :: Settings -> AuthData -> ResourceURI -> IO SealedResource
--listResource :: Settings -> AuthData -> ResourceURI -> IO ResourceList
--deleteResource :: Settings -> AuthData -> ResourceURI -> IO ()
--updateResource :: Settings -> AuthData -> ResourceURI SealedResource -> IO ()
--monitorResource :: Settings -> AuthData -> ResourceURI -> MVar ResourceURI -> IO ()

data DebugOption = RunStdIO | EchoProto deriving (Eq, Ord, Read, Show, Bounded, Enum)

-- sendEmail :: debugOpts -> localhostName -> tlsSettngs -> relays -> from  -> [rcpt] -> Mime.BodyEncoding -> mailData -> IO failures
sendEmail :: ToString host => [DebugOption] -> host -> TlsSettings -> [Relay] -> Account -> [Account] -> Mime.BodyEncoding -> LBS.ByteString -> IO [(Account, Response)]
sendEmail dbg h set relays fromAdd rcptTo enc mailData = do
  resp <- try $! sendEmail' dbg h set relays fromAdd rcptTo enc mailData :: IO (Either IOError [(Account, Response)])
  case resp of
    Right a -> return a
    Left e -> do
      hPutStrLn stderr $ "Error sending email: " ++ show e
      return $ map (\x -> (x, toResponse BadConnection)) rcptTo
    

sendEmail' :: ToString host => [DebugOption] -> host -> TlsSettings ->[Relay] -> Account -> [Account] -> Mime.BodyEncoding -> LBS.ByteString -> IO [(Account, Response)]
sendEmail' _ _ _ _ _ [] _ _ = return []
sendEmail' dbg h set relays fromAdd rcptTo enc mailData = do
  let byhost = List.groupBy ((==) `on` getHost relays) rcptTo
  conn <- if RunStdIO `elem` dbg
    then do
    t <- getStdIO
    return [inSendingCtx h set t . inEitherTCtx $ rcptTo]
    else mapM (connHost) byhost
  results <- mapM (resume2 $ startHost dbg fromAdd enc) conn >>=
             intercalateFold resume2 dataToHost (LBS.toChunks mailData) >>=
             mapM (resume2 closeHost) >>=
             mapM peelCtx
  return . concat $ zipWith resolveErrors byhost results
  where
    getHost :: [Relay] -> Account -> Host
    getHost [] a = ByName $ Ac.domain a
    getHost (r:rr) a = if null (r^.relayRules)
      then r^.relayHost
      else if (Ac.normalize a) =~ (r^.relayRules)
           then r^.relayHost
           else getHost rr a
    inCtx :: U.UniformIO io => io -> a -> RSt Sending a
    inCtx = inSendingCtx h set
    connHost :: [Account] -> IO (RSt Sending (RSt (EitherT ClientError) [Account]))
    connHost x = case x of
      [] -> do
        t <- getStdIO
        return . inCtx t . Left $ CanNotConnect
      rr@(r:_) -> do
        c <- openMailHost $ getHost relays r
        case c of
          Left e -> do
            t <- getStdIO
            return . inCtx t . Left $ e
          Right c' -> return . inCtx c' . inEitherTCtx $ rr

type SendingType a = EitherT ClientError (Sending IO) a

startHost :: [DebugOption] -> Account -> Mime.BodyEncoding -> [Account] -> SendingType ()
startHost dbg fromAdd enc rcptTo = do
  let echo = if EchoProto `elem` dbg then Just stderr else Nothing
  safeCT $ do
    startSending echo
    startSession
    mailCmd fromAdd
    mapM_ rcptCmd rcptTo
    startData enc

dataToHost :: BS.ByteString -> () -> SendingType ()
dataToHost dt _ = safeCT $ dataChunk dt False

closeHost :: () -> SendingType ()
closeHost _ = safeCT $ do
  dataChunk BS.empty True
  quitCmd

peelCtx :: RSt Sending (RSt (EitherT ClientError) ()) -> IO (Either ClientError [(Account, Response)])
peelCtx c = do
  let (c', io, ff) = peelSendingCtx c
  U.uClose io
  case peelEitherTCtx c' of
    Left e -> return . Left $ e
    Right _ -> return . Right $ ff

resolveErrors :: [Account] -> Either ClientError [(Account, Response)] -> [(Account, Response)]
resolveErrors aa rt = case rt of
  Right ff -> ff
  Left _ -> map (\x -> (x, toResponse BadConnection)) aa

-- Returns the mailservers for a given domain name, ordered by priority
emailAddrs :: BS.ByteString -> IO [Domain]
emailAddrs a = do
  let hostname = a
  rs <- makeResolvSeed defaultResolvConf
  hs <- withResolver rs $ \resolver -> DNS.lookupMX resolver hostname
  case hs of
    Right ds -> do
      dr <- mapM randMX ds
      return $ map fst3 $ List.sortBy orderMX dr
    Left _ -> throwIO MXLookupError
  
randMX :: (Domain, Int) -> IO (Domain, Int, Int)
randMX (d, p) = do
  r <- randomIO
  return (d, p, r)
  
orderMX :: (Domain, Int, Int) -> (Domain, Int, Int) -> Ordering
orderMX (_, pa, ra) (_, pb, rb) = if pa == pb then compare ra rb else compare pa pb

fst3 :: (a, b, c) -> a
fst3 (a, _, _) = a

openMailHost :: Host -> IO (Either ClientError SomeIO)
openMailHost host =
  case host of
    ByName (HostName h) -> do
      mxs <- geterr $ emailAddrs h
      case mxs of
        Right [] -> tryOpen [h]
        Right adds -> tryOpen adds
        Left _ -> tryOpen [h]
    ByIP ip -> tryOpen [s . show $ ip]
  where
    pp = fromIntegral relayPortNumber :: Int
    tryOpen :: [BS.ByteString] -> IO (Either ClientError SomeIO)
    tryOpen [] = return . Left $ CanNotConnect
    tryOpen (a:aa) = do
      ret <- geterr $ connectToHost (s a) pp
      case ret of
        Right con -> return . Right . SomeIO $ con
        Left _ -> tryOpen aa

geterr :: IO a -> IO (Either ClientError a)
geterr f = do
  r <- f
  return . Right $ r