notmuch-web-0.1.0: src/NotmuchCmd.hs
{-
Copyright (C) 2013 John Lenz <lenz@math.uic.edu>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}
module NotmuchCmd (
-- * Search
ThreadID(..)
, SearchResult(..)
, notmuchSearch
-- * Show
, MessageID(..)
, MessagePart(..)
, Message(..)
, messageSubject
, messageFrom
, Thread(..)
, notmuchShow
-- * Export Part
, notmuchMessagePart
-- * Tag
, notmuchTagMessage
, notmuchTagThread
-- * Reply
, Reply(..)
, ReplyTo(..)
, notmuchReply
-- * Utils
, 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
-- | A single entry returned from the notmuch search command.
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
]
-- | The notmuch search command.
notmuchSearch :: MonadIO m => String -> m [SearchResult]
notmuchSearch s = notmuchJson $ ["search", "--format=json", "--format-version=1"] ++ words s
data MessagePart = MessagePart {
partID :: Int
, partContentType :: T.Text
, partContentFilename :: Maybe T.Text
, partContent :: Either T.Text [MessagePart]
} deriving (Show,Eq)
instance FromJSON MessagePart where
parseJSON (Object v) = do
i <- v .: "id"
t <- v .: "content-type"
x <- v .:? "content"
f <- v .:? "filename"
case x of
(Just (Array _)) -> MessagePart i t f . Right <$> v .: "content"
(Just (String c)) -> return $ MessagePart i t f $ Left c
(Just _) -> fail $ "Invalid content: " ++ show x
Nothing -> return $ MessagePart i t f $ Left ""
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 :: M.Map (CI.CI T.Text) T.Text
, 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"
-- | The notmuch show command.
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] -- ^ new tags
-> [String] -- ^ remove tags
-> String -- ^ Search 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] -- ^ new tags
-> [String] -- ^ remove tags
-> MessageID
-> m ()
notmuchTagMessage new remove (MessageID m) = notmuchTag new remove $ "id:" ++ m
notmuchTagThread :: MonadIO m => [String] -- ^ new tags
-> [String] -- ^ remove tags
-> ThreadID
-> m ()
notmuchTagThread new remove (ThreadID t) = notmuchTag new remove $ "thread:" ++ t
-- | Run a raw notmuch command.
notmuchRaw :: MonadIO m => [String] -> m (ExitCode, String, String) -- ^ exitcode, stdout, stderr
notmuchRaw args = liftIO $ readProcessWithExitCode "notmuch" args ""
-- | A helper function to run notmuch and parse the result from json. For this
-- to work, the arguments must include '--format=json'.
notmuchJson :: (MonadIO m, FromJSON a)
=> [String] -- ^ Arguments
-> 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: " ++ e
Success x -> return x