summaryrefslogtreecommitdiffstats
path: root/Notmuch
diff options
context:
space:
mode:
authorKierán Meinhardt <kieran.meinhardt@gmail.com>2020-09-23 17:44:40 +0200
committerKierán Meinhardt <kieran.meinhardt@gmail.com>2020-09-23 17:44:40 +0200
commit8e92e6e11d2b3b0bfb5ac9d68f347219493e6380 (patch)
tree6484ca42d85ca89475e922f7b45039c116ebbf97 /Notmuch
parent6a6ad3aecd53ffd89101a0dee2b4ea576d4964d4 (diff)
split into library + executables
Diffstat (limited to 'Notmuch')
-rw-r--r--Notmuch/Class.hs4
-rw-r--r--Notmuch/Message.hs123
-rw-r--r--Notmuch/SearchResult.hs61
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
--- ]