Initial commit

1 files changed, 102 insertions, 0 deletions

diff --git a/src/Smtp.hs b/src/Smtp.hs
new file mode 100644
index 0000000..331f6d2
--- /dev/null
+++ b/src/Smtp.hs
@@ -0,0 +1,102 @@
+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