Initial commit

13 files changed, 868 insertions, 0 deletions

diff --git a/src/Cache.hs b/src/Cache.hs
new file mode 100644
index 0000000..b009770
--- /dev/null
+++ b/src/Cache.hs
@@ -0,0 +1,46 @@
+module Cache (newInMemory, start, CacheM, getInbox) where
+
+import Control.Concurrent.STM
+  ( TVar
+  , atomically
+  , newTVarIO
+  , readTVar
+  , readTVarIO
+  , writeTVar
+  )
+import Intro
+import qualified Mail as M
+import qualified Queue as Q
+
+data Cache = Cache
+  { count :: Int
+  , inbox :: [M.Mail]
+  }
+
+type CacheM = TVar Cache
+
+newInMemory :: IO CacheM
+newInMemory = newTVarIO newCache
+
+start :: Q.QueueM M.Mail -> CacheM -> IO ()
+start queue cache = go
+ where
+  go :: IO ()
+  go = do
+    mail <- Q.pull queue
+    updateCache cache (`addMail` mail)
+    go
+
+getInbox :: CacheM -> IO [M.Mail]
+getInbox c = inbox <$> readTVarIO c
+
+newCache :: Cache
+newCache = Cache 0 []
+
+addMail :: Cache -> M.Mail -> Cache
+addMail cache mail = cache{count = count cache + 1, inbox = mail : inbox cache}
+
+updateCache :: CacheM -> (Cache -> Cache) -> IO ()
+updateCache c f = atomically $ do
+  cache <- readTVar c
+  writeTVar c (f cache)
diff --git a/src/Common.hs b/src/Common.hs
new file mode 100644
index 0000000..91bf708
--- /dev/null
+++ b/src/Common.hs
@@ -0,0 +1,82 @@
+module Common
+  ( toLower
+  , trim
+  , trimWith
+  , splitOn
+  , split2
+  , replace
+  , (!!?)
+  , findVal
+  , maybeAt
+  , startsWith
+  , delete
+  )
+where
+
+import Data.Char (isSpace)
+import qualified Data.Char as C
+import Data.List (find, stripPrefix)
+import Intro
+
+trim :: String -> String
+trim = f . f
+ where
+  f = reverse . dropWhile isSpace
+
+trimWith :: (Char -> Bool) -> String -> String
+trimWith p = f . f
+ where
+  f = reverse . dropWhile p
+
+splitOn :: (a -> Bool) -> [a] -> [[a]]
+splitOn p s = case dropWhile p s of
+  [] -> []
+  s' -> w : splitOn p s''
+   where
+    (w, s'') = break p s'
+
+split2 :: (a -> Bool) -> [a] -> ([a], [a])
+split2 p s =
+  case break p s of
+    (x, _ : y) -> (x, y)
+    (x, []) -> (x, [])
+
+infix 9 !!?
+
+(!!?) :: [a] -> Int -> Maybe a
+(!!?) xs i
+  | i < 0 = Nothing
+  | otherwise = go i xs
+ where
+  go :: Int -> [a] -> Maybe a
+  go 0 (x : _) = Just x
+  go j (_ : ys) = go (j - 1) ys
+  go _ [] = Nothing
+
+maybeAt :: Int -> [a] -> Maybe a
+maybeAt = flip (!!?)
+
+toLower :: String -> String
+toLower = fmap C.toLower
+
+startsWith :: (a -> Bool) -> [a] -> Bool
+startsWith _ [] = False
+startsWith p (x : _) = p x
+
+findVal :: (a -> Bool) -> [(a, b)] -> Maybe b
+findVal p xs = snd <$> find (p . fst) xs
+
+replace :: (Eq a) => [a] -> [a] -> [a] -> [a]
+replace [] to xs = go xs
+ where
+  go [] = to
+  go (x : xs') = to ++ x : go xs'
+replace from to xs | Just xs' <- stripPrefix from xs = to ++ replace from to xs'
+replace from to (x : xs) = x : replace from to xs
+replace _ _ [] = []
+
+delete :: (a -> Bool) -> [a] -> (Maybe a, [a])
+delete p = foldr f (Nothing, [])
+ where
+  f x (Nothing, xs) | p x = (Just x, xs)
+  f x (m, xs) = (m, x : xs)
diff --git a/src/Common/Mime.hs b/src/Common/Mime.hs
new file mode 100644
index 0000000..5356312
--- /dev/null
+++ b/src/Common/Mime.hs
@@ -0,0 +1,23 @@
+module Common.Mime (getType, getSubtype, MimeType (..)) where
+
+import Common (split2, trim)
+import Intro
+
+data MimeType = Text String | Image String | Application String
+
+getType :: String -> Maybe MimeType
+getType mime = case type_ of
+  "text" -> Just (Text subtype)
+  "image" -> Just (Image subtype)
+  "application" -> Just (Application subtype)
+  _ -> Nothing
+ where
+  (type_, subtype) = split2 (== '/') $ trim mime
+
+getSubtype :: String -> String
+getSubtype = trim . snd . split2 (== '/')
+
+instance Show MimeType where
+  show (Text sub) = "text/" ++ sub
+  show (Image sub) = "image/" ++ sub
+  show (Application sub) = "application/" ++ sub
diff --git a/src/Html.hs b/src/Html.hs
new file mode 100644
index 0000000..dd60e16
--- /dev/null
+++ b/src/Html.hs
@@ -0,0 +1,88 @@
+module Html (span, html, p, hr, div_, iframe, img, main_, ul, li, table, td, th, tr, a) where
+
+import Data.List (unwords)
+import Intro
+
+type Attr = (String, String)
+
+html :: [String] -> String
+html xs =
+  concat
+    [ "<html>"
+    , "<head>"
+    , script
+        [ "function resizeIframe(x) { \
+          \  x.style.height = x.contentWindow.document.documentElement.scrollHeight + 'px'; \
+          \}"
+        ]
+    , "</head>"
+    , "<body>"
+    , style
+        [ ":root { font-size: 16px; }"
+        , "* { padding: 0; margin: 0; }"
+        , "body { display: flex; flex-direction: column; gap: 1rem; padding: 1rem; }"
+        , "hr { height: 0; border: 0; border-top: 1px solid #000; }"
+        , "table { border-collapse: collapse; width: 100%; }"
+        , "td, th { border: 1px solid #000; padding: 0.4rem; }"
+        , "iframe { width: 100%; min-height: 80vh; border: none; }"
+        , "main { display: flex; flex-direction: column; gap: 1rem; }"
+        , ".part { background-color: #eee; }"
+        , ".part-body { padding: 1rem; }"
+        ]
+    , concat xs
+    , "</body></html>"
+    ]
+
+hr :: String
+hr = "<hr>"
+
+style :: [String] -> String
+style xs = concat ["<style>", concat xs, "</style>"]
+
+script :: [String] -> String
+script xs = concat ["<script>", concat xs, "</script>"]
+
+iframe :: [Attr] -> [String] -> String
+iframe xs ys = concat ["<iframe onload='resizeIframe(this)' ", attrs xs, ">", concat ys, "</iframe>"]
+
+div_ :: [Attr] -> [String] -> String
+div_ xs ys = concat ["<div ", attrs xs, ">", concat ys, "</div>"]
+
+main_ :: [String] -> String
+main_ xs = concat ["<main>", concat xs, "</main>"]
+
+p :: [String] -> String
+p xs = concat ["<p>", concat xs, "</p>"]
+
+span :: [String] -> String
+span xs = concat ["<span>", concat xs, "</span>"]
+
+a :: [Attr] -> [String] -> String
+a xs ys = concat ["<a ", attrs xs, ">", concat ys, "</a>"]
+
+table :: [String] -> String
+table xs = concat ["<table>", concat xs, "</table>"]
+
+td :: [String] -> String
+td xs = concat ["<td>", concat xs, "</td>"]
+
+th :: [String] -> String
+th xs = concat ["<th>", concat xs, "</th>"]
+
+tr :: [String] -> String
+tr xs = concat ["<tr>", concat xs, "</tr>"]
+
+ul :: [String] -> String
+ul xs = concat ["<ul>", concat xs, "</ul>"]
+
+li :: [String] -> String
+li xs = concat ["<li>", concat xs, "</li>"]
+
+img :: [Attr] -> String
+img xs = concat ["<img ", attrs xs, ">"]
+
+attr :: Attr -> String
+attr (k, v) = concat [k, "='", v, "'"]
+
+attrs :: [Attr] -> String
+attrs xs = unwords (attr <$> xs)
diff --git a/src/Http.hs b/src/Http.hs
new file mode 100644
index 0000000..f486920
--- /dev/null
+++ b/src/Http.hs
@@ -0,0 +1,75 @@
+module Http (runServer) where
+
+import qualified Cache as C
+import Common (maybeAt, splitOn)
+import qualified Html as H
+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
+import qualified Template as T
+import Text.Read (readMaybe)
+
+runServer :: Maybe HostName -> ServiceName -> C.CacheM -> Q.QueueM M.Mail -> IO ()
+runServer host port cache queue = Tcp.runServer host port (sockHandler cache queue)
+
+sockHandler :: C.CacheM -> Q.QueueM M.Mail -> Socket -> IO ()
+sockHandler cache queue s = do
+  handle <- socketToHandle s ReadWriteMode
+  requestHandler handle cache queue
+
+requestHandler :: Handle -> C.CacheM -> Q.QueueM M.Mail -> IO ()
+requestHandler h cache queue = do
+  line <- hGetLine h
+  case route line of
+    ("GET", []) -> showInbox h cache
+    ("GET", ["poll", s]) -> showPolled h queue s
+    ("GET", ["mail", n]) -> case (readMaybe n :: Maybe Int) of
+      Just n' -> showMail h cache n'
+      Nothing -> showNotFound h
+    _ -> showNotFound h
+  hClose h
+
+showNotFound :: Handle -> IO ()
+showNotFound h = do
+  replyHtml h 404 [H.p ["Page not found"]]
+
+showInbox :: Handle -> C.CacheM -> IO ()
+showInbox h cache = do
+  inbox <- C.getInbox cache
+  replyHtml h 200 (T.inbox inbox)
+
+showMail :: Handle -> C.CacheM -> Int -> IO ()
+showMail h cache idx = do
+  mail <- maybeAt idx <$> C.getInbox cache
+  case mail of
+    Just mail' -> replyHtml h 200 (T.mail mail')
+    Nothing -> showNotFound h
+
+showPolled :: Handle -> Q.QueueM M.Mail -> String -> IO ()
+showPolled h queue s = do
+  mail <- Q.pullWith (\m -> m.to == [s]) queue
+  replyHtml h 200 (T.mail mail)
+
+route :: String -> (String, [String])
+route x = case words x of
+  [m, p, "HTTP/1.1"] -> (m, splitOn (== '/') p)
+  _ -> ("GET", [])
+
+replyHtml :: Handle -> Int -> [String] -> IO ()
+replyHtml h s body = do
+  let page = H.html body
+  hPutStrLn h $ "HTTP/1.1 " ++ status s
+  hPutStrLn h "content-type: text/html"
+  hPutStrLn h $ "content-length: " ++ show (length page)
+  hPutStrLn h ""
+  hPutStrLn h page
+  hPutStrLn h ""
+
+status :: Int -> String
+status s = case s of
+  200 -> "200 OK"
+  404 -> "404 NOT FOUND"
+  _ -> "500 INTERNAL SERVER ERROR"
diff --git a/src/Intro.hs b/src/Intro.hs
new file mode 100644
index 0000000..46e35d4
--- /dev/null
+++ b/src/Intro.hs
@@ -0,0 +1,50 @@
+module Intro
+  ( ($)
+  , (&&)
+  , (+)
+  , (++)
+  , (-)
+  , (.)
+  , (/=)
+  , (<$>)
+  , (<)
+  , (=<<)
+  , (==)
+  , (>>=)
+  , (||)
+  , Bool (False, True)
+  , Char
+  , Eq
+  , IO
+  , Int
+  , Maybe (Just, Nothing)
+  , Either (Left, Right)
+  , Show
+  , String
+  , break
+  , concat
+  , const
+  , curry
+  , dropWhile
+  , filter
+  , flip
+  , foldr
+  , fst
+  , head
+  , length
+  , fmap
+  , mconcat
+  , not
+  , otherwise
+  , pure
+  , putStrLn
+  , reverse
+  , show
+  , snd
+  , words
+  , zip
+  , zipWith
+  )
+where
+
+import Prelude
diff --git a/src/Mail.hs b/src/Mail.hs
new file mode 100644
index 0000000..830f4da
--- /dev/null
+++ b/src/Mail.hs
@@ -0,0 +1,39 @@
+module Mail
+  ( Mail (..)
+  , subject
+  , Header
+  , P.Part (..)
+  , MailM
+  , newMail
+  , setData
+  )
+where
+
+import Common (toLower)
+import Control.Monad.State.Lazy (StateT)
+import Data.List (find)
+import Intro
+import Mail.Header (Header)
+import qualified Mail.Parser as P
+
+data Mail = Mail
+  { client :: String
+  , from :: String
+  , to :: [String]
+  , headers :: [Header]
+  , body :: [P.Part]
+  }
+  deriving (Show, Eq)
+
+type MailM a = StateT Mail IO a
+
+newMail :: Mail
+newMail = Mail "" "" [] [] []
+
+setData :: [String] -> Mail -> Mail
+setData xs m = m{headers = msg.headers, body = msg.body}
+ where
+  msg = P.run xs
+
+subject :: Mail -> Maybe String
+subject m = snd <$> find (\(k, _) -> toLower k == "subject") (headers m)
diff --git a/src/Mail/Header.hs b/src/Mail/Header.hs
new file mode 100644
index 0000000..e7265b2
--- /dev/null
+++ b/src/Mail/Header.hs
@@ -0,0 +1,45 @@
+module Mail.Header
+  ( ContentType (..)
+  , Header
+  , contentType
+  , contentTransferEncoding
+  )
+where
+
+import Common (findVal, split2, splitOn, toLower, trim, trimWith)
+import Intro
+
+type Header = (String, String)
+
+data ContentType = ContentType
+  { mime :: String
+  , boundary :: Maybe String
+  , charset :: Maybe String
+  }
+  deriving (Show)
+
+newContentType :: String -> ContentType
+newContentType m = ContentType{mime = m, boundary = Nothing, charset = Nothing}
+
+contentType :: [Header] -> Maybe ContentType
+contentType xs = do
+  v <- findValIns "content-type" xs
+  case (fmap trim . splitOn (== ';')) v of
+    [y] -> pure (newContentType y)
+    y : ys ->
+      let kv = fmap (split2 (== '=')) ys
+       in pure
+            $ (newContentType y)
+              { boundary = trimQuotes <$> findValIns "boundary" kv
+              , charset = findValIns "charset" kv
+              }
+    [] -> Nothing
+
+contentTransferEncoding :: [Header] -> Maybe String
+contentTransferEncoding = findValIns "content-transfer-encoding"
+
+findValIns :: String -> [Header] -> Maybe String
+findValIns k = findVal ((== k) . toLower)
+
+trimQuotes :: String -> String
+trimQuotes = trimWith (\x -> x == '"' || x == ' ')
diff --git a/src/Mail/Parser.hs b/src/Mail/Parser.hs
new file mode 100644
index 0000000..090602c
--- /dev/null
+++ b/src/Mail/Parser.hs
@@ -0,0 +1,136 @@
+module Mail.Parser (run, Message (..), Part (..)) where
+
+import Common (startsWith, trim)
+import Control.Monad.State (State, evalState, get, gets, modify)
+import Data.Char (isSpace)
+import Data.List (intercalate)
+import Intro
+import Mail.Header (Header)
+import qualified Mail.Header as H
+
+data Message = Message
+  { headers :: [Header]
+  , body :: [Part]
+  }
+  deriving (Show)
+
+data Part = Part
+  { headers :: [Header]
+  , body :: String -- TOOD: Scoped Fields extension
+  }
+  deriving (Show, Eq)
+
+data ParserState = InHeader (Maybe Header) | InBody deriving (Show, Eq)
+
+data Parser = Parser
+  { pHeaders :: [Header]
+  , pBody :: [String]
+  , pState :: ParserState
+  , pErrors :: [String]
+  }
+  deriving (Show)
+
+type MessageM = State Parser Message
+
+type PartM = State Parser Part
+
+newParser :: Parser
+newParser = Parser [] [] (InHeader Nothing) []
+
+run :: [String] -> Message
+run xs = evalState (parseMail xs) newParser
+
+parseMail :: [String] -> MessageM
+parseMail [] = gets (evalState parseMailBody)
+parseMail (x : xs) = do
+  s <- get
+  case pState s of
+    InHeader Nothing
+      | trim x == "" -> modify (setState InBody)
+      | otherwise -> case kv x of
+          Just (k, v) -> modify (setInHeader (k, v))
+          Nothing -> modify (setInHeaderStart . pushError x)
+    InHeader (Just (k, v))
+      | trim x == "" -> modify (setState InBody . pushHeader (k, v))
+      | startsWith isSpace x -> modify (setInHeader (k, v ++ x))
+      | otherwise -> case kv x of
+          Just (k', v') -> modify (setInHeader (k', v') . pushHeader (k, v))
+          Nothing -> modify (setInHeaderStart . pushHeader (k, v) . pushError x)
+    InBody -> modify (pushBody x)
+  parseMail xs
+
+parseMailBody :: MessageM
+parseMailBody = do
+  s <- get
+  pure $ case getBoundary s of
+    Just boundary ->
+      Message
+        { headers = pHeaders s
+        , body = getPart <$> bodyParts (reverse $ pBody s) boundary
+        }
+    Nothing ->
+      Message
+        { headers = pHeaders s
+        , body = [Part{headers = [], body = intercalate "\r\n" . reverse $ pBody s}]
+        }
+ where
+  getBoundary s = H.boundary =<< (H.contentType . pHeaders) s
+  getPart part = evalState (parsePart part) newParser
+
+parsePart :: [String] -> PartM
+parsePart [] = do
+  s <- get
+  pure $ Part{headers = pHeaders s, body = intercalate "\r\n" . reverse $ pBody s}
+parsePart (x : xs) = do
+  s <- get
+  case pState s of
+    InHeader Nothing
+      | trim x == "" -> modify (setState InBody)
+      | otherwise -> case kv x of
+          Just (k, v) -> modify (setInHeader (k, v))
+          Nothing -> modify (setInHeaderStart . pushError x)
+    InHeader (Just (k, v))
+      | trim x == "" -> modify (setState InBody . pushHeader (k, v))
+      | startsWith isSpace x -> modify (setInHeader (k, v ++ x))
+      | otherwise -> case kv x of
+          Just (k', v') -> modify (setInHeader (k', v') . pushHeader (k, v))
+          Nothing -> modify (setInHeaderStart . pushHeader (k, v) . pushError x)
+    InBody -> modify (pushBody x)
+  parsePart xs
+
+pushHeader :: Header -> Parser -> Parser
+pushHeader x p = p{pHeaders = (trim <$> x) : pHeaders p}
+
+pushBody :: String -> Parser -> Parser
+pushBody x p = p{pBody = trim x : pBody p}
+
+pushError :: String -> Parser -> Parser
+pushError x p = p{pErrors = x : pErrors p}
+
+setState :: ParserState -> Parser -> Parser
+setState x p = p{pState = x}
+
+setInHeaderStart :: Parser -> Parser
+setInHeaderStart p = p{pState = InHeader Nothing}
+
+setInHeader :: Header -> Parser -> Parser
+setInHeader x p = p{pState = InHeader $ Just x}
+
+kv :: String -> Maybe (String, String)
+kv x =
+  case break (== ':') x of
+    (k, _ : v) -> Just (k, v)
+    (_, []) -> Nothing
+
+bodyParts :: [String] -> String -> [[String]]
+bodyParts lines' boundary = filter (not . isEmptyPart) $ go lines' [] []
+ where
+  go :: [String] -> [String] -> [[String]] -> [[String]]
+  go [] _ parts = parts
+  go (x : xs) acc parts
+    | trim x == ("--" ++ boundary) = go xs [] (reverse acc : parts)
+    | otherwise = go xs (x : acc) parts
+
+isEmptyPart :: [String] -> Bool
+isEmptyPart [""] = True
+isEmptyPart _ = False
diff --git a/src/Queue.hs b/src/Queue.hs
new file mode 100644
index 0000000..56af251
--- /dev/null
+++ b/src/Queue.hs
@@ -0,0 +1,65 @@
+module Queue
+  ( Queue
+  , QueueM
+  , newQueue
+  , push
+  , pull
+  , pullWith
+  )
+where
+
+import Common (delete)
+import Control.Concurrent.STM
+  ( TChan
+  , TMVar
+  , TVar
+  , atomically
+  , newEmptyTMVarIO
+  , newTChan
+  , newTVar
+  , readTChan
+  , readTVar
+  , readTVarIO
+  , takeTMVar
+  , tryPutTMVar
+  , writeTChan
+  , writeTVar
+  )
+import Control.Monad (when)
+import Intro
+
+type Selector a = (a -> Bool)
+
+data Queue a = Queue
+  { inner :: TChan a
+  , selectors :: [(Selector a, TMVar a)]
+  }
+
+type QueueM a = TVar (Queue a)
+
+newQueue :: IO (QueueM a)
+newQueue = atomically $ do
+  chan <- newTChan
+  newTVar $ Queue chan []
+
+pullWith :: Selector a -> QueueM a -> IO a
+pullWith p queueM = do
+  q <- readTVarIO queueM
+  t <- newEmptyTMVarIO
+  atomically $ writeTVar queueM (q{selectors = (p, t) : q.selectors})
+  atomically $ takeTMVar t
+
+push :: QueueM a -> a -> IO ()
+push queueM x = atomically $ do
+  q <- readTVar queueM
+  case delete (\(p, _) -> p x) q.selectors of
+    (Just (_, t), xs) -> do
+      writeTChan q.inner x
+      isPut <- tryPutTMVar t x
+      when isPut $ writeTVar queueM (q{selectors = xs})
+    (Nothing, _) -> writeTChan q.inner x
+
+pull :: QueueM a -> IO a
+pull queueM = atomically $ do
+  q <- readTVar queueM
+  readTChan q.inner
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
diff --git a/src/Tcp.hs b/src/Tcp.hs
new file mode 100644
index 0000000..d0ee6c9
--- /dev/null
+++ b/src/Tcp.hs
@@ -0,0 +1,50 @@
+module Tcp (runServer) where
+
+import Control.Concurrent (forkFinally)
+import qualified Control.Exception as E
+import Control.Monad (forever, void)
+import Intro
+import Network.Socket
+  ( AddrInfoFlag (AI_PASSIVE)
+  , HostName
+  , ServiceName
+  , Socket
+  , SocketOption (ReuseAddr)
+  , SocketType (Stream)
+  , accept
+  , addrAddress
+  , addrFlags
+  , addrSocketType
+  , bind
+  , close
+  , defaultHints
+  , getAddrInfo
+  , gracefulClose
+  , listen
+  , openSocket
+  , setCloseOnExecIfNeeded
+  , setSocketOption
+  , withFdSocket
+  , withSocketsDo
+  )
+
+runServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a
+runServer host port server = withSocketsDo $ do
+  addr <- resolve
+  E.bracket (open addr) close go
+ where
+  resolve = do
+    let hints = defaultHints{addrFlags = [AI_PASSIVE], addrSocketType = Stream}
+    head <$> getAddrInfo (Just hints) host (Just port)
+  open addr = E.bracketOnError (openSocket addr) close $ \sock -> do
+    setSocketOption sock ReuseAddr 1
+    withFdSocket sock setCloseOnExecIfNeeded
+    bind sock $ addrAddress addr
+    listen sock 1024
+    pure sock
+  go :: Socket -> IO a
+  go sock = forever
+    $ E.bracketOnError (accept sock) (close . fst)
+    $ \(conn, _peer) ->
+      void
+        $ forkFinally (server conn) (const $ gracefulClose conn 5000)
diff --git a/src/Template.hs b/src/Template.hs
new file mode 100644
index 0000000..ff13bd3
--- /dev/null
+++ b/src/Template.hs
@@ -0,0 +1,67 @@
+module Template (inbox, mail) where
+
+import Common (replace)
+import qualified Common.Mime as Mime
+import Data.List (intercalate)
+import Data.Maybe (fromMaybe)
+import qualified Html as H
+import Intro
+import qualified Mail as M
+import qualified Mail.Header as H
+
+inbox :: [M.Mail] -> [String]
+inbox xs =
+  [ H.p [show $ length xs, " messages."]
+  , H.table $ inboxHeader : zipWith (curry inboxRow) [0 ..] xs
+  ]
+
+inboxHeader :: String
+inboxHeader = H.tr [H.th ["Subject"], H.th ["From"], H.th ["To"]]
+
+inboxRow :: (Int, M.Mail) -> String
+inboxRow (i, m) =
+  H.tr
+    [ H.td [H.a [("href", "/mail/" ++ show i)] [fromMaybe "No subject" (M.subject m)]]
+    , H.td [M.from m]
+    , H.td (M.to m)
+    ]
+
+mail :: M.Mail -> [String]
+mail m =
+  [ H.a [("href", "/")] ["Inbox"]
+  , H.p ["From: ", M.from m]
+  , H.p ["To: ", intercalate ", " $ M.to m]
+  , H.table (mailHeader <$> m.headers)
+  , H.hr
+  , H.main_ (fmap (H.div_ [("class", "part")] . mailPart) m.body)
+  ]
+
+mailHeader :: M.Header -> String
+mailHeader (k, v) = H.tr [H.td [k], H.td [v]]
+
+mailPart :: M.Part -> [String]
+mailPart p =
+  [ H.table (mailHeader <$> p.headers)
+  , H.div_ [("class", "part-body")] [mailPartBody p]
+  ]
+
+mailPartBody :: M.Part -> String
+mailPartBody p = case (mimeType, encoding) of
+  (Just (Mime.Image _), Just "base64") -> H.img [("src", concat ["data:", show mimeType, ";base64,", p.body])]
+  (_, Just "quoted-printable") -> H.iframe [("srcdoc", decodeQP p.body)] []
+  _ -> H.iframe [("srcdoc", p.body)] []
+ where
+  mimeType = (H.contentType p.headers) >>= Mime.getType . H.mime
+  encoding = H.contentTransferEncoding p.headers
+
+-- "Handles" the "quoted-printable" encoding:
+-- https://datatracker.ietf.org/doc/html/rfc1521#section-5.1
+-- This is just wrong (or, wronger than the rest), but this part of the spec
+-- is crazy, so, whatever.
+decodeQP :: String -> String
+decodeQP =
+  replace "=3D" "="
+    . replace "=C2" ""
+    . replace "=A0" " "
+    . replace "=\r" ""
+    . replace "=\r\n" ""