Initial commit

2 files changed, 181 insertions, 0 deletions

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