diff options
Diffstat (limited to 'Notmuch')
| -rw-r--r-- | Notmuch/Message.hs | 115 | ||||
| -rw-r--r-- | Notmuch/SearchResult.hs | 51 |
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 +-- ] |