/
Email.hs
146 lines (127 loc) · 5.82 KB
/
Email.hs
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
137
138
139
140
141
142
143
144
145
146
--------------------------------------------------------------------
-- |
-- Module : Email
-- Copyright : (c) Nicolas Pouillard 2008, 2009, 2010, 2011
-- License : BSD3
--
-- Maintainer: Nicolas Pouillard <nicolas.pouillard@gmail.com>
-- Stability : provisional
-- Portability:
--
--------------------------------------------------------------------
{-# LANGUAGE BangPatterns, Rank2Types, TemplateHaskell, TypeOperators,
OverloadedStrings, GeneralizedNewtypeDeriving #-}
module Email where
import Control.Applicative
import Control.Lens
import qualified Control.Exception as E
import qualified Data.ByteString.Lazy.Char8 as C
import qualified Data.ByteString.Lazy as B
{- TMP-NO-MIME
import Codec.MIME.Type (MIMEValueB)
import Codec.MIME.Parse (parseMIMEBody, safeParseMIMEBodyByteString, WithoutCRLF(..))
import System.IO.Unsafe (unsafePerformIO)
import Debug.Trace (trace)
-}
import Text.ParserCombinators.Parsec.Rfc2822 (Field(..), fields)
import Text.ParserCombinators.Parsec (parse)
import EOL (fixCrlfS {- TMP-NO-MIME, fixCrlfB -})
import System.IO.Error (isDoesNotExistError)
import System.Environment (getEnv)
import Codec.Mbox (Mbox(..), mboxMsgBody)
import Data.Maybe (listToMaybe, fromMaybe)
import Data.Char (toLower)
data Email = Email { _emailFields :: [Field]
-- TMP-NO-MIME , _emailContent :: MIMEValueB
, _emailContent :: B.ByteString
, _rawEmail :: B.ByteString
}
deriving (Show)
$(makeLenses ''Email)
myCunpack :: C.ByteString -> String
myCunpack = C.unpack
--myCunpack = unfoldr C.uncons
--myCunpack ys = case C.uncons ys of { Nothing -> [] ; Just (x,xs) -> x : myCunpack xs }
{-
Since parsing the full message is two slow, one first extract fields.
-- the old version
> readEmail = either (error . show) id . parse message "<string>" . fixCrlfS . myCunpack
-}
readFields :: B.ByteString -> [Field]
readFields input =
either err id . parse fields "<string>" . fixCrlfS . myCunpack $ input
where err e = error $ "Error in the following message <<EOS\n" ++ myCunpack input ++ "\nEOS\n\n" ++ show e
-- | Takes a message and reads only the fields part of it.
readFieldsOnly :: B.ByteString -> [Field]
readFieldsOnly inp = readFields . fst . fromMaybe err . splitAtNlNl $ inp
where err = error "readFieldsOnly: parse error"
{-
readField :: B.ByteString -> Field
readField input =
either err id . parse field "<string>" . myCunpack $ input
where err e = error $ "Error in the following line:\n " ++ show (myCunpack input) ++ "\n\n" ++ show e
readFields :: B.ByteString -> [Field]
readFields = map (readField . (`C.append` (C.pack "\r\n"))) . C.lines
-}
safeGetEnv :: String -> IO (Maybe String)
safeGetEnv s = (Just <$> getEnv s) `E.catch` \e -> if isDoesNotExistError e
then return Nothing
else ioError e -- I'm wondering if this could happen
{- TMP-NO-MIME
{-# NOINLINE dynParseMIMEBody #-}
dynParseMIMEBody :: [(String, String)] -> B.ByteString -> MIMEValueB
dynParseMIMEBody = unsafePerformIO $
do mode <- safeGetEnv "MIME_PARSING_MODE"
return $ case mode of
Just "string" -> \hdr -> fmap C.pack . parseMIMEBody hdr . fixCrlfS . C.unpack
Just "bytestring" -> \hdr -> parseMIMEBody hdr . fixCrlfB
Just "safe" -> \hdr -> safeParseMIMEBodyByteString hdr . fixCrlfB
Just "bytestringcrlf" -> \hdr -> fmap withoutCRLF . parseMIMEBody hdr . WithoutCRLF
Just other -> trace ("unknown MIME_PARSING_MODE " ++ other) parseMIMEBody
Nothing -> parseMIMEBody
-}
splitAtNlNl :: B.ByteString -> Maybe (B.ByteString, B.ByteString)
splitAtNlNl !orig = go 0 orig
where go !count !input = do
off <- (+1) <$> C.elemIndex '\n' input
let i' = C.drop off input
case C.uncons i' of
Nothing -> Just (C.take (off + count) orig, C.empty)
Just ('\n', i'') -> Just (C.take (off + count) orig, i'')
_ -> go (off + count) i'
readEmail :: B.ByteString -> Email
readEmail !orig = mkEmail $ fromMaybe (error "readEmail: parse error") $ splitAtNlNl orig
where
mkEmail ~(flds, body) =
Email { _emailFields = headers
--, emailContent = parseMIMEBody optional_headers (fixCrlfB body)
--, emailContent = fmap C.pack $ parseMIMEBody optional_headers (fixCrlfS (C.unpack body))
--, emailContent = safeParseMIMEBodyByteString optional_headers (fixCrlfB body)
{- TMP-NO-MIME
, _emailContent = dynParseMIMEBody optional_headers body
-}
, _emailContent = body
, _rawEmail = orig }
where headers = readFields flds
{- TMP-NO-MIME
optional_headers = [ (k,v) | OptionalField k v <- headers ]
-}
readMboxEmails :: Mbox B.ByteString -> [Email]
readMboxEmails = map (readEmail . view mboxMsgBody) . mboxMessages
stringOfField :: Field -> (String, String)
stringOfField (MessageID x) = ("message-id", fromMaybe (error "impossible: Email.stringOfField") $ unquote x)
stringOfField (Subject x) = ("subject", x)
stringOfField (OptionalField x y) = (map toLower x, y)
stringOfField x = ("x-unknown", show x) -- TODO
messageId :: Email -> Maybe String
messageId msg = listToMaybe [ mid | MessageID mid <- msg^.emailFields ]
messageSubject :: Email -> Maybe String
messageSubject msg = listToMaybe [ mid | Subject mid <- msg^.emailFields ]
{-
head ([show subject | Subject subject <- flds ]
++ ["(malformed subject) " ++ show subject | OptionalField "Subject" subject <- flds ]
++ ["no subject, body: " ++ ellipse 40 (show msg)])
-}
unquote :: String -> Maybe String
unquote ('<':xs) = listToMaybe [ys | zs == ">"] where (ys, zs) = break (=='>') xs
unquote _ = Nothing