Email.hs

{-# LANGUAGE ScopedTypeVariables #-}

module DPM.Core.Email (

  sendEmail, sendEmailSimple, readDarcsEmail, tagSubject,
  getEditorCommand

) where

import Prelude hiding ( catch )
import Text.PrettyPrint
import Control.Exception
import System.Environment
import System.IO
import System.Exit
import System.Process
import System.Directory
import qualified Data.ByteString as B
import qualified Darcs.Email
import qualified Data.List as List
import Text.Regex.Posix ((=~))

import DPM.Core.DataTypes
import DPM.Core.DPM_Monad
import DPM.Core.Utils ( findCommand, formatTime, darcsDateFormat )

-- FIXME: make this customizable
atTagLookupTable :: [(String, String)]
atTagLookupTable = [("stefan|wehr|sw@umidev\\.de", "@sw")
                   ,("david|leuschner|dl@umidev\\.de", "@dl")
                   ,("dirk|spöri|spoeri|ds@umidev\\.de", "@ds")
                   ,("johannes|weiss|jw@umidev\\.de", "@jw")
                   ,("gero|kriependorf|gk@umidev\\.de", "@gk")
                   ,("harald|fischjer|hf@umidev\\.de", "@hf")]

lookupAtTag :: String -> String
lookupAtTag author =
    case List.find (\(pat, _) -> author =~ pat) atTagLookupTable of
      Just (_, tag) -> tag
      Nothing -> ""

tagSubject :: String -> Maybe String -> String -> String
tagSubject task mauthor s =
    let prefix = case mauthor of
                   Nothing -> ""
                   Just author ->
                       case lookupAtTag author of
                         "" -> ""
                         s -> s ++ " "
    in prefix ++ "[DPM:" ++ task ++ "] " ++ s

sendEmailSimple :: Patch -> String -> DPM ()
sendEmailSimple patch task =
    do user <- getDPMConfigValue cfg_currentUser
       fromAddress <- getDPMConfigValue cfg_fromAddress
       repo <- getDPMConfigValue cfg_repoDir
       liftIO $
              sendEmail fromAddress
                        (p_author patch)
                        []
                        (tagSubject task Nothing
                                    (unPatchGroupID (p_name patch)))
                        (show
                         (text "User" <+> quote user <+> text task <+>
                               text " your patch:"
                          $$ text "" $$
                          text (formatTime darcsDateFormat (p_date patch)) <+>
                          text (p_author patch) $$
                          text "  *" <+> text (unPatchGroupID (p_name patch))
                          $$ text "" $$
                          text "ID:" <+> text (unPatchID (p_id patch))
                          $$ text "" $$
                          text "Repository:" <+> text repo
                          $$ text "" $$
                          text "So long, and thanks for all the patches!\n"))
                        []
    where quote s = text "'" <> text s <> text "'"

-- FIXME: implement properly
sendEmail :: String -> String -> [String]
          -> String -> String -> [FilePath] -> IO ()
sendEmail from to ccs subject body attachements =
    do tmpDir <- getTemporaryDirectory
       (tmpFile, handle) <- openTempFile tmpDir "dpm-email"
       hPutStrLn handle $ "From: " ++ from
       hPutStrLn handle $ "To: " ++ to
       mapM (\cc -> hPutStrLn handle $ "Cc: " ++ cc) ccs
       hPutStrLn handle $ "Subject: " ++ subject
       hPutStrLn handle ""
       hPutStr handle body
       hClose handle
       let args = ["-x", "-H", tmpFile] ++
                  concatMap (\a -> ["-a", a]) attachements
           cmd = "mutt"
       -- rawSystem cmd args
       (ecode, out, err) <- readProcessWithExitCode cmd args ""
       hPutStr stderr err
       hPutStr stdout out
       case ecode of
         ExitSuccess ->
             putStrLn $ "Email sent."
         ExitFailure n ->
             hPutStrLn stderr $ "Sending email failed with exit code " ++ show n

getEditorCommand :: IO FilePath
getEditorCommand =
    do editor <- getEnv "EDITOR" `catch` (\(_::SomeException) -> return "vi")
       either <- findCommand editor
       case either of
         Left _ -> return "/usr/bin/vi"
         Right x -> return x

readDarcsEmail :: B.ByteString -> B.ByteString
readDarcsEmail = Darcs.Email.read_email

-- Local Variables:
-- coding: utf-8
-- End: