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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
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
|
