module NotmuchCmd (
ThreadID(..)
, SearchResult(..)
, notmuchSearch
, MessageID(..)
, MessageHeaders
, MessageContent(..)
, MessagePart(..)
, Message(..)
, messageSubject
, messageFrom
, Thread(..)
, notmuchShow
, notmuchMessagePart
, notmuchTagMessage
, notmuchTagThread
, Reply(..)
, ReplyTo(..)
, notmuchReply
, notmuchRaw
, notmuchJson
, notmuchVersion
) 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.Monoid ((<>))
import Data.Time.Calendar (Day(..))
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Typeable (Typeable)
import Data.Version (Version(..), parseVersion)
import Text.Blaze (ToMarkup(..))
import Text.ParserCombinators.ReadP (readP_to_S)
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 :: CI.CI T.Text
, partContentCharset :: Maybe (CI.CI 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 <- 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
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
notmuchVersion :: MonadIO m => m Version
notmuchVersion = do
out <- liftIO $ readProcess "notmuch" ["--version"] ""
let fixTags :: Char -> Char
fixTags '+' = '-'
fixTags '~' = '-'
fixTags c = c
let vStr = map fixTags $ words out !! 1
let vs = filter (\(_,r) -> r == "") $ readP_to_S parseVersion vStr
case vs of
((v,_):_) -> return v
_ -> throw $ NotmuchError $ "Unable to parse version: " ++ vStr