{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE CPP, TypeOperators #-}

module Darcs.Commands.Send ( send ) where
import System.Exit ( exitWith, ExitCode( ExitSuccess ) )
import System.IO.Error ( ioeGetErrorString )
import System.IO ( hClose )
import Control.Monad ( when, unless, forM_ )
import Storage.Hashed.Tree ( Tree )
import Data.Maybe ( isNothing )

import Darcs.Commands ( DarcsCommand(..), putInfo, putVerbose )
import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile,
                                    Target, Context,
                                    DryRun, Quiet, Unified
                                  ), getOutput,
                         fixUrl, definePatches,
                         getCc, getAuthor, workingRepoDir,
                         editDescription, logfile, rmlogfile,
                         sign, getSubject, depsSel, getInReplyTo,
                         matchSeveral, setDefault, outputAutoName,
                         output, ccSend, subject, target, author, sendmailCmd,
                         inReplyTo, remoteRepo, networkOptions,
                         allInteractive, getSendmailCmd,
                         printDryRunMessageAndExit,
                         summary, allowUnrelatedRepos,
                         fromOpt, dryRun, sendToContext, getOutput,
                         changesReverse,
                       )
import Darcs.Flags ( willRemoveLogFile, doReverse )
import Darcs.Hopefully ( PatchInfoAnd, hopefully, patchDesc )
import Darcs.Repository ( PatchSet, Repository,
                          amInRepository, identifyRepositoryFor, withRepoReadLock, ($-),
                          readRepo, readRecorded, prefsUrl, checkUnrelatedRepos )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import Darcs.Patch ( RepoPatch, description, applyToTree, invert )
import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:>>)(..),
                       mapFL, mapFL_FL, lengthFL, nullFL, unsafeCoerceP )
import Darcs.Patch.Bundle ( makeBundleN, scanContext, patchFilename )
import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist )
import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail )
import ByteStringUtils ( mmapFilePS )
import qualified Data.ByteString.Char8 as BC (unpack)
import Darcs.Lock ( withOpenTemp, writeDocBinFile, readDocBinFile, worldReadableTemp, removeFileMayNotExist )
import Darcs.SelectChanges ( selectChanges, WhichChanges(..), selectionContext, runSelection )
import Darcs.Patch.Depends ( findCommonWithThem )
import Darcs.Utils ( askUser, catchall, editFile, formatPath )
import Progress ( debugMessage )
import Darcs.Email ( makeEmail )
import Printer ( Doc, vsep, vcat, text, ($$), (<+>), (<>), putDoc )
import Darcs.RepoPath ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd,
                        getCurrentDirectory, useAbsoluteOrStd )
import HTTP ( postUrl )
#include "impossible.h"

#include "gadts.h"

sendDescription :: String
sendDescription =
 "Send by email a bundle of one or more patches."

sendHelp :: String
sendHelp =
 "Send is used to prepare a bundle of patches that can be applied to a target\n"++
 "repository.  Send accepts the URL of the repository as an argument.  When\n"++
 "called without an argument, send will use the most recent repository that\n"++
 "was either pushed to, pulled from or sent to.  By default, the patch bundle\n"++
 "is sent by email, although you may save it to a file.\n"

send :: DarcsCommand
send = DarcsCommand {commandName = "send",
                     commandHelp = sendHelp,
                     commandDescription = sendDescription,
                     commandExtraArgs = 1,
                     commandExtraArgHelp = ["[REPOSITORY]"],
                     commandCommand = sendCmd,
                     commandPrereq = amInRepository,
                     commandGetArgPossibilities = getPreflist "repos",
                     commandArgdefaults = defaultrepo,
                     commandAdvancedOptions = [logfile, rmlogfile,
                                                 remoteRepo,
                                                 sendToContext, changesReverse] ++
                                                networkOptions,
                     commandBasicOptions = [matchSeveral, depsSel,
                                              allInteractive,
                                              fromOpt, author,
                                              target,ccSend,subject, inReplyTo,
                                              output,outputAutoName,sign]
                                              ++dryRun++[summary,
                                              editDescription,
                                              setDefault False,
                                              workingRepoDir,
                                              sendmailCmd,
                                              allowUnrelatedRepos]}

sendCmd :: [DarcsFlag] -> [String] -> IO ()
sendCmd input_opts [""] = sendCmd input_opts []
sendCmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $- \repository -> do
  context_ps <- the_context input_opts
  case context_ps of
    Just them -> sendToThem repository input_opts [] "CONTEXT" them
    Nothing -> do
        repodir <- fixUrl input_opts unfixedrepodir
        -- Test to make sure we aren't trying to push to the current repo
        here <- getCurrentDirectory
        when (repodir == toFilePath here) $
           fail ("Can't send to current repository! Did you mean send --context?")
        repo <- identifyRepositoryFor repository repodir
        them <- readRepo repo
        old_default <- getPreflist "defaultrepo"
        setDefaultrepo repodir input_opts
        when (old_default == [repodir] && not (Quiet `elem` input_opts)) $
             putStrLn $ "Creating patch to "++formatPath repodir++"..."
        wtds <- decideOnBehavior input_opts repo
        sendToThem repository input_opts wtds repodir them
    where the_context [] = return Nothing
          the_context (Context foo:_)
              = (Just . scanContext )`fmap` mmapFilePS (toFilePath foo)
          the_context (_:fs) = the_context fs
sendCmd _ _ = impossible

sendToThem :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p C(Origin x) -> IO ()
sendToThem repo opts wtds their_name them = do
  us <- readRepo repo
  common :>> us' <- return $ findCommonWithThem us them
  checkUnrelatedRepos opts us them
  (case us' of
      NilFL -> do putInfo opts $ text "No recorded local changes to send!"
                  exitWith ExitSuccess
      _ -> putVerbose opts $ text "We have the following patches to send:"
                     $$ (vcat $ mapFL description us')) :: IO ()
  pristine <- readRecorded repo
  let context = selectionContext "send" opts Nothing []
      selector = if doReverse opts
                 then selectChanges FirstReversed
                 else selectChanges First
  (to_be_sent :> _) <- runSelection (selector us') context
  printDryRunMessageAndExit "send" opts to_be_sent
  when (nullFL to_be_sent) $ do
      putInfo opts $ text "You don't want to send any patches, and that's fine with me!"
      exitWith ExitSuccess
  definePatches to_be_sent
  bundle <- prepareBundle opts common pristine (us':\/:to_be_sent)
  let make_fname (tb:>:_) = patchFilename $ patchDesc tb
      make_fname _ = impossible
      fname = make_fname to_be_sent
      outname = getOutput opts fname
  case outname of
    Just fname' -> writeBundleToFile opts to_be_sent bundle fname' wtds their_name
    Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name

prepareBundle :: forall p C(x y z). RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin z)
                -> Tree IO -> ((FL (PatchInfoAnd p)) :\/: (FL (PatchInfoAnd p))) C(x y)
                -> IO Doc
prepareBundle opts common pristine (us' :\/: to_be_sent) = do
  pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine
  unsig_bundle <- makeBundleN (Just pristine') (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent)
  signString opts unsig_bundle

sendBundle :: forall p C(x y) . (RepoPatch p) => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y)
             -> Doc -> String -> [WhatToDo] -> String -> IO ()
sendBundle opts to_be_sent bundle fname wtds their_name=
         let
           auto_subject :: forall pp C(x y) . FL (PatchInfoAnd pp) C(x y) -> String
           auto_subject (p:>:NilFL)  = "darcs patch: " ++ trim (patchDesc p) 57
           auto_subject (p:>:ps) = "darcs patch: " ++ trim (patchDesc p) 43 ++
                            " (and " ++ show (lengthFL ps) ++ " more)"
           auto_subject _ = error "Tried to get a name from empty patch list."
           trim st n = if length st <= n then st
                       else take (n-3) st ++ "..."
           in do
           thetargets <- getTargets wtds
           from <- getAuthor opts
           let thesubject = case getSubject opts of
                            Nothing -> auto_subject to_be_sent
                            Just subj -> subj
           (mailcontents, mailfile) <- getDescription opts their_name to_be_sent
           let body = makeEmail their_name
                        (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts)
                        (Just mailcontents)
                        bundle
                        (Just fname)
               contentAndBundle = Just (mailcontents, bundle)

               sendmail = do
                 sm_cmd <- getSendmailCmd opts
                 (sendEmailDoc from (lt [t | SendMail t <- thetargets]) (thesubject) (getCc opts)
                               sm_cmd contentAndBundle body >>
                  (putInfo opts . text $ ("Successfully sent patch bundle to: "
                            ++ lt [ t | SendMail t <- thetargets ]
                            ++ ccs (getCc opts) ++".")))
                 `catch` \e -> let msg = "Email body left in " in
                               do case mailfile of
                                    Just mf -> putStrLn $ msg++mf++"."
                                    Nothing -> return ()
                                  fail $ ioeGetErrorString e
               ccs [] = []
               ccs cs  = " and cc'ed " ++ cs

           when (null [ p | Post p <- thetargets]) sendmail
           nbody <- withOpenTemp $ \ (fh,fn) -> do
               generateEmail fh from (lt [t | SendMail t <- thetargets]) thesubject (getCc opts) body
               hClose fh
               mmapFilePS fn
           forM_ [ p | Post p <- thetargets]
             (\url -> do
                putInfo opts . text $ "Posting patch to " ++ url
                postUrl url (BC.unpack nbody) "message/rfc822")
             `catch` const sendmail
           cleanup opts mailfile


lt :: [String] -> String
lt [t] = t
lt [t,""] = t
lt (t:ts) = t++" , "++lt ts
lt [] = ""

cleanup :: (FilePathLike t) => [DarcsFlag] -> Maybe t -> IO ()
cleanup opts (Just mailfile) = when (isNothing (getFileopt opts) || (willRemoveLogFile opts)) $
                                      removeFileMayNotExist mailfile
cleanup _ Nothing = return ()

writeBundleToFile :: forall p C(x y) . (RepoPatch p) => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> Doc ->
                    AbsolutePathOrStd -> [WhatToDo] -> String -> IO ()
writeBundleToFile opts to_be_sent bundle fname wtds their_name =
    do (d,f) <- getDescription opts their_name to_be_sent
       let putabs a = do writeDocBinFile a (d $$ bundle)
                         putStrLn $ "Wrote patch to " ++ toFilePath a ++ "."
           putstd = putDoc (d $$ bundle)
       useAbsoluteOrStd putabs putstd fname
       let mails = lt [ t | SendMail t <- wtds ]
       unless (null mails) $ putInfo opts $ text $ "The usual recipent for this bundle is: " ++ mails
       cleanup opts f

data WhatToDo
    = Post String        -- ^ POST the patch via HTTP
    | SendMail String    -- ^ send patch via email


decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO [WhatToDo]
decideOnBehavior opts the_remote_repo =
    case the_targets of
    [] -> do wtds <- check_post
             unless (null wtds) $ announce_recipients wtds
             return wtds
    ts -> do announce_recipients ts
             return ts
    where the_targets = collectTargets opts
#ifdef HAVE_HTTP
          -- the ifdef above is to so that darcs only checks the remote
          -- _darcs/post if we have an implementation of postUrl.  See
          -- our HTTP module for more details
          check_post = do p <- ((readPost . BC.unpack) `fmap`
                                fetchFilePS (prefsUrl the_remote_repo++"/post")
                                (MaxAge 600)) `catchall` return []
                          emails <- who_to_email
                          return (p++emails)
          readPost p = map pp (lines p) where
            pp ('m':'a':'i':'l':'t':'o':':':s) = SendMail s
            pp s = Post s
#else
          check_post = who_to_email
#endif
          who_to_email =
              do email <- (BC.unpack `fmap`
                           fetchFilePS (prefsUrl the_remote_repo++"/email")
                                       (MaxAge 600))
                          `catchall` return ""
                 if '@' `elem` email then return . map SendMail $ lines email
                                     else return []
          announce_recipients emails =
            let pn (SendMail s) = s
                pn (Post p) = p
            in if DryRun `elem` opts
            then putInfo opts . text $ "Patch bundle would be sent to: "++unwords (map pn emails)
            else when (null the_targets) $
                 putInfo opts . text $ "Patch bundle will be sent to: "++unwords (map pn emails)

getTargets :: [WhatToDo] -> IO [WhatToDo]
getTargets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? "
getTargets wtds = return wtds

collectTargets :: [DarcsFlag] -> [WhatToDo]
collectTargets flags = [ f t | Target t <- flags ] where
    f url@('h':'t':'t':'p':':':_) = Post url
    f em = SendMail em