module Network.Mail.Postie.Protocol
  ( TlsStatus (..),
    AuthStatus (..),
    Mailbox,
    Event (..),
    Command (..),
    SmtpFSM,
    Reply,
    initSmtpFSM,
    step,
    reply,
    reply',
    renderReply,
    parseCommand,
    parseHelo,
    parseMailFrom,
  )
where

import Control.Applicative
import Control.Monad (void)
import Data.Attoparsec.ByteString.Char8 hiding (match)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Functor (($>))
import Network.Mail.Postie.Address
import Prelude hiding (takeWhile)

data TlsStatus = Active | Forbidden | Permitted | Required deriving (TlsStatus -> TlsStatus -> Bool
(TlsStatus -> TlsStatus -> Bool)
-> (TlsStatus -> TlsStatus -> Bool) -> Eq TlsStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TlsStatus -> TlsStatus -> Bool
$c/= :: TlsStatus -> TlsStatus -> Bool
== :: TlsStatus -> TlsStatus -> Bool
$c== :: TlsStatus -> TlsStatus -> Bool
Eq)

data AuthStatus = Authed | NoAuth | AuthRequired deriving (AuthStatus -> AuthStatus -> Bool
(AuthStatus -> AuthStatus -> Bool)
-> (AuthStatus -> AuthStatus -> Bool) -> Eq AuthStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthStatus -> AuthStatus -> Bool
$c/= :: AuthStatus -> AuthStatus -> Bool
== :: AuthStatus -> AuthStatus -> Bool
$c== :: AuthStatus -> AuthStatus -> Bool
Eq)

data SessionState
  = Unknown
  | HaveHelo
  | HaveEhlo
  | HaveMailFrom
  | HaveRcptTo
  | HaveData
  | HaveQuit

type Mailbox = Address

data Event
  = SayHelo BS.ByteString
  | SayHeloAgain BS.ByteString
  | SayEhlo BS.ByteString
  | SayEhloAgain BS.ByteString
  | SayOK
  | SetMailFrom Mailbox
  | AddRcptTo Mailbox
  | StartData
  | WantTls
  | WantAuth BS.ByteString
  | WantReset
  | WantQuit
  | TlsAlreadyActive
  | TlsNotSupported
  | NeedStartTlsFirst
  | NeedAuthFirst
  | NeedHeloFirst
  | NeedMailFromFirst
  | NeedRcptToFirst
  deriving (Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq, Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show)

data Command
  = Helo BS.ByteString
  | Ehlo BS.ByteString
  | MailFrom Mailbox
  | RcptTo Mailbox
  | StartTls
  | Auth BS.ByteString
  | Data
  | Rset
  | Quit
  deriving (Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq, Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show)

newtype SmtpFSM = SmtpFSM {SmtpFSM -> Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)
step :: Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)}

initSmtpFSM :: SmtpFSM
initSmtpFSM :: SmtpFSM
initSmtpFSM = (Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)) -> SmtpFSM
SmtpFSM (SessionState
-> Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)
handleSmtpCmd SessionState
Unknown)

handleSmtpCmd :: SessionState -> Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)
handleSmtpCmd :: SessionState
-> Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)
handleSmtpCmd st :: SessionState
st cmd :: Command
cmd tlsSt :: TlsStatus
tlsSt auth :: AuthStatus
auth = TlsStatus
-> AuthStatus -> SessionState -> Command -> (Event, SmtpFSM)
match TlsStatus
tlsSt AuthStatus
auth SessionState
st Command
cmd
  where
    match :: TlsStatus -> AuthStatus -> SessionState -> Command -> (Event, SmtpFSM)
    match :: TlsStatus
-> AuthStatus -> SessionState -> Command -> (Event, SmtpFSM)
match _ _ HaveQuit _ = (Event, SmtpFSM)
forall a. HasCallStack => a
undefined
    match _ _ HaveData Data = (Event, SmtpFSM)
forall a. HasCallStack => a
undefined
    match _ _ _ Quit = (SessionState, Event) -> (Event, SmtpFSM)
trans (SessionState
HaveQuit, Event
WantQuit)
    match _ _ Unknown (Helo x :: ByteString
x) = (SessionState, Event) -> (Event, SmtpFSM)
trans (SessionState
HaveHelo, ByteString -> Event
SayHelo ByteString
x)
    match _ _ _ (Helo x :: ByteString
x) = Event -> (Event, SmtpFSM)
event (ByteString -> Event
SayHeloAgain ByteString
x)
    match _ _ Unknown (Ehlo x :: ByteString
x) = (SessionState, Event) -> (Event, SmtpFSM)
trans (SessionState
HaveEhlo, ByteString -> Event
SayEhlo ByteString
x)
    match _ _ _ (Ehlo x :: ByteString
x) = Event -> (Event, SmtpFSM)
event (ByteString -> Event
SayEhloAgain ByteString
x)
    match Required _ _ (MailFrom _) = Event -> (Event, SmtpFSM)
event Event
NeedStartTlsFirst
    match _ AuthRequired _ (MailFrom _) = Event -> (Event, SmtpFSM)
event Event
NeedAuthFirst
    match _ _ Unknown (MailFrom _) = Event -> (Event, SmtpFSM)
event Event
NeedHeloFirst
    match _ _ _ (MailFrom x :: Mailbox
x) = (SessionState, Event) -> (Event, SmtpFSM)
trans (SessionState
HaveMailFrom, Mailbox -> Event
SetMailFrom Mailbox
x)
    match Required _ _ (RcptTo _) = Event -> (Event, SmtpFSM)
event Event
NeedStartTlsFirst
    match _ AuthRequired _ (RcptTo _) = Event -> (Event, SmtpFSM)
event Event
NeedAuthFirst
    match _ _ Unknown (RcptTo _) = Event -> (Event, SmtpFSM)
event Event
NeedHeloFirst
    match _ _ HaveHelo (RcptTo _) = Event -> (Event, SmtpFSM)
event Event
NeedMailFromFirst
    match _ _ HaveEhlo (RcptTo _) = Event -> (Event, SmtpFSM)
event Event
NeedMailFromFirst
    match _ _ _ (RcptTo x :: Mailbox
x) = (SessionState, Event) -> (Event, SmtpFSM)
trans (SessionState
HaveRcptTo, Mailbox -> Event
AddRcptTo Mailbox
x)
    match Required _ _ Data = Event -> (Event, SmtpFSM)
event Event
NeedStartTlsFirst
    match _ AuthRequired _ Data = Event -> (Event, SmtpFSM)
event Event
NeedAuthFirst
    match _ _ Unknown Data = Event -> (Event, SmtpFSM)
event Event
NeedHeloFirst
    match _ _ HaveHelo Data = Event -> (Event, SmtpFSM)
event Event
NeedMailFromFirst
    match _ _ HaveEhlo Data = Event -> (Event, SmtpFSM)
event Event
NeedMailFromFirst
    match _ _ HaveMailFrom Data = Event -> (Event, SmtpFSM)
event Event
NeedRcptToFirst
    match _ _ HaveRcptTo Data = (SessionState, Event) -> (Event, SmtpFSM)
trans (SessionState
HaveData, Event
StartData)
    match Required _ _ Rset = Event -> (Event, SmtpFSM)
event Event
NeedStartTlsFirst
    match _ _ _ Rset = (SessionState, Event) -> (Event, SmtpFSM)
trans (SessionState
HaveHelo, Event
WantReset)
    match Active _ _ StartTls = Event -> (Event, SmtpFSM)
event Event
TlsAlreadyActive
    match Forbidden _ _ StartTls = Event -> (Event, SmtpFSM)
event Event
TlsNotSupported
    match _ _ _ StartTls = (SessionState, Event) -> (Event, SmtpFSM)
trans (SessionState
Unknown, Event
WantTls)
    match Required _ _ (Auth _) = Event -> (Event, SmtpFSM)
event Event
NeedStartTlsFirst
    match _ _ _ (Auth d :: ByteString
d) = (SessionState, Event) -> (Event, SmtpFSM)
trans (SessionState
HaveEhlo, ByteString -> Event
WantAuth ByteString
d)
    event :: Event -> (Event, SmtpFSM)
    event :: Event -> (Event, SmtpFSM)
event e :: Event
e = (Event
e, (Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)) -> SmtpFSM
SmtpFSM (SessionState
-> Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)
handleSmtpCmd SessionState
st))
    trans :: (SessionState, Event) -> (Event, SmtpFSM)
    trans :: (SessionState, Event) -> (Event, SmtpFSM)
trans (st' :: SessionState
st', e :: Event
e) = (Event
e, (Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)) -> SmtpFSM
SmtpFSM (SessionState
-> Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)
handleSmtpCmd SessionState
st'))

type StatusCode = Int

data Reply = Reply StatusCode [LBS.ByteString]

reply :: StatusCode -> LBS.ByteString -> Reply
reply :: Int -> ByteString -> Reply
reply c :: Int
c s :: ByteString
s = Int -> [ByteString] -> Reply
reply' Int
c [ByteString
s]

reply' :: StatusCode -> [LBS.ByteString] -> Reply
reply' :: Int -> [ByteString] -> Reply
reply' = Int -> [ByteString] -> Reply
Reply

renderReply :: Reply -> LBS.ByteString
renderReply :: Reply -> ByteString
renderReply (Reply code :: Int
code msgs :: [ByteString]
msgs) = [ByteString] -> ByteString
LBS.concat [ByteString]
msg'
  where
    prefixCon :: ByteString
prefixCon = String -> ByteString
LBS.pack (Int -> String
forall a. Show a => a -> String
show Int
code String -> ShowS
forall a. [a] -> [a] -> [a]
++ "-")
    prefixEnd :: ByteString
prefixEnd = String -> ByteString
LBS.pack (Int -> String
forall a. Show a => a -> String
show Int
code String -> ShowS
forall a. [a] -> [a] -> [a]
++ " ")
    fmt :: ByteString -> ByteString -> ByteString
fmt p :: ByteString
p l :: ByteString
l = [ByteString] -> ByteString
LBS.concat [ByteString
p, ByteString
l, "\r\n"]
    (x :: ByteString
x : xs :: [ByteString]
xs) = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
msgs
    msgCon :: [ByteString]
msgCon = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
fmt ByteString
prefixCon) [ByteString]
xs
    msgEnd :: ByteString
msgEnd = ByteString -> ByteString -> ByteString
fmt ByteString
prefixEnd ByteString
x
    msg' :: [ByteString]
msg' = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString
msgEnd ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
msgCon)

parseCommand :: Parser Command
parseCommand :: Parser Command
parseCommand = Parser Command
commands Parser Command -> Parser ByteString () -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
crlf
  where
    commands :: Parser Command
commands =
      [Parser Command] -> Parser Command
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
        [ Parser Command
parseQuit,
          Parser Command
parseData,
          Parser Command
parseRset,
          Parser Command
parseHelo,
          Parser Command
parseEhlo,
          Parser Command
parseStartTls,
          Parser Command
parseAuth,
          Parser Command
parseMailFrom,
          Parser Command
parseRcptTo
        ]

crlf :: Parser ()
crlf :: Parser ByteString ()
crlf = Parser ByteString Char -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString Char -> Parser ByteString ())
-> Parser ByteString Char -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser ByteString Char
char '\r' Parser ByteString Char
-> Parser ByteString Char -> Parser ByteString Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser ByteString Char
char '\n'

parseHello :: (BS.ByteString -> Command) -> BS.ByteString -> Parser Command
parseHello :: (ByteString -> Command) -> ByteString -> Parser Command
parseHello f :: ByteString -> Command
f s :: ByteString
s = ByteString -> Command
f (ByteString -> Command)
-> Parser ByteString ByteString -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString ByteString
parser
  where
    parser :: Parser ByteString ByteString
parser = ByteString -> Parser ByteString ByteString
stringCI ByteString
s Parser ByteString ByteString
-> Parser ByteString Char -> Parser ByteString Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser ByteString Char
char ' ' Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString ByteString
takeWhile (String -> Char -> Bool
notInClass "\r ")

parseHelo :: Parser Command
parseHelo :: Parser Command
parseHelo = (ByteString -> Command) -> ByteString -> Parser Command
parseHello ByteString -> Command
Helo "helo"

parseEhlo :: Parser Command
parseEhlo :: Parser Command
parseEhlo = (ByteString -> Command) -> ByteString -> Parser Command
parseHello ByteString -> Command
Ehlo "ehlo"

parseMailFrom :: Parser Command
parseMailFrom :: Parser Command
parseMailFrom = ByteString -> Parser ByteString ByteString
stringCI "mail from:<" Parser ByteString ByteString -> Parser Command -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Mailbox -> Command
MailFrom (Mailbox -> Command) -> Parser ByteString Mailbox -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Mailbox
addrSpec) Parser Command -> Parser ByteString Char -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char '>'

parseRcptTo :: Parser Command
parseRcptTo :: Parser Command
parseRcptTo = ByteString -> Parser ByteString ByteString
stringCI "rcpt to:<" Parser ByteString ByteString -> Parser Command -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Mailbox -> Command
RcptTo (Mailbox -> Command) -> Parser ByteString Mailbox -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Mailbox
addrSpec) Parser Command -> Parser ByteString Char -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char '>'

parseStartTls :: Parser Command
parseStartTls :: Parser Command
parseStartTls = ByteString -> Parser ByteString ByteString
stringCI "starttls" Parser ByteString ByteString -> Command -> Parser Command
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Command
StartTls

parseAuth :: Parser Command
parseAuth :: Parser Command
parseAuth = ByteString -> Command
Auth (ByteString -> Command)
-> Parser ByteString ByteString -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Parser ByteString ByteString
stringCI "auth plain" Parser ByteString ByteString
-> Parser ByteString Char -> Parser ByteString Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser ByteString Char
char ' ' Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString ByteString
takeWhile (String -> Char -> Bool
notInClass "\r "))

parseRset :: Parser Command
parseRset :: Parser Command
parseRset = ByteString -> Parser ByteString ByteString
stringCI "rset" Parser ByteString ByteString -> Command -> Parser Command
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Command
Rset

parseData :: Parser Command
parseData :: Parser Command
parseData = ByteString -> Parser ByteString ByteString
stringCI "data" Parser ByteString ByteString -> Command -> Parser Command
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Command
Data

parseQuit :: Parser Command
parseQuit :: Parser Command
parseQuit = ByteString -> Parser ByteString ByteString
stringCI "quit" Parser ByteString ByteString -> Command -> Parser Command
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Command
Quit