1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
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
|
