blob: db6f17b46509d25140dbd81c4eb4b23d5a3be178 (
plain)
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
|
{- Email accessors.
-
- Copyright 2013 Raúl Benencia <rul@kalgan.cc>
-
- Licensed under the GNU GPL version 3 or higher
-
-}
module Email where
import Codec.MIME.Type(MIMEValue(..), MIMEContent(..), showMIMEType, Type(..), MIMEType(..))
import Data.Char(toLower)
import Data.List(find)
getBody :: MIMEValue -> String
getBody msg =
case mime_val_content msg of
Single c -> c
Multi mvs -> case firstTextPart mvs of
Just mv -> unwrapContent . mime_val_content $ mv
Nothing -> "This email has no displayable content."
where
unwrapContent (Single c) = c
-- hackish function for showing the email. In he future the logic of this
-- function should be improved.
firstTextPart [] = Nothing
firstTextPart (mv:mvs) = case mime_val_content mv of
Single c -> if isText mv then Just mv else firstTextPart mvs
Multi mvs' -> firstTextPart mvs'
where
isText = \mv -> case (mimeType $ mime_val_type mv) of
Text text -> True
_ -> False
getHeaders :: MIMEValue -> [(String,String)]
getHeaders = mime_val_headers
-- | Convert a String to multiple Strings, cropped by the maximum column
-- size if necessary.
formatBody :: String -> Int -> [String]
formatBody body maxColumns = format [] [] body where
format parsed acc [] = parsed ++ [acc]
format parsed acc ('\r':'\n':xs) = format (parsed ++ [acc]) [] xs
format parsed acc rest@(x:xs) | length acc < maxColumns = format parsed (acc ++ [x]) xs
| otherwise = format (parsed ++ [acc]) "+" rest
-- The following function is a verbatim copy of the unexported function in
-- Codec.MIME.Parse.
-- case in-sensitive lookup of field names or attributes\/parameters.
lookupField' :: String -> [(String,a)] -> Maybe a
lookupField' n ns =
-- assume that inputs have been mostly normalized already
-- (i.e., lower-cased), but should the lookup fail fall back
-- to a second try where we do normalize before giving up.
case lookup n ns of
x@Just{} -> x
Nothing ->
let nl = map toLower n in
case find (\ (y,_) -> nl == map toLower y) ns of
Nothing -> Nothing
Just (_,x) -> Just x
unwrapField = maybe "" id
lookupField n ns = unwrapField $ lookupField' n ns
{-import Text.Parsec.Error(ParseError)
import Text.ParserCombinators.Parsec (parse)
import Text.ParserCombinators.Parsec.Rfc2822
parseEmail :: String -> Message
parseEmail msg = unwrapEmail $ parse message "<stdin>" $ fixEol msg
unwrapEmail (Right email) = email
getFields (Message fs _) = fs
-- There is obviously a pattern here. Find a way to narrow it down.
getReturnPath fs = do { ReturnPath f <- fs; f }
getFrom fs = do { From f <- fs; f }
getTo fs = do { To f <- fs; f }
getCc fs = do { Cc f <- fs; f }
getBcc fs = do { Bcc f <- fs; f }
getReplyTo fs = do { ReplyTo f <- fs; f }
getSubject fs = do { Subject f <- fs; f }
getMessageID fs = do { MessageID f <- fs; f }
getInReplyTo fs = do { InReplyTo f <- fs; f }
getReferences fs = do { References f <- fs; f }
getComments fs = do { Comments f <- fs; f }
getKeywords fs = do { Keywords f <- fs; f }
--getDate fs = do { Date f <- fs; f }
--getResentDate fs = do { ResentDate f <- fs; f }
getResentFrom fs = do { ResentFrom f <- fs; f }
--getResentSender fs = do { ResentSender f <- fs; f }
getResentTo fs = do { ResentTo f <- fs; f }
getResentCc fs = do { ResentCc f <- fs; f }
getResentBcc fs = do { ResentBcc f <- fs; f }
getResentMessageID fs = do { ResentMessageID f <- fs; f }
--getReceived fs = do { Received f <- fs; f }
getBody (Message _ []) = "Empty body"
getBody (Message _ body) = body
-- Make sure all lines are terminated by CRLF.
fixEol :: String -> String
fixEol ('\r':'\n':xs) = '\r' : '\n' : fixEol xs
fixEol ('\n':xs) = '\r' : '\n' : fixEol xs
fixEol (x:xs) = x : fixEol xs
fixEol [] = []-}
|
