{- darcs-monitor - Darcs repository monitor
Copyright © 2007 Antti-Juhani Kaijanaho
Copyright © 2007 Benjamin Franksen
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 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 General Public License for more details.
You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-}
module EmailPatch (emailPatch,defaultSendmail) where
import Control.Monad.Trans
import System.Directory
import System.Exit
import System.IO
import System.Process
import Config
import Darcs
import PatchData
import Paths_darcs_monitor
defaultSendmail :: String
defaultSendmail = "/usr/sbin/sendmail"
sendMail :: (MonadConfig m, MonadIO m) =>
String -> String -> m Bool
sendMail recipient text = do
sendmail <- asks confSendmailPath
liftIO $ do (inh, outh, errh, ph) <-
runInteractiveProcess sendmail [recipient] Nothing Nothing
hClose outh
hPutStr inh text
hClose inh
err <- hGetContents errh
hPutStr stderr err
ec <- waitForProcess ph
return (ec == ExitSuccess)
emailPatch :: (MonadConfig m, MonadIO m) =>
String -> PatchData -> m Bool
emailPatch rec pd = do
diff <- invokeDarcs ["diff"
,"--match=hash " ++ patchHash pd
,"--repo=" ++ patchRepo pd
,"-u"]
changes <- invokeDarcs ["changes"
,"--match=hash " ++ patchHash pd
,"--repo=" ++ patchRepo pd
,"-s"]
menc <- asks confCharset
met <- asks confEmailTemplate
maxDiff <- asks confMaxDiff
et <- liftIO $ case met of
Just s -> return s
Nothing -> do let s = patchRepoDir pd ++ "email-template"
ex <- doesFileExist s
if ex
then return s
else getDataFileName "default-template"
tmpl <- liftIO $ readFile et
let f hdr ('%':'%':r) = let r' = dropWhile (/= '\n') r
r'' = case r' of ('\n':r''') -> r'''
_ -> r'
in f hdr r''
f hdr ('%':r) = let (k,('%':r')) = span (/= '%') r
he s = if hdr
then headerEncode menc s
else nhe s
nhe = showString
repl = case k of
"RECIPIENT" -> nhe rec
"DIFF" -> he
$ case maxDiff of
Just md
| length diff > md
-> take md diff ++
"[...incomplete...]"
_ -> diff
"CHANGES" -> he changes
"REPO" -> he (patchRepo pd)
"SHORTREPO" -> he (shortRepo pd)
"AUTHOR" -> he (patchAuthor pd ++ " ") .
showChar '<' .
nhe (patchAuthorEmail pd) .
showChar '>'
"DATE" -> nhe (patchDate pd)
"HASH" -> nhe (patchHash pd)
"TITLE" -> he (patchTitle pd)
"COMMENT" -> he (patchComment pd)
_ -> nhe ('%' : k ++ "%")
in repl . f hdr r'
f True ('\n':'\n':r) = showString "\n\n" . f False r
f hdr (c:r) = showChar c . f hdr r
f _ [] = id
text' = f True tmpl
let text = case menc of
Just enc -> showString "MIME-Version: 1.0\n\
\Content-Transfer-Encoding: 8bit\n\
\Content-Type: text/plain; charset=" .
showString enc .
showChar '\n' .
text'
Nothing -> text'
liftIO $ putStrLn $ "Sending mail to " ++ rec ++ " about " ++ patchTitle pd
sendMail rec (text "")
headerEncode :: Maybe String -> String -> ShowS
headerEncode menc str =
case menc of
Nothing -> showString str
Just enc -> let ws = words str
ws' = map (\s ->
if areSafe s
then s
else "=?" ++
enc ++
"?Q?" ++
qEnc s "" ++
"?="
) ws
in showString (unwords ws')
where qEnc [] = id
qEnc (' ':r) = showChar '_' . qEnc r
qEnc ('_':r) = showString "=5F" . qEnc r
qEnc (c:r)
| c `elem` safe = showChar c . qEnc r
| otherwise = showChar '=' .
showChar c1 .
showChar c2 .
qEnc r
where a = fromEnum c
a1 = a `div` 16
a2 = a `mod` 16
c1 = hds !! a1
c2 = hds !! a2
hds = "0123456789ABCDEF"
safe :: String
safe = "<>@-+.abcdefghijklmnopqrstuvwxyABCDEFGHIJKLMNOPQRSTUVWXY0123456789\
\!\"#$%&\'()*,:;[]\\^_`{}|~/"
areSafe :: String -> Bool
areSafe = all (`elem` safe)
shortRepo :: PatchData -> String
shortRepo he
| last repo == '/' = reverse $ takeWhile (/= '/') $ tail $ reverse repo
| '/' `elem` repo = reverse $ takeWhile (/= '/') $ reverse repo
| otherwise = repo
where repo = patchRepo he