From 8e92e6e11d2b3b0bfb5ac9d68f347219493e6380 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Wed, 23 Sep 2020 17:44:40 +0200 Subject: split into library + executables --- src/Notmuch/Class.hs | 4 ++ src/Notmuch/Message.hs | 123 ++++++++++++++++++++++++++++++++++++++++++++ src/Notmuch/SearchResult.hs | 61 ++++++++++++++++++++++ 3 files changed, 188 insertions(+) create mode 100644 src/Notmuch/Class.hs create mode 100644 src/Notmuch/Message.hs create mode 100644 src/Notmuch/SearchResult.hs (limited to 'src/Notmuch') diff --git a/src/Notmuch/Class.hs b/src/Notmuch/Class.hs new file mode 100644 index 0000000..2d2b416 --- /dev/null +++ b/src/Notmuch/Class.hs @@ -0,0 +1,4 @@ +module Notmuch.Class where + +class HasNotmuchId a where + notmuchId :: a -> String diff --git a/src/Notmuch/Message.hs b/src/Notmuch/Message.hs new file mode 100644 index 0000000..d08be39 --- /dev/null +++ b/src/Notmuch/Message.hs @@ -0,0 +1,123 @@ +{-# 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.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 + + +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 + + +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 + , 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" diff --git a/src/Notmuch/SearchResult.hs b/src/Notmuch/SearchResult.hs new file mode 100644 index 0000000..a59fa9c --- /dev/null +++ b/src/Notmuch/SearchResult.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Notmuch.SearchResult where + +import Data.Aeson +import Data.Text +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Notmuch.Class + + +newtype ThreadID = ThreadID { unThreadID :: 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) + + +instance Eq SearchResult where + s1 == s2 = + searchThread s1 == searchThread s2 + + +instance HasNotmuchId SearchResult where + notmuchId = unThreadID . searchThread + + +instance FromJSON SearchResult where + parseJSON (Object v) = SearchResult <$> (ThreadID . ("thread:"++) <$> 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 +-- ] -- cgit v1.2.3