module NotmuchCmd (
ThreadID(..)
, SearchResult(..)
, notmuchSearch
, MessageID(..)
, MessageHeaders
, MessageContent(..)
, MessagePart(..)
, Message(..)
, messageSubject
, messageFrom
, Thread(..)
, notmuchShow
, notmuchMessagePart
, notmuchTagMessage
, notmuchTagThread
, Reply(..)
, ReplyTo(..)
, notmuchReply
, notmuchRaw
, notmuchJson
) where
import Prelude
import Control.Exception (Exception, throw)
import Control.Applicative
import Control.Monad.IO.Class (MonadIO(..))
import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.ByteString (ByteString)
import Data.Conduit
import Data.Conduit.Attoparsec (sinkParser)
import Data.Conduit.Process
import Data.Time.Calendar (Day(..))
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Typeable (Typeable)
import Text.Blaze (ToMarkup(..))
import System.Process
import System.Exit
import Yesod (PathPiece)
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.Tree as TR
import qualified Data.CaseInsensitive as CI
newtype NotmuchError = NotmuchError String
deriving (Show,Typeable)
instance Exception NotmuchError
newtype ThreadID = ThreadID String
deriving (Show,Read,Eq,PathPiece,FromJSON,ToJSON)
instance ToMarkup ThreadID where
toMarkup (ThreadID s) = toMarkup s
preEscapedToMarkup (ThreadID s) = toMarkup s
data SearchResult = SearchResult {
searchThread :: ThreadID
, searchTime :: UTCTime
, searchDateRel :: T.Text
, searchSubject :: T.Text
, searchAuthors :: T.Text
, searchTags :: [T.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 .: "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
]
notmuchSearch :: MonadIO m => String -> m [SearchResult]
notmuchSearch s = notmuchJson $ ["search", "--format=json", "--format-version=1"] ++ words s
type MessageHeaders = M.Map (CI.CI T.Text) T.Text
data MessageContent = ContentText T.Text
| ContentMultipart [MessagePart]
| ContentMsgRFC822 [(MessageHeaders, [MessagePart])]
deriving (Show, Eq)
data MessagePart = MessagePart {
partID :: Int
, partContentType :: T.Text
, partContentCharset :: Maybe T.Text
, partContentFilename :: Maybe T.Text
, partContent :: MessageContent
} deriving (Show,Eq)
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 <- v .: "content-type"
x <- v .:? "content"
f <- v .:? "filename"
cs <- v .:? "content-charset"
let ctype = 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: " `T.append` t
(_, Nothing) -> return $ MessagePart i t cs f $ ContentText ""
parseJSON x = fail $ "Error parsing part: " ++ show x
newtype MessageID = MessageID { unMessageID :: String }
deriving (Show,Read,Eq,PathPiece,FromJSON)
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,Eq)
messageSubject :: Message -> T.Text
messageSubject (Message {messageHeaders = h}) =
maybe "" id $ M.lookup "subject" h
messageFrom :: Message -> T.Text
messageFrom (Message {messageHeaders = h}) =
maybe "" id $ M.lookup "from" h
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 }
deriving (Show)
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"
notmuchShow :: MonadIO m => ThreadID -> m Thread
notmuchShow (ThreadID t) = do
ts <- notmuchJson ["show", "--format=json", "--format-version=1", "thread:" ++ t]
return $ Thread $ concat $ map threadForest ts
notmuchMessagePart :: MonadIO m => MessageID -> Int -> (m MessagePart, Source (ResourceT IO) ByteString)
notmuchMessagePart (MessageID m) num = (msg, sourceProcess process)
where
msg = notmuchJson ["show", "--format=json", "--format-version=1", "--part=" ++ show num, "id:" ++ m]
process = proc "notmuch" ["show", "--format=raw", "--part=" ++ show num, "id:" ++ m]
data Reply = Reply {
replyHeaders :: M.Map (CI.CI T.Text) T.Text
, replyOriginal :: Message
} deriving (Show,Eq)
instance FromJSON Reply where
parseJSON (Object v) = Reply <$> (M.mapKeys CI.mk <$> v .: "reply-headers")
<*> v .: "original"
parseJSON x = fail $ "Error parsing reply: " ++ show x
data ReplyTo = ReplyAll | ReplySender
deriving (Eq, Show)
notmuchReply :: MonadIO m => MessageID -> ReplyTo -> m Reply
notmuchReply (MessageID m) r = notmuchJson $ ["reply", "--format=json", "--format-version=1"] ++ rto ++ i
where
rto = case r of
ReplyAll -> ["--reply-to=all"]
ReplySender -> ["--reply-to=sender"]
i = ["id:" ++ m]
notmuchTag :: MonadIO m => [String]
-> [String]
-> String
-> m ()
notmuchTag new remove search = do
let args = "tag" : map ('+':) new ++ map ('-':) remove ++ words search
(exit,_,err) <- notmuchRaw args
if exit == ExitSuccess
then return ()
else throw $ NotmuchError err
notmuchTagMessage :: MonadIO m => [String]
-> [String]
-> MessageID
-> m ()
notmuchTagMessage new remove (MessageID m) = notmuchTag new remove $ "id:" ++ m
notmuchTagThread :: MonadIO m => [String]
-> [String]
-> ThreadID
-> m ()
notmuchTagThread new remove (ThreadID t) = notmuchTag new remove $ "thread:" ++ t
notmuchRaw :: MonadIO m => [String] -> m (ExitCode, String, String)
notmuchRaw args = liftIO $ readProcessWithExitCode "notmuch" args ""
notmuchJson :: (MonadIO m, FromJSON a)
=> [String]
-> m a
notmuchJson args = liftIO $ do
let process = proc "notmuch" args
v <- runResourceT $ sourceProcess process $$ sinkParser json
case fromJSON v of
Error e -> throw $ NotmuchError $ "Error parsing for " ++ show args ++ " : " ++ e
Success x -> return x