{-
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