summaryrefslogtreecommitdiffstats
path: root/Notmuch
diff options
context:
space:
mode:
Diffstat (limited to 'Notmuch')
-rw-r--r--Notmuch/Message.hs115
-rw-r--r--Notmuch/SearchResult.hs51
2 files changed, 166 insertions, 0 deletions
diff --git a/Notmuch/Message.hs b/Notmuch/Message.hs
new file mode 100644
index 0000000..3889e7c
--- /dev/null
+++ b/Notmuch/Message.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Notmuch.Message where
+
+import Control.Applicative
+import Data.Aeson
+import Data.Aeson.Types (Parser)
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+import Data.Monoid
+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
+ | 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
+
+
+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"
+ let ctype = CI.map (T.takeWhile (/= '/')) t
+ case (ctype, x) 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
+ (_, Just _) -> return $ MessagePart i t cs f $ ContentText $ "Unknown content-type: " <> CI.original t
+ (_, Nothing) -> return $ MessagePart i t cs f $ ContentText ""
+
+ parseJSON x = fail $ "Error parsing part: " ++ show x
+
+
+data Message = Message {
+ messageId :: MessageID
+ , messageDateRel :: T.Text
+ , 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 FromJSON Message where
+ parseJSON (Object v) = Message <$> v .: "id"
+ <*> v .: "date_relative"
+ <*> (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) (fromInteger 0)
+ parseJSON x = fail $ "Error parsing message: " ++ show x
+
+
+
+
+data 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"
+
diff --git a/Notmuch/SearchResult.hs b/Notmuch/SearchResult.hs
new file mode 100644
index 0000000..164c5b3
--- /dev/null
+++ b/Notmuch/SearchResult.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Notmuch.SearchResult where
+
+import Control.Applicative
+import Data.Aeson
+import Data.Text
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+
+
+newtype ThreadID = ThreadID String
+ deriving (Show,Read,Eq,FromJSON,ToJSON)
+
+
+-- | A single entry returned from the notmuch search command.
+data SearchResult = SearchResult {
+ searchThread :: ThreadID
+ , searchTime :: UTCTime
+ , searchDateRel :: Text
+ , searchSubject :: Text
+ , searchAuthors :: Text
+ , searchQuery :: [Maybe Text] -- TODO (Text, Maybe Text)
+ , searchTags :: [Text]
+ , searchMatched :: Int
+ , searchTotal :: Int
+ }
+ deriving (Show,Eq)
+
+instance FromJSON SearchResult where
+ parseJSON (Object v) = SearchResult <$> v .: "thread"
+ <*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp")
+ <*> v .: "date_relative"
+ <*> v .:? "subject" .!= ""
+ <*> v .:? "authors" .!= ""
+ <*> v .:? "query" .!= []
+ <*> v .: "tags"
+ <*> v .: "matched"
+ <*> v .: "total"
+ parseJSON x = fail $ "Error parsing search: " ++ show x
+
+--instance ToJSON SearchResult where
+-- toJSON s = object [ "thread" .= searchThread s
+-- , "time" .= searchTime s
+-- , "date_relative" .= searchDateRel s
+-- , "subject" .= searchSubject s
+-- , "authors" .= searchAuthors s
+-- , "tags" .= searchTags s
+-- , "matched" .= searchMatched s
+-- , "total" .= searchTotal s
+-- ]