module Network.Mail.Postie.Session
  ( runSession,
    mkSessionEnv,
    mkSessionID,
  )
where

import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad.Reader
import Control.Monad.State
import Data.ByteString (ByteString)
import qualified Network.TLS as TLS
import qualified Pipes.Parse as P
import Network.Mail.Postie.Address
import Network.Mail.Postie.Connection
import Network.Mail.Postie.Pipes
import Network.Mail.Postie.Protocol (Event (..), Reply, renderReply, reply, reply')
import qualified Network.Mail.Postie.Protocol as SMTP
import Network.Mail.Postie.SessionID
import Network.Mail.Postie.Settings
import Network.Mail.Postie.Types
import Prelude hiding (lines)

data SessionEnv
  = SessionEnv
      { SessionEnv -> SessionID
sessionID :: SessionID,
        SessionEnv -> Application
sessionApp :: Application,
        SessionEnv -> Settings
sessionSettings :: Settings,
        SessionEnv -> Connection
sessionConnection :: Connection,
        SessionEnv -> Maybe ServerParams
sessionServerParams :: Maybe TLS.ServerParams
      }

data SessionState
  = SessionState
      { SessionState -> SmtpFSM
sessionProtocol :: SMTP.SmtpFSM,
        SessionState -> Transaction
sessionTransaction :: Transaction
      }

type SessionM a = ReaderT SessionEnv (StateT SessionState IO) a

data Transaction
  = TxnInitial
  | TxnHaveAuth ByteString
  | TxnHaveMailFrom (Maybe ByteString) Address
  | TxnHaveRecipient (Maybe ByteString) Address [Address]

mkSessionEnv :: SessionID -> Application -> Settings -> Connection -> Maybe TLS.ServerParams -> SessionEnv
mkSessionEnv :: SessionID
-> Application
-> Settings
-> Connection
-> Maybe ServerParams
-> SessionEnv
mkSessionEnv = SessionID
-> Application
-> Settings
-> Connection
-> Maybe ServerParams
-> SessionEnv
SessionEnv

runSession :: SessionEnv -> IO ()
runSession :: SessionEnv -> IO ()
runSession env :: SessionEnv
env = StateT SessionState IO () -> SessionState -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ReaderT SessionEnv (StateT SessionState IO) ()
-> SessionEnv -> StateT SessionState IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT SessionEnv (StateT SessionState IO) ()
startSession SessionEnv
env) SessionState
session
  where
    session :: SessionState
session =
      SessionState :: SmtpFSM -> Transaction -> SessionState
SessionState
        { sessionProtocol :: SmtpFSM
sessionProtocol = SmtpFSM
SMTP.initSmtpFSM,
          sessionTransaction :: Transaction
sessionTransaction = Transaction
TxnInitial
        }

startSession :: SessionM ()
startSession :: ReaderT SessionEnv (StateT SessionState IO) ()
startSession = do
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 220 "hello!"
  ReaderT SessionEnv (StateT SessionState IO) ()
sessionLoop

sessionLoop :: SessionM ()
sessionLoop :: ReaderT SessionEnv (StateT SessionState IO) ()
sessionLoop = do
  (event :: Event
event, fsm' :: SmtpFSM
fsm') <- SmtpFSM -> Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)
SMTP.step (SmtpFSM -> Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM))
-> ReaderT SessionEnv (StateT SessionState IO) SmtpFSM
-> ReaderT
     SessionEnv
     (StateT SessionState IO)
     (Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SessionEnv (StateT SessionState IO) SmtpFSM
getSmtpFsm ReaderT
  SessionEnv
  (StateT SessionState IO)
  (Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM))
-> ReaderT SessionEnv (StateT SessionState IO) Command
-> ReaderT
     SessionEnv
     (StateT SessionState IO)
     (TlsStatus -> AuthStatus -> (Event, SmtpFSM))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT SessionEnv (StateT SessionState IO) Command
getCommand ReaderT
  SessionEnv
  (StateT SessionState IO)
  (TlsStatus -> AuthStatus -> (Event, SmtpFSM))
-> ReaderT SessionEnv (StateT SessionState IO) TlsStatus
-> ReaderT
     SessionEnv
     (StateT SessionState IO)
     (AuthStatus -> (Event, SmtpFSM))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT SessionEnv (StateT SessionState IO) TlsStatus
getTlsStatus ReaderT
  SessionEnv
  (StateT SessionState IO)
  (AuthStatus -> (Event, SmtpFSM))
-> ReaderT SessionEnv (StateT SessionState IO) AuthStatus
-> ReaderT SessionEnv (StateT SessionState IO) (Event, SmtpFSM)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT SessionEnv (StateT SessionState IO) AuthStatus
getAuthStatus
  case Event
event of
    WantQuit -> do
      Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 221 "goodbye"
      () -> ReaderT SessionEnv (StateT SessionState IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    _ -> do
      (SessionState -> SessionState)
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ss :: SessionState
ss -> SessionState
ss {sessionProtocol :: SmtpFSM
sessionProtocol = SmtpFSM
fsm'})
      Event -> ReaderT SessionEnv (StateT SessionState IO) ()
handleEvent Event
event ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT SessionEnv (StateT SessionState IO) ()
sessionLoop
  where
    getSmtpFsm :: ReaderT SessionEnv (StateT SessionState IO) SmtpFSM
getSmtpFsm = (SessionState -> SmtpFSM)
-> ReaderT SessionEnv (StateT SessionState IO) SmtpFSM
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SessionState -> SmtpFSM
sessionProtocol
    getTlsStatus :: ReaderT SessionEnv (StateT SessionState IO) TlsStatus
getTlsStatus = do
      SessionEnv
        { sessionConnection :: SessionEnv -> Connection
sessionConnection = Connection
conn,
          sessionSettings :: SessionEnv -> Settings
sessionSettings = Settings
settings
        } <-
        ReaderT SessionEnv (StateT SessionState IO) SessionEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
      Bool
isSecure <- IO Bool -> ReaderT SessionEnv (StateT SessionState IO) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Connection -> IO Bool
connIsSecure Connection
conn)
      TlsStatus -> ReaderT SessionEnv (StateT SessionState IO) TlsStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (TlsStatus
 -> ReaderT SessionEnv (StateT SessionState IO) TlsStatus)
-> TlsStatus
-> ReaderT SessionEnv (StateT SessionState IO) TlsStatus
forall a b. (a -> b) -> a -> b
$ case Settings -> Maybe StartTLSPolicy
settingsStartTLSPolicy Settings
settings of
        Just p :: StartTLSPolicy
p
          | Bool
isSecure -> TlsStatus
SMTP.Active
          | StartTLSPolicy
p StartTLSPolicy -> StartTLSPolicy -> Bool
forall a. Eq a => a -> a -> Bool
== StartTLSPolicy
AllowStartTLS -> TlsStatus
SMTP.Permitted
          | StartTLSPolicy
p StartTLSPolicy -> StartTLSPolicy -> Bool
forall a. Eq a => a -> a -> Bool
== StartTLSPolicy
DemandStartTLS -> TlsStatus
SMTP.Required
        _ -> TlsStatus
SMTP.Forbidden
    getAuthStatus :: ReaderT SessionEnv (StateT SessionState IO) AuthStatus
getAuthStatus = do
      Bool
reqAuth <- (SessionEnv -> Bool)
-> ReaderT SessionEnv (StateT SessionState IO) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Settings -> Bool
settingsRequireAuth (Settings -> Bool)
-> (SessionEnv -> Settings) -> SessionEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionEnv -> Settings
sessionSettings)
      Transaction
txn <- (SessionState -> Transaction)
-> ReaderT SessionEnv (StateT SessionState IO) Transaction
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SessionState -> Transaction
sessionTransaction
      AuthStatus
-> ReaderT SessionEnv (StateT SessionState IO) AuthStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthStatus
 -> ReaderT SessionEnv (StateT SessionState IO) AuthStatus)
-> AuthStatus
-> ReaderT SessionEnv (StateT SessionState IO) AuthStatus
forall a b. (a -> b) -> a -> b
$ case Transaction
txn of
        TxnInitial -> if Bool
reqAuth then AuthStatus
SMTP.AuthRequired else AuthStatus
SMTP.NoAuth
        TxnHaveAuth _ -> AuthStatus
SMTP.Authed
        TxnHaveMailFrom (Just _) _ -> AuthStatus
SMTP.Authed
        TxnHaveRecipient (Just _) _ _ -> AuthStatus
SMTP.Authed
        _ -> AuthStatus
SMTP.NoAuth

preserveAuth :: (Maybe ByteString -> Transaction) -> Transaction -> Transaction
preserveAuth :: (Maybe ByteString -> Transaction) -> Transaction -> Transaction
preserveAuth f :: Maybe ByteString -> Transaction
f t :: Transaction
t = case Transaction
t of
  TxnInitial -> Maybe ByteString -> Transaction
f Maybe ByteString
forall a. Maybe a
Nothing
  TxnHaveAuth d :: ByteString
d -> Maybe ByteString -> Transaction
f (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
d)
  TxnHaveMailFrom a :: Maybe ByteString
a _ -> Maybe ByteString -> Transaction
f Maybe ByteString
a
  TxnHaveRecipient a :: Maybe ByteString
a _ _ -> Maybe ByteString -> Transaction
f Maybe ByteString
a

handleHelo :: ByteString -> SessionM HandlerResponse
handleHelo :: ByteString -> SessionM HandlerResponse
handleHelo x :: ByteString
x = do
  SessionEnv
    { sessionID :: SessionEnv -> SessionID
sessionID = SessionID
sid,
      sessionSettings :: SessionEnv -> Settings
sessionSettings = Settings
settings
    } <-
    ReaderT SessionEnv (StateT SessionState IO) SessionEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  let handler :: SessionID -> ByteString -> IO HandlerResponse
handler = Settings -> SessionID -> ByteString -> IO HandlerResponse
settingsOnHello Settings
settings
  IO HandlerResponse -> SessionM HandlerResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HandlerResponse -> SessionM HandlerResponse)
-> IO HandlerResponse -> SessionM HandlerResponse
forall a b. (a -> b) -> a -> b
$ SessionID -> ByteString -> IO HandlerResponse
handler SessionID
sid ByteString
x

handleEvent :: SMTP.Event -> SessionM ()
handleEvent :: Event -> ReaderT SessionEnv (StateT SessionState IO) ()
handleEvent (SayHelo x :: ByteString
x) = do
  HandlerResponse
result <- ByteString -> SessionM HandlerResponse
handleHelo ByteString
x
  HandlerResponse
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
handlerResponse HandlerResponse
result (Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok)
handleEvent (SayEhlo x :: ByteString
x) = do
  HandlerResponse
result <- ByteString -> SessionM HandlerResponse
handleHelo ByteString
x
  HandlerResponse
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
handlerResponse HandlerResponse
result (ReaderT SessionEnv (StateT SessionState IO) ()
 -> ReaderT SessionEnv (StateT SessionState IO) ())
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$
    Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> ReaderT SessionEnv (StateT SessionState IO) Reply
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT SessionEnv (StateT SessionState IO) Reply
ehloAdvertisement
handleEvent (SayEhloAgain _) = Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok
handleEvent (SayHeloAgain _) = Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok
handleEvent SayOK = Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok
handleEvent (SetMailFrom x :: Mailbox
x) = do
  SessionEnv
    { sessionID :: SessionEnv -> SessionID
sessionID = SessionID
sid,
      sessionSettings :: SessionEnv -> Settings
sessionSettings = Settings
settings
    } <-
    ReaderT SessionEnv (StateT SessionState IO) SessionEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  let handler :: SessionID -> Mailbox -> IO HandlerResponse
handler = Settings -> SessionID -> Mailbox -> IO HandlerResponse
settingsOnMailFrom Settings
settings
  HandlerResponse
result <- IO HandlerResponse -> SessionM HandlerResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HandlerResponse -> SessionM HandlerResponse)
-> IO HandlerResponse -> SessionM HandlerResponse
forall a b. (a -> b) -> a -> b
$ SessionID -> Mailbox -> IO HandlerResponse
handler SessionID
sid Mailbox
x
  HandlerResponse
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
handlerResponse HandlerResponse
result (ReaderT SessionEnv (StateT SessionState IO) ()
 -> ReaderT SessionEnv (StateT SessionState IO) ())
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ do
    (SessionState -> SessionState)
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ss :: SessionState
ss -> SessionState
ss {sessionTransaction :: Transaction
sessionTransaction = (Maybe ByteString -> Transaction) -> Transaction -> Transaction
preserveAuth (Maybe ByteString -> Mailbox -> Transaction
`TxnHaveMailFrom` Mailbox
x) (SessionState -> Transaction
sessionTransaction SessionState
ss)})
    Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok
handleEvent (AddRcptTo x :: Mailbox
x) = do
  SessionEnv
    { sessionID :: SessionEnv -> SessionID
sessionID = SessionID
sid,
      sessionSettings :: SessionEnv -> Settings
sessionSettings = Settings
settings
    } <-
    ReaderT SessionEnv (StateT SessionState IO) SessionEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  let handler :: SessionID -> Mailbox -> IO HandlerResponse
handler = Settings -> SessionID -> Mailbox -> IO HandlerResponse
settingsOnRecipient Settings
settings
  HandlerResponse
result <- IO HandlerResponse -> SessionM HandlerResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HandlerResponse -> SessionM HandlerResponse)
-> IO HandlerResponse -> SessionM HandlerResponse
forall a b. (a -> b) -> a -> b
$ SessionID -> Mailbox -> IO HandlerResponse
handler SessionID
sid Mailbox
x
  HandlerResponse
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
handlerResponse HandlerResponse
result (ReaderT SessionEnv (StateT SessionState IO) ()
 -> ReaderT SessionEnv (StateT SessionState IO) ())
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Transaction
txn <- (SessionState -> Transaction)
-> ReaderT SessionEnv (StateT SessionState IO) Transaction
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SessionState -> Transaction
sessionTransaction
    let txn' :: Transaction
txn' = case Transaction
txn of
          (TxnHaveMailFrom a :: Maybe ByteString
a y :: Mailbox
y) -> Maybe ByteString -> Mailbox -> [Mailbox] -> Transaction
TxnHaveRecipient Maybe ByteString
a Mailbox
y [Mailbox
x]
          (TxnHaveRecipient a :: Maybe ByteString
a y :: Mailbox
y xs :: [Mailbox]
xs) -> Maybe ByteString -> Mailbox -> [Mailbox] -> Transaction
TxnHaveRecipient Maybe ByteString
a Mailbox
y (Mailbox
x Mailbox -> [Mailbox] -> [Mailbox]
forall a. a -> [a] -> [a]
: [Mailbox]
xs)
          _ -> [Char] -> Transaction
forall a. HasCallStack => [Char] -> a
error "impossible"
    (SessionState -> SessionState)
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ss :: SessionState
ss -> SessionState
ss {sessionTransaction :: Transaction
sessionTransaction = Transaction
txn'})
    Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok
handleEvent StartData = do
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 354 "End data with <CR><LF>.<CR><LF>"
  SessionEnv
    { sessionID :: SessionEnv -> SessionID
sessionID = SessionID
sid,
      sessionApp :: SessionEnv -> Application
sessionApp = Application
app,
      sessionSettings :: SessionEnv -> Settings
sessionSettings = Settings
settings,
      sessionConnection :: SessionEnv -> Connection
sessionConnection = Connection
conn
    } <-
    ReaderT SessionEnv (StateT SessionState IO) SessionEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  (TxnHaveRecipient auth :: Maybe ByteString
auth sender :: Mailbox
sender recipients :: [Mailbox]
recipients) <- (SessionState -> Transaction)
-> ReaderT SessionEnv (StateT SessionState IO) Transaction
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SessionState -> Transaction
sessionTransaction
  let chunks :: Producer ByteString IO ()
chunks = StatusCode
-> Producer ByteString IO () -> Producer ByteString IO ()
dataChunks (Settings -> StatusCode
settingsMaxDataSize Settings
settings) (Connection -> Producer' ByteString IO ()
forall (m :: * -> *).
MonadIO m =>
Connection -> Producer' ByteString m ()
toProducer Connection
conn)
  let mail :: Mail
mail = SessionID
-> Maybe ByteString
-> Mailbox
-> [Mailbox]
-> Producer ByteString IO ()
-> Mail
Mail SessionID
sid Maybe ByteString
auth Mailbox
sender [Mailbox]
recipients Producer ByteString IO ()
chunks
  HandlerResponse
result <- IO HandlerResponse -> SessionM HandlerResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HandlerResponse -> SessionM HandlerResponse)
-> IO HandlerResponse -> SessionM HandlerResponse
forall a b. (a -> b) -> a -> b
$ Application
app Mail
mail
  HandlerResponse
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
handlerResponse HandlerResponse
result (ReaderT SessionEnv (StateT SessionState IO) ()
 -> ReaderT SessionEnv (StateT SessionState IO) ())
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok
    (SessionState -> SessionState)
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ss :: SessionState
ss -> SessionState
ss {sessionTransaction :: Transaction
sessionTransaction = Transaction
TxnInitial})
handleEvent WantTls = do
  SessionEnv
    { sessionID :: SessionEnv -> SessionID
sessionID = SessionID
sid,
      sessionConnection :: SessionEnv -> Connection
sessionConnection = Connection
conn,
      sessionSettings :: SessionEnv -> Settings
sessionSettings = Settings
settings,
      sessionServerParams :: SessionEnv -> Maybe ServerParams
sessionServerParams = Just serverParams :: ServerParams
serverParams
    } <-
    ReaderT SessionEnv (StateT SessionState IO) SessionEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  let handler :: SessionID -> IO ()
handler = Settings -> SessionID -> IO ()
settingsOnStartTLS Settings
settings
  IO () -> ReaderT SessionEnv (StateT SessionState IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT SessionEnv (StateT SessionState IO) ())
-> IO () -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ SessionID -> IO ()
handler SessionID
sid
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok
  IO () -> ReaderT SessionEnv (StateT SessionState IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT SessionEnv (StateT SessionState IO) ())
-> IO () -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ Connection -> ServerParams -> IO ()
connSetSecure Connection
conn ServerParams
serverParams
  (SessionState -> SessionState)
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ss :: SessionState
ss -> SessionState
ss {sessionTransaction :: Transaction
sessionTransaction = Transaction
TxnInitial})
handleEvent (WantAuth d :: ByteString
d) = do
  (sid :: SessionID
sid, settings :: Settings
settings) <- (SessionEnv -> (SessionID, Settings))
-> ReaderT
     SessionEnv (StateT SessionState IO) (SessionID, Settings)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (SessionEnv -> SessionID
sessionID (SessionEnv -> SessionID)
-> (SessionEnv -> Settings) -> SessionEnv -> (SessionID, Settings)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SessionEnv -> Settings
sessionSettings)
  let handler :: SessionID -> ByteString -> IO HandlerResponse
handler = Settings -> SessionID -> ByteString -> IO HandlerResponse
settingsOnAuth Settings
settings
  HandlerResponse
result <- IO HandlerResponse -> SessionM HandlerResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HandlerResponse -> SessionM HandlerResponse)
-> IO HandlerResponse -> SessionM HandlerResponse
forall a b. (a -> b) -> a -> b
$ SessionID -> ByteString -> IO HandlerResponse
handler SessionID
sid ByteString
d
  HandlerResponse
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
handlerResponse HandlerResponse
result (ReaderT SessionEnv (StateT SessionState IO) ()
 -> ReaderT SessionEnv (StateT SessionState IO) ())
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok
    (SessionState -> SessionState)
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ss :: SessionState
ss -> SessionState
ss {sessionTransaction :: Transaction
sessionTransaction = ByteString -> Transaction
TxnHaveAuth ByteString
d})
handleEvent WantReset = do
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
ok
  (SessionState -> SessionState)
-> ReaderT SessionEnv (StateT SessionState IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ss :: SessionState
ss -> SessionState
ss {sessionTransaction :: Transaction
sessionTransaction = Transaction
TxnInitial})
handleEvent TlsAlreadyActive =
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 454 "STARTTLS not supported (already active)"
handleEvent TlsNotSupported =
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 454 "STARTTLS not supported"
handleEvent NeedStartTlsFirst =
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 530 "Issue STARTTLS first"
handleEvent NeedAuthFirst =
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 530 "5.7.1 Authentication required"
handleEvent NeedHeloFirst =
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 503 "Need EHLO first"
handleEvent NeedMailFromFirst =
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 503 "Need MAIL FROM first"
handleEvent NeedRcptToFirst =
  Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 503 "Need RCPT TO first"
handleEvent _ = [Char] -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a. HasCallStack => [Char] -> a
error "impossible"

handlerResponse :: HandlerResponse -> SessionM () -> SessionM ()
handlerResponse :: HandlerResponse
-> ReaderT SessionEnv (StateT SessionState IO) ()
-> ReaderT SessionEnv (StateT SessionState IO) ()
handlerResponse Accepted action :: ReaderT SessionEnv (StateT SessionState IO) ()
action = ReaderT SessionEnv (StateT SessionState IO) ()
action
handlerResponse Rejected _ = Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply Reply
reject

getCommand :: SessionM SMTP.Command
getCommand :: ReaderT SessionEnv (StateT SessionState IO) Command
getCommand = do
  Producer ByteString IO ()
input <- Connection -> Producer ByteString IO ()
forall (m :: * -> *).
MonadIO m =>
Connection -> Producer' ByteString m ()
toProducer (Connection -> Producer ByteString IO ())
-> ReaderT SessionEnv (StateT SessionState IO) Connection
-> ReaderT
     SessionEnv (StateT SessionState IO) (Producer ByteString IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (SessionEnv -> Connection)
-> ReaderT SessionEnv (StateT SessionState IO) Connection
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SessionEnv -> Connection
sessionConnection
  Maybe Command
result <- IO (Maybe Command)
-> ReaderT SessionEnv (StateT SessionState IO) (Maybe Command)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Command)
 -> ReaderT SessionEnv (StateT SessionState IO) (Maybe Command))
-> IO (Maybe Command)
-> ReaderT SessionEnv (StateT SessionState IO) (Maybe Command)
forall a b. (a -> b) -> a -> b
$ StateT (Producer ByteString IO ()) IO (Maybe Command)
-> Producer ByteString IO () -> IO (Maybe Command)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
P.evalStateT (Parser Command -> Parser ByteString IO (Maybe Command)
forall r. Parser r -> Parser ByteString IO (Maybe r)
attoParser Parser Command
SMTP.parseCommand) Producer ByteString IO ()
input
  case Maybe Command
result of
    Nothing -> do
      Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply (Reply -> ReaderT SessionEnv (StateT SessionState IO) ())
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> ByteString -> Reply
reply 500 "Syntax error, command unrecognized"
      ReaderT SessionEnv (StateT SessionState IO) Command
getCommand
    Just command :: Command
command -> Command -> ReaderT SessionEnv (StateT SessionState IO) Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
command

ehloAdvertisement :: SessionM Reply
ehloAdvertisement :: ReaderT SessionEnv (StateT SessionState IO) Reply
ehloAdvertisement = do
  [ByteString]
stls <- ReaderT SessionEnv (StateT SessionState IO) [ByteString]
startTls
  let extensions :: [ByteString]
extensions = "8BITMIME" ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
stls
  Reply -> ReaderT SessionEnv (StateT SessionState IO) Reply
forall (m :: * -> *) a. Monad m => a -> m a
return (Reply -> ReaderT SessionEnv (StateT SessionState IO) Reply)
-> Reply -> ReaderT SessionEnv (StateT SessionState IO) Reply
forall a b. (a -> b) -> a -> b
$ StatusCode -> [ByteString] -> Reply
reply' 250 ([ByteString]
extensions [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ ["OK"])
  where
    startTls :: ReaderT SessionEnv (StateT SessionState IO) [ByteString]
startTls = do
      SessionEnv
        { sessionConnection :: SessionEnv -> Connection
sessionConnection = Connection
conn,
          sessionSettings :: SessionEnv -> Settings
sessionSettings = Settings
settings
        } <-
        ReaderT SessionEnv (StateT SessionState IO) SessionEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
      Bool
secure <- IO Bool -> ReaderT SessionEnv (StateT SessionState IO) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Connection -> IO Bool
connIsSecure Connection
conn)
      [ByteString]
-> ReaderT SessionEnv (StateT SessionState IO) [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ "STARTTLS"
          | Bool -> Bool
not Bool
secure
              Bool -> Bool -> Bool
&& ( case Settings -> Maybe StartTLSPolicy
settingsStartTLSPolicy Settings
settings of
                     Just _ -> Bool
True
                     _ -> Bool
False
                 )
        ]

ok :: Reply
ok :: Reply
ok = StatusCode -> ByteString -> Reply
reply 250 "OK"

reject :: Reply
reject :: Reply
reject = StatusCode -> ByteString -> Reply
reply 554 "Transaction failed"

sendReply :: Reply -> SessionM ()
sendReply :: Reply -> ReaderT SessionEnv (StateT SessionState IO) ()
sendReply r :: Reply
r = do
  Connection
conn <- (SessionEnv -> Connection)
-> ReaderT SessionEnv (StateT SessionState IO) Connection
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SessionEnv -> Connection
sessionConnection
  IO () -> ReaderT SessionEnv (StateT SessionState IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT SessionEnv (StateT SessionState IO) ())
-> IO () -> ReaderT SessionEnv (StateT SessionState IO) ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
connSend Connection
conn (Reply -> ByteString
renderReply Reply
r)