content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE DerivingStrategies #-}
  -- |
  -- Internal functions that are used in the SMTP protocol,
  -- you may need these module in case if you want to implement additional
  -- functionality that does not exist in the "Network.HaskellNet.SMTP".
  --
  -- __Example__.
  --
  -- One example could be sending multiple emails over the same stream
  -- in order to use that you may want to use 'RSET' command, so you can implement:
  --
  -- @
  -- import "Network.HaskellNet.SMTP.Internal"
  --
  -- resetConnection :: SMTPConnection -> IO ()
  -- resetConnection conn = do
  --    (code, _) <- 'sendCommand' conn 'RSET'
  --    'unless' (code == 250) $ 'throwIO' $ 'UnexpectedReply' 'RSET' [250] code ""
  -- @
  --
  module Network.HaskellNet.SMTP.Internal
    ( SMTPConnection(..)
    , Command(..)
    , SMTPException(..)
    , ReplyCode
    , tryCommand
    , parseResponse
    , sendCommand
    , sendMailData
    , closeSMTP
    , gracefullyCloseSMTP
    , quitSMTP
      -- * Reexports
    , Address(..)
    ) where
  
  import Control.Exception
  import Control.Monad (unless)
  import Data.Char (isDigit)
  import Data.ByteString (ByteString)
  import qualified Data.ByteString.Char8 as BS
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import Data.Typeable
  
  import Network.HaskellNet.Auth
  import Network.HaskellNet.BSStream
  
  import Network.Mail.Mime
  
  import Prelude
  
  -- | All communication with server is done using @SMTPConnection@ value.
  data SMTPConnection = SMTPC {
    -- | Connection communication channel.
    bsstream :: !BSStream,
    -- | Server properties as per reply to the 'EHLO' request.
    _response :: ![ByteString]
    }
  
  -- | SMTP commands.
  --
  -- Supports basic and extended SMTP protocol without TLS support.
  --
  -- For each command we provide list of the expected reply codes that happens in success and failure cases
  -- respectively.
  data Command
    = -- | The @HELO@ command initiates the SMTP session conversation. The client greets the server and introduces itself.
      -- As a rule, HELO is attributed with an argument that specifies the domain name or IP address of the SMTP client.
      --
      -- Success: 250
      -- Failure: 504, 550
      HELO T.Text
    | -- | @EHLO@ is an alternative to HELO for servers that support the SMTP service extensions (ESMTP)
      --
      -- Success: 250
      -- Failure: 502, 504, 550
      EHLO T.Text
    | -- | @MAIL FROM@ command initiates a mail transfer. As an argument, MAIL FROM includes a sender mailbox (reverse-path)
      -- can accept optional parameters.
      --
      -- Success: 250
      --
      -- Failure: 451, 452, 455, 503, 550, 552, 553, 555
      MAIL T.Text
    | -- | The @RCPT TO@ command specifies exactly one recipient.
      --
      -- Success: 250 251
      --
      -- Failure: 450 451 452 455 503 550 551 552 553 555
      RCPT T.Text
    | -- | With the @DATA@ command, the client asks the server for permission to transfer the mail data.
      --
      -- Success: 250, 354
      --
      -- Failure: 450 451 452 503 550 552 554
      --
      -- Client just sends data and after receiving 354 starts streaming email, terminating transfer by
      -- sending @\r\n.\r\n@.
      DATA ByteString
    | -- |
      -- @EXPN@ is used to verify whether a mailing list in the argument exists on the local host.
      -- The positive response will specify the membership of the recipients.
      --
      -- Success: 250 252
      --
      -- Failure: 502 504 550
      EXPN T.Text
    | -- |
      -- @VRFY@ is used to verify whether a mailbox in the argument exists on the local host.
      -- The server response includes the user’s mailbox and may include the user’s full name.
      --
      -- Success: 250 251 252
      --
      -- Failure: 502 504 550 551 553
      VRFY T.Text
    | -- |
      -- With the @HELP@ command, the client requests a list of commands the server supports, may request
      -- help for specific command
      --
      -- Success: 211 214
      --
      -- Failure: 502 504
      HELP T.Text
    | -- | Authorization support
      AUTH AuthType UserName Password
    | -- | @NOOP@  can be used to verify if the connection is alive
      --
      -- Success: 250
      NOOP
    | -- | @RSET@ Resets the state
      --
      -- Success: 250
      RSET
    | -- | @QUIT@ asks server to close connection. Client should terminate the connection when receives
      -- status.
      --
      -- Success: 221
      QUIT
      deriving (Show, Eq)
  
  -- | Code reply from the server. It's always 3 digit integer.
  type ReplyCode = Int
  
  -- | Exceptions that can happen during communication.
  data SMTPException
    = -- | Reply code was not in the list of expected.
      --
      --  * @Command@ - command that was sent.
      --  * @[ReplyCode]@ -- list of expected codes
      --  * @ReplyCode@ -- the code that we have received
      --  * @ByteString@ -- additional data returned by the server.
      UnexpectedReply Command [ReplyCode] ReplyCode BS.ByteString
      -- | The server didn't accept the start of the message delivery
    | NotConfirmed ReplyCode BS.ByteString
      -- | The server does not support current authentication method
    | AuthNegotiationFailed ReplyCode BS.ByteString
      -- | Can't send email because no recipients were specified.
    | NoRecipients Mail
      -- | Received an unexpected greeting from the server.
    | UnexpectedGreeting ReplyCode
    deriving (Show)
    deriving (Typeable)
  
  instance Exception SMTPException where
    displayException (UnexpectedReply cmd expected code msg) =
      "Cannot execute command " ++ show cmd ++
         ", " ++ prettyExpected expected ++
         ", " ++ prettyReceived code msg
      where
        prettyReceived :: Int -> ByteString -> String
        prettyReceived co ms = "but received" ++ show co ++ " (" ++ BS.unpack ms ++ ")"
        prettyExpected :: [ReplyCode] -> String
        prettyExpected [x] = "expected reply code of " ++ show x
        prettyExpected xs = "expected any reply code of " ++ show xs
    displayException (NotConfirmed code msg) =
      "This server cannot accept any data. code: " ++ show code ++ ", msg: " ++ BS.unpack msg
    displayException (AuthNegotiationFailed code msg) =
      "Authentication failed. code: " ++ show code ++ ", msg: " ++ BS.unpack msg
    displayException (NoRecipients _mail) =
      "No recipients were specified"
    displayException (UnexpectedGreeting code) =
      "Expected greeting from the server, but got: " <> show code
  
  
  -- | Safe wrapper for running a client command over the SMTP
  -- connection.
  --
  -- /Note on current behavior/
  --
  -- We allow the command to fail several times, retry
  -- happens in case if we have received unexpected status code.
  -- In this case message will be sent again. However in case
  -- of other synchronous or asynchronous exceptions there will
  -- be no retries.
  --
  -- It case if number of retries were exceeded connection will
  -- be closed automatically.
  --
  -- The behaviors in notes will likely be changed in the future
  -- and should not be relied upon, see issues 76, 77.
  tryCommand
    :: SMTPConnection -- ^ Connection
    -> Command -- ^ Supported command
    -> Int -- ^ Number of allowed retries
    -> [ReplyCode] -- ^ List of accepted codes
    -> IO ByteString -- ^ Resulting data
  tryCommand conn cmd tries expectedReplies = do
      (code, msg) <- sendCommand conn cmd
      case () of
          _ | code `elem` expectedReplies -> return msg
          _ | tries > 1 ->
              tryCommand conn cmd (tries - 1) expectedReplies
            | otherwise ->
              throwIO $ UnexpectedReply cmd expectedReplies code msg
  
  -- | Read response from the stream. Response consists of the code
  -- and one or more lines of data.
  --
  -- In case if it's not the last line of reply the code is followed
  -- by the '-' sign. We return the code and all the data with the code
  -- stripped.
  --
  -- Eg.:
  --
  -- @
  -- "250-8BITMIME\\r"
  -- "250-PIPELINING\\r"
  -- "250-SIZE 42991616\\r"
  -- "250-AUTH LOGIN PLAIN XOAUTH2\\r"
  -- "250-DSN\\r"
  -- "250 ENHANCEDSTATUSCODES\\r"
  -- @
  --
  -- Returns:
  --
  -- @
  -- (250, "8BITMIME\\nPIPELINING\nSIZE 42991616\\nAUTH LOGIN PLAIN XOAUTH2\\nDSN\\nENHANCEDSTATUSCODES")
  -- @
  --
  -- Throws 'SMTPException'.
  parseResponse :: BSStream -> IO (ReplyCode, ByteString)
  parseResponse st =
      do (code, bdy) <- readLines
         return (read $ BS.unpack code, BS.unlines bdy)
      where readLines =
                do l <- bsGetLine st
                   let (c, bdy) = BS.span isDigit l
                   if not (BS.null bdy) && BS.head bdy == '-'
                      then do (c2, ls) <- readLines
                              return (c2, BS.tail bdy:ls)
                      else return (c, [BS.tail bdy])
  
  -- | Sends a 'Command' to the server. Function that performs all the logic
  -- for sending messages. Throws an exception if something goes wrong.
  --
  -- Throws 'SMTPException'.
  sendCommand
    :: SMTPConnection
    -> Command
    -> IO (ReplyCode, ByteString)
  sendCommand (SMTPC conn _) (DATA dat) =
      do bsPutCrLf conn "DATA"
         (code, msg) <- parseResponse conn
         unless (code == 354) $ throwIO $ NotConfirmed code msg
         mapM_ (sendLine . stripCR) $ BS.lines dat ++ [BS.pack "."]
         parseResponse conn
      where sendLine = bsPutCrLf conn
            stripCR bs = case BS.unsnoc bs of
                           Just (line, '\r') -> line
                           _                 -> bs
  sendCommand (SMTPC conn _) (AUTH LOGIN username password) =
      do bsPutCrLf conn command
         (_, _) <- parseResponse conn
         bsPutCrLf conn $ BS.pack userB64
         (_, _) <- parseResponse conn
         bsPutCrLf conn $ BS.pack passB64
         parseResponse conn
      where command = "AUTH LOGIN"
            (userB64, passB64) = login username password
  sendCommand (SMTPC conn _) (AUTH at username password) =
      do bsPutCrLf conn $ T.encodeUtf8 command
         (code, msg) <- parseResponse conn
         unless (code == 334) $ throwIO $ AuthNegotiationFailed code msg
         bsPutCrLf conn $ BS.pack $ auth at (BS.unpack msg) username password
         parseResponse conn
      where command = T.unwords ["AUTH", T.pack (show at)]
  sendCommand (SMTPC conn _) meth =
      do bsPutCrLf conn $! T.encodeUtf8 command
         parseResponse conn
      where command = case meth of
                        (HELO param) -> "HELO " <> param
                        (EHLO param) -> "EHLO " <> param
                        (MAIL param) -> "MAIL FROM:<" <> param <> ">"
                        (RCPT param) -> "RCPT TO:<" <> param <> ">"
                        (EXPN param) -> "EXPN " <> param
                        (VRFY param) -> "VRFY " <> param
                        (HELP msg)   -> if T.null msg
                                        then "HELP\r\n"
                                        else "HELP " <> msg
                        NOOP         -> "NOOP"
                        RSET         -> "RSET"
                        QUIT         -> "QUIT"
                        DATA _       -> error "sendCommand: impossible happened DATA command expected to be processed in thepreceeding clause"
                        AUTH _ _ _   -> error "sendCommand: impossible happened AUTH command expected to be processed in the preceeding clause"
  
  -- | Sends quit to the server. Connection must be terminated afterwards, i.e. it's not
  -- allowed to issue any command on this connection.
  quitSMTP :: SMTPConnection -> IO ()
  quitSMTP c = do
    _ <- tryCommand c QUIT 1 [221]
    pure ()
  
  -- | Terminates the connection. 'Quit' command is not send in this case.
  -- It's safe to issue this command at any time if the connection is still
  -- open.
  closeSMTP :: SMTPConnection -> IO ()
  closeSMTP (SMTPC conn _) = bsClose conn
  
  -- | Gracefully closes SMTP connection. Connection should be in available
  -- state. First it sends quit command and then closes connection itself.
  -- Connection should not be used after this command exits (even if it exits with an exception).
  -- This command may throw an exception in case of network failure or
  -- protocol failure when sending 'QUIT' command. If it happens connection
  -- nevertheless is closed.
  --
  -- @since 0.6
  gracefullyCloseSMTP :: SMTPConnection -> IO ()
  gracefullyCloseSMTP c@(SMTPC conn _) = quitSMTP c `finally` bsClose conn
  
  -- | Sends a mail to the server.
  --
  -- Throws 'SMTPException'.
  sendMailData :: Address -- ^ sender mail
           -> [Address] -- ^ receivers
           -> ByteString -- ^ data
           -> SMTPConnection
           -> IO ()
  sendMailData sender receivers dat conn = do
     sendAndCheck (MAIL (addressEmail sender))
     mapM_ (sendAndCheck . RCPT . addressEmail) receivers
     sendAndCheck (DATA dat)
     return ()
    where
      sendAndCheck cmd = tryCommand conn cmd 1 [250, 251]
  
  -- | Just a crlf constant.
  crlf :: BS.ByteString
  crlf = BS.pack "\r\n"
  
  -- | Write a message ending with ctlf.
  bsPutCrLf :: BSStream -> ByteString -> IO ()
  bsPutCrLf h s = bsPut h (s <> crlf)
  