-- submit moderated comments (received by email) to the blog
-- pesco 2009
--
-- usage: submitcomments domain
--
-- the program expects an email on stdin.
-- the email is inspected and can be found to be either:
-- a) from a moderator for pass-through:
--    top-level is multipart/signed
--    embedded is at least one message/rfc822 satisfying:
--      1. addressed to an address of the form 'comment-...@domain'
--      2. the address points to an existing blog post
--      2. not a duplicate (i.e. not already in the corresponding mbox)
--    top-level signature is valid within moderator keyring
--    => deliver all embedded comments, ignore anything else in the mail
--       the program exits with success
--       this concludes processing of the email
-- b) anything else, i.e.
--    top-level not multipart/signed, or
--      (could be a mistake on part of the moderator, but we don't care)
--    no comment messages embedded, or
--      (this catches author-signed comments before the costly sig-check)
--    all embedded comments have already been submitted, or
--      (this catches replays before the costly sig-check)
--    top-level signature not from a moderator, or
--    top-level signature forged
--    => exit with failure (exit status 1)
--       the caller should forward the email to moderators for inspection

import Email
import Control.Monad (liftM, mapM_, filterM, when)
import System (getArgs)
import System.Exit (exitWith, ExitCode(..))
import System.IO
import System.Directory (doesFileExist, removeFile)
import System.Cmd (system)
import System.Time
import Data.Char (isSpace)
import Data.List (isPrefixOf, intersperse)


main = do
    [domain] <- getArgs

    eml <- liftM email getContents

    -- this means (to the caller): forward entire input message to moderators
    let fwd s = do  hPutStr stderr (s++":\n" ++ indent (mailsummary eml))
                    exitWith (ExitFailure 1)

    -- this means (to the caller): i've handled it, forget about the message
    let ign s = do  hPutStrLn stderr (s ++ ", ignoring\n" ++ indent (mailsummary eml))
                    exitWith ExitSuccess

    when (not (istype "multipart" "signed" eml)) $
        fwd "not multipart/signed"
    let Just (msg, sig) = findsigned eml

    let comments = find_comments domain (email msg)
    when (null comments) $
        ign "email contains no comments"

    system "darcs pull -a"

    valid_comments <- filterM (valid domain) comments
    when (null valid_comments) $
        fwd "contains only invalid comments"

    new_comments <- filterM (nondup domain) valid_comments
    when (null new_comments) $ do
        ign "email contains only duplicates"

    valid <- verify_pgp_signature msg sig
    when (not valid) $
        fwd "invalid signature"

    mapM_ (deliver domain) new_comments
    system "darcs push -a"

indent = unlines . map ("  "++) . lines

mailsummary :: Email -> String
mailsummary eml = h "Subject" ++ h "To" ++ h "Cc" ++ indent (mimetree eml)
    where
    h s =  maybe "" (\x -> s++":"++x++"\n") (lookup s (fst eml))

mimetree :: Email -> String
mimetree eml = case lookup "Content-Type" (fst eml) of
    Just mt -> unwords (lines mt) ++ "\n" ++ indent (concatMap mimetree (snd (subparts eml)))
    Nothing -> "<no content-type>\n"


-- find message/rfc822 parts that are addressed to a comment email address
find_comments :: String -> Email -> [Email]
find_comments domain = filter (is_to_comment domain) . embedded_msgs
    where
    embedded_msgs = map (email . snd) . findparts "message" "rfc822"

-- check whether To: or Cc: header points to a comment address at domain
is_to_comment :: String -> Email -> Bool
is_to_comment domain = any (is_comment_address domain) . addressees

is_comment_address domain (Emailaddress _ u _ d) = u == "comment" && d == domain

-- check if comment refers to any existing post and
valid :: String -> Email -> IO Bool
valid domain eml = post_paths domain eml >>= (return . not . null)

-- check if comment doesn't yet appear in at least one corresponding mbox file
nondup :: String -> Email -> IO Bool
nondup domain eml = delivery_paths domain eml >>= (return . not . null)

delivery_paths domain eml = post_paths domain eml >>= filterM (is_nondup eml)

post_paths domain eml = do
    let cmt_addrs = filter (is_comment_address domain) (addressees eml)
        cmt_args  = [a | Emailaddress _ _ a _ <- cmt_addrs]
        cmt_paths = filter is_valid_path (map arg_to_path cmt_args)

    filterM post_exists cmt_paths

    where
    arg_to_path = map (\c -> if c=='.' then '/' else c)
    is_valid_path p = not (any isSpace p) && head p /= '/'
    post_exists p = doesFileExist (p ++ ".txt")

is_nondup eml p = do
    let pm = p ++ ".mbox"
    ex <- doesFileExist pm
    if ex then do
            h <- openFile pm ReadMode
            c <- hGetContents h
            let result = not (eml `elem` mbox c)
            result `seq` hClose h
            return result
        else do
            return True


-- verify the given message/signature via a call to gpg
verify_pgp_signature :: String -> String -> IO Bool
verify_pgp_signature msg sig = do
    (msgpath, h) <- openTempFile "/tmp" "gpgverify.txt"
    hPutStr h msg
    hClose h
    (sigpath, h) <- openTempFile "/tmp" "gpgverify.sig"
    hPutStr h sig
    hClose h
    ec <- system (gpg ++ " --verify " ++ sigpath ++ " " ++ msgpath)
    removeFile msgpath
    removeFile sigpath
    return (ec == ExitSuccess)

gpg = "gpg --no-default-keyring\
         \ --keyring ./moderators.gpg\
         \ --trust-model always\
         \ --quiet"

-- append a given comment to the appropriate mbox file(s)
deliver :: String -> Email -> IO ()
deliver domain eml = do
    ps <- delivery_paths domain eml
    mapM_ deliver1 ps
    where
    deliver1 p' = do
        let p = p' ++ ".mbox"
        t <- getClockTime
        ex <- doesFileExist p
        h <- openFile p AppendMode
        hPutStr h (fromline t)
        hPutStr h (escape (show_email eml))
        hPutChar h '\n'
        hClose h
        when (not ex) $
            system ("darcs add " ++ p) >> return ()
        system ("darcs record -a -A '" ++ author ++ "' -m 'comment on " ++ p' ++ "' " ++ p)
    fromline t = "From " ++ fromaddr ++ " " ++ show t ++ "\n"
    fromhdr = lookup "From" (fst eml)
    fromaddr = maybe "" (showaddr.emailaddress) fromhdr
    author = maybe "anonymous" id fromhdr
    escape = unlines . map escapeline . lines
    escapeline l
        | "From " `isPrefixOf` l' = '>':l
        | otherwise               = l
        where
        l' = takeWhile (=='>') l
    showaddr (Emailaddress _ u a d) = u ++ a' ++ d'
        where
        a' = if null a then "" else ("+" ++ a)
        d' = if null d then "" else ("@" ++ d)

show_email :: Email -> String
show_email (headers, body) = concatMap show_hdr headers ++ "\n" ++ body
    where
    show_hdr (k,v) = k ++ ":" ++ v ++ "\n"