1{-# LANGUAGE CPP #-}
2
3module Mail (fileMsg) where
4
5import Data.Char
6import Data.Maybe
7import Data.Time
8import Msg
9import System.IO
10import Text.Parsec
11import Text.Parsec.String
12
13----------------------------------------------------------------
14
15type Key = String
16newtype Value = Value { foldedLines :: [String] } deriving Show
17type Header = [(Key,Value)]
18
19getValue :: Key -> [(Key,Value)] -> Maybe String
20getValue key fs = concat . foldedLines <$> lookup key fs
21
22----------------------------------------------------------------
23
24fileMsg :: FilePath -> String -> IO (Maybe Msg)
25fileMsg file folder = makeMsg folder . header <$> readFileU8 file
26  where
27    readFileU8 fl = do
28        h <- openFile fl ReadMode
29#if __GLASGOW_HASKELL__ >= 611
30        hSetEncoding h latin1
31#endif
32        hGetContents h
33
34header :: String -> Header
35header = unfold . takeWhile (/= "") . lines
36
37unfold :: [String] -> Header
38unfold [] = []
39unfold (l:ls) = unfold' $ break (== ':') l
40  where
41    unfold' (_,[])   = unfold ls'
42    unfold' (k,_:v') = (key, Value (v:vs)) : unfold ls'
43      where
44        key = map toLower k
45        v   = dropWhile isSpace v'
46    vs  = takeWhile (isSpace . head) ls
47    ls' = dropWhile (isSpace . head) ls
48
49makeMsg :: FilePath -> Header -> Maybe Msg
50makeMsg folder hdr = messageID hdr >>= \vmyid ->
51  Just Msg {
52      myid = vmyid
53    , path = folder
54    , paid = messagePaID hdr
55    , date = messageDate hdr
56    }
57
58----------------------------------------------------------------
59
60messageID :: Header -> Maybe ID
61messageID hdr = getValue "message-id" hdr >>= parseMaybe msgid
62
63{-
64  (1) The In-Reply-To contains one ID, use it.
65  (2) The References contains one or more IDs, use the last one.
66  (3) The In-Reply-To contains two or more IDs, use the first one.
67-}
68
69messagePaID :: Header -> ID
70messagePaID hdr
71  | ilen == 1 = head is
72  | rlen /= 0 = last rs
73  | ilen /= 0 = head is
74  | otherwise = ""
75  where
76    ilen = length is
77    rlen = length rs
78    is = fromMaybe [] inReplyTo
79    rs = fromMaybe [] references
80    inReplyTo  = getValue "in-reply-to" hdr >>= parseMaybe msgids
81    references = getValue "references"  hdr >>= parseMaybe msgids
82
83messageDate :: Header -> String
84messageDate hdr = maybe "19700101000000" toStr (getValue "date" hdr >>= parseDate)
85  where
86    toStr :: UTCTime -> String
87    toStr  = formatTime defaultTimeLocale "%Y%m%d%H%M%S"
88
89parseDate :: String -> Maybe UTCTime
90parseDate cs = parseTimeM True defaultTimeLocale "%a, %e %b %Y %T %z" xs
91  where
92    (xs,_) = break (=='(') cs
93
94----------------------------------------------------------------
95
96parseMaybe :: Parser a -> String -> Maybe a
97parseMaybe p cs = either (const Nothing) Just (parse p "" cs)
98
99----------------------------------------------------------------
100
101msgid :: Parser String
102msgid = do
103    _ <- char '<'
104    left  <- many1 (oneOf dotAtom)
105    _ <- char '@'
106    right <- many1 (oneOf dotAtom)
107    _ <- char '>'
108    spaces
109    return $ "<" ++ left ++ "@" ++ right ++ ">"
110  where
111    dotAtom = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
112           ++ "!#$%&'*+-/=?^_`{|}~."
113
114msgids :: Parser [String]
115msgids = many1 msgid
116