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
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Notmuch.Message where
import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Notmuch.Class
import qualified Data.ByteString.Lazy.Char8 as LBS8
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.CaseInsensitive as CI
import qualified Data.Vector as V
import qualified Data.Tree as TR
newtype MessageID = MessageID { unMessageID :: String }
deriving (Show, Read, Eq, FromJSON)
type MessageHeaders = M.Map (CI.CI T.Text) T.Text
data MessageContent = ContentText T.Text
| ContentRaw LBS8.ByteString Int
| ContentMultipart [MessagePart]
| ContentMsgRFC822 [(MessageHeaders, [MessagePart])]
deriving (Show)
data MessagePart = MessagePart {
partID :: Int
, partContentType :: CI.CI T.Text
, partContentCharset :: Maybe (CI.CI T.Text)
, partContentFilename :: Maybe T.Text
, partContent :: MessageContent
}
deriving (Show)
instance Eq MessagePart where
a == b = partID a == partID b
contentSize :: MessageContent -> Int
contentSize (ContentText text) = T.length text
contentSize (ContentMultipart parts) = sum $ map (contentSize . partContent) parts
contentSize (ContentMsgRFC822 xs) = sum $ map (sum . map (contentSize . partContent) . snd) xs
contentSize (ContentRaw _ contentLength) = contentLength
parseRFC822 :: V.Vector Value -> Parser MessageContent
parseRFC822 lst = ContentMsgRFC822 . V.toList <$> V.mapM p lst
where
p (Object o) = do h <- M.mapKeys CI.mk <$> o .: "headers"
b <- o .: "body"
return (h, b)
p _ = fail "Invalid rfc822 body"
instance FromJSON MessagePart where
parseJSON (Object v) = do
i <- v .: "id"
t <- CI.mk . T.toLower <$> v .: "content-type"
x <- v .:? "content"
f <- v .:? "filename"
cs <- fmap CI.mk <$> v .:? "content-charset"
maybeContentLength <- v .:? "content-length"
let ctype = CI.map (T.takeWhile (/= '/')) t
case (ctype, x, maybeContentLength) of
("multipart", Just (Array _), _) ->
MessagePart i t cs f . ContentMultipart <$> v .: "content"
("message", Just (Array lst), _) | t == "message/rfc822" ->
MessagePart i t cs f <$> parseRFC822 lst
(_, Just (String c), _) ->
return $ MessagePart i t cs f $ ContentText c
(_, Nothing, Just contentLength) ->
return $ MessagePart i t cs f $ ContentRaw "" contentLength
(_, _, _) ->
return $ MessagePart i t cs f $ ContentText ("Unknown content-type: " <> CI.original t)
parseJSON x = fail $ "Error parsing part: " ++ show x
data Message = Message {
messageId :: MessageID
, messageTime :: UTCTime
, messageHeaders :: MessageHeaders
, messageBody :: [MessagePart]
, messageExcluded :: Bool
, messageMatch :: Bool
, messageTags :: [T.Text]
, messageFilename :: FilePath
}
deriving (Show)
instance Eq Message where
a == b = messageId a == messageId b
instance HasNotmuchId Message where
notmuchId = unMessageID . messageId
instance FromJSON Message where
parseJSON (Object v) = Message <$> (MessageID . ("id:"<>) <$> v .: "id")
<*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp")
<*> (M.mapKeys CI.mk <$> v .: "headers")
<*> v .: "body"
<*> v .: "excluded"
<*> v .: "match"
<*> v .: "tags"
<*> v .: "filename"
parseJSON (Array _) = return $ Message (MessageID "") defTime M.empty [] True False [] ""
where defTime = UTCTime (ModifiedJulianDay 0) 0
parseJSON x = fail $ "Error parsing message: " ++ show x
hasTag :: T.Text -> Message -> Bool
hasTag tag = (tag `elem`) . messageTags
newtype Thread = Thread { threadForest :: TR.Forest Message }
instance FromJSON Thread where
parseJSON (Array vs) = Thread <$> mapM parseTree (V.toList vs)
parseJSON _ = fail "Thread is not an array"
parseTree :: Value -> Parser (TR.Tree Message)
parseTree vs@(Array _) = do
(msg, Thread t) <- parseJSON vs
return $ TR.Node msg t
parseTree _ = fail "Tree is not an array"
|
