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
|
{-# LANGUAGE OverloadedStrings #-}
module Notmuch.Message where
import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.CaseInsensitive qualified as CI
import Data.Map qualified as M
import Data.Text qualified as T
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Tree qualified as TR
import Data.Vector qualified as V
import Notmuch.Class
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"
|
