module Smtp (runServer) where

import Common (splitOn, trim)
import Control.Monad (unless, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State.Lazy (execStateT, modify)
import Intro
import qualified Mail as M
import Network.Socket (HostName, ServiceName, Socket, socketToHandle)
import qualified Queue as Q
import System.IO (Handle, IOMode (ReadWriteMode), hClose, hGetLine, hPutStrLn)
import qualified Tcp

runServer :: Maybe HostName -> ServiceName -> Q.QueueM M.Mail -> IO ()
runServer host port queue = Tcp.runServer host port (sockHandler queue)

sockHandler :: Q.QueueM M.Mail -> Socket -> IO ()
sockHandler queue s = do
  handle <- socketToHandle s ReadWriteMode
  hPutStrLn handle "220 service ready"
  go handle
 where
  go :: Handle -> IO ()
  go handle = do
    mail <- execStateT (commandHandler handle) M.newMail
    Q.push queue mail
    go handle

commandHandler :: Handle -> M.MailM ()
commandHandler h = do
  line <- liftIO $ hGetLine h
  let command = words line
  case command of
    ["EHLO", client] -> do
      modify (\s -> s{M.client = client})
      replyOk h
      commandHandler h
    ["HELO", client] -> do
      modify (\s -> s{M.client = client})
      replyOk h
      commandHandler h
    ["AUTH", _, _] -> do
      reply h 235 "authentication succeeded"
      commandHandler h
    ["MAIL", from] -> do
      modify (\s -> s{M.from = readFrom from})
      replyOk h
      commandHandler h
    ["RCPT", to] -> do
      modify (\s -> s{M.to = readTo to : M.to s})
      replyOk h
      commandHandler h
    ["DATA"] -> do
      reply h 354 "start mail input"
      dataHandler h
    ["RSET"] -> do
      modify (const M.newMail)
      replyOk h
    ["QUIT"] -> do
      replyByeAndClose h
    ["NOOP"] -> replyOk h
    _ -> do
      reply h 500 "unknown command"
      liftIO $ putStrLn ("Unknown command: " ++ line)
  pure ()

dataHandler :: Handle -> M.MailM ()
dataHandler handle = do
  readData []
  replyOk handle
  replyByeAndClose handle
 where
  readData :: [String] -> M.MailM ()
  readData xs = do
    line <- liftIO $ hGetLine handle
    let cont = trim line /= "."
    when cont $ readData (line : xs)
    unless cont $ modify (M.setData $ reverse xs)

reply :: Handle -> Int -> String -> M.MailM ()
reply handle status message =
  liftIO
    $ hPutStrLn handle
    $ mconcat [show status, " ", message]

replyOk :: Handle -> M.MailM ()
replyOk handle = reply handle 250 "ok"

replyByeAndClose :: Handle -> M.MailM ()
replyByeAndClose handle = do
  reply handle 221 "closing channel"
  liftIO $ hClose handle

readFrom :: String -> String
readFrom s = filter (\c -> c /= '<' && c /= '>') $ case splitOn (== ':') s of
  ["FROM", addr] -> addr
  _ -> s

readTo :: String -> String
readTo s = filter (\c -> c /= '<' && c /= '>') $ case splitOn (== ':') s of
  ["TO", addr] -> addr
  _ -> s