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