diff options
Diffstat (limited to 'Notmuch')
| -rw-r--r-- | Notmuch/Class.hs | 4 | ||||
| -rw-r--r-- | Notmuch/Message.hs | 123 | ||||
| -rw-r--r-- | Notmuch/SearchResult.hs | 61 |
3 files changed, 0 insertions, 188 deletions
diff --git a/Notmuch/Class.hs b/Notmuch/Class.hs deleted file mode 100644 index 2d2b416..0000000 --- a/Notmuch/Class.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Notmuch.Class where - -class HasNotmuchId a where - notmuchId :: a -> String diff --git a/Notmuch/Message.hs b/Notmuch/Message.hs deleted file mode 100644 index d08be39..0000000 --- a/Notmuch/Message.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# 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/Notmuch/SearchResult.hs b/Notmuch/SearchResult.hs deleted file mode 100644 index a59fa9c..0000000 --- a/Notmuch/SearchResult.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# 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 --- ] |