--  Copyright (C) 2002-2004 David Roundy
--
--  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, 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; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

{-# LANGUAGE CPP, TypeOperators, OverloadedStrings #-}

module Darcs.UI.Commands.Send ( send ) where

import Prelude ()
import Darcs.Prelude

import Prelude hiding ( (^) )

import System.Exit
    ( exitSuccess
#ifndef HAVE_MAPI
    , ExitCode ( ExitFailure )
    , exitWith
#endif
    )
import System.IO.Error ( ioeGetErrorString )
import System.IO ( hClose )
import Control.Exception ( catch, IOException )
import Control.Monad ( when, unless, forM_ )
import Darcs.Util.Tree ( Tree )
import Data.List ( intercalate, isPrefixOf )
import Data.List ( stripPrefix )
import Data.Maybe ( isNothing, fromMaybe )

import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts
    , putInfo
    , putVerbose
    , printDryRunMessageAndExit
    , setEnvDarcsPatches
    , defaultRepo
    , amInHashedRepository
    )
import Darcs.UI.Flags
    ( DarcsFlag( Target
               , Context
               , Mail
               , DryRun
               , Quiet
               , AllowUnrelatedRepos
               )
    , willRemoveLogFile, doReverse, dryRun, useCache, remoteRepos, setDefault
    , fixUrl
    , getCc
    , getAuthor
    , getSubject
    , getInReplyTo
    , getSendmailCmd
    , getOutput
    , getCharset
    , verbosity
    , hasSummary
    , isInteractive
    , hasAuthor
    , hasLogfile
    , selectDeps
    , minimize
    , editDescription
    )
import Darcs.UI.Options
    ( DarcsOption, (^), odesc, ocheck, onormalise
    , defaultFlags, parseFlags
    )
import qualified Darcs.UI.Options.All as O

import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc )
import Darcs.Repository ( PatchSet, Repository,
                          identifyRepositoryFor, withRepository, RepoJob(..),
                          readRepo, readRecorded, prefsUrl, checkUnrelatedRepos )
import Darcs.Patch.Set ( Origin )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch ( IsRepoType, RepoPatch, description, applyToTree, invert )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), (:>)(..), (:\/:)(..),
    mapFL, mapFL_FL, lengthFL, nullFL )
import Darcs.Patch.Bundle ( minContext, makeBundleN, scanContextFile, patchFilename )
import Darcs.Repository.Prefs ( addRepoSource, getPreflist )
import Darcs.Util.External ( fetchFilePS, Cachable(..) )
import Darcs.UI.External
    ( signString
    , sendEmailDoc
    , generateEmail
    , editFile
    , catchall
    , getSystemEncoding
    , isUTF8Locale
#ifndef HAVE_MAPI
    , haveSendmail
#endif
    )
import Darcs.Util.ByteString ( mmapFilePS, isAscii )
import qualified Data.ByteString.Char8 as BC (unpack)
import Darcs.Util.Lock
    ( withOpenTemp
    , writeDocBinFile
    , readDocBinFile
    , removeFileMayNotExist
    )
import Darcs.UI.SelectChanges
    ( WhichChanges(..)
    , selectionContext
    , runSelection
    )
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )
import Darcs.Patch.Depends ( findCommonWithThem )
import Darcs.Util.Prompt ( askUser, promptYorn )
import Data.Text.Encoding       ( decodeUtf8' )
import Darcs.Util.Progress ( debugMessage )
import Darcs.UI.Email ( makeEmail )
import Darcs.Util.Printer
    ( Doc, vsep, text, ($$), (<+>), (<>), putDoc, putDocLn
    , renderPS, RenderMode(..)
    )
import Darcs.Util.English ( englishNum, Noun(..) )
import Darcs.Util.Path ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd,
                        getCurrentDirectory, useAbsoluteOrStd, makeAbsoluteOrStd )
import Darcs.Util.Download.HTTP ( postUrl )
import Darcs.Util.Workaround ( renameFile )
import Darcs.Util.Global ( darcsSendMessage, darcsSendMessageFinal )
import Darcs.Util.SignalHandler ( catchInterrupt )

import qualified Darcs.UI.Message.Send as Msg
#include "impossible.h"

sendBasicOpts :: DarcsOption a
                 ([O.MatchFlag]
                  -> O.SelectDeps
                  -> Maybe Bool
                  -> O.HeaderFields
                  -> Maybe String
                  -> Maybe String
                  -> (Bool, Maybe String)
                  -> Maybe O.Output
                  -> O.Sign
                  -> O.DryRun
                  -> O.XmlOutput
                  -> Maybe O.Summary
                  -> Bool
                  -> Maybe Bool
                  -> Maybe String
                  -> Bool
                  -> Bool
                  -> a)
sendBasicOpts
    = O.matchSeveral
    ^ O.selectDeps
    ^ O.interactive -- True
    ^ O.headerFields
    ^ O.author
    ^ O.charset
    ^ O.sendmail
    ^ O.output
    ^ O.sign
    ^ O.dryRunXml
    ^ O.summary
    ^ O.editDescription
    ^ O.setDefault
    ^ O.workingRepoDir
    ^ O.minimize
    ^ O.allowUnrelatedRepos

sendAdvancedOpts :: DarcsOption a
                    (O.Logfile
                     -> O.RemoteRepos
                     -> Maybe AbsolutePath
                     -> Bool
                     -> O.NetworkOptions
                     -> a)
sendAdvancedOpts
    = O.logfile
    ^ O.remoteRepos
    ^ O.sendToContext 
    ^ O.changesReverse
    ^ O.network

sendOpts :: DarcsOption a
            ([O.MatchFlag]
             -> O.SelectDeps
             -> Maybe Bool
             -> O.HeaderFields
             -> Maybe String
             -> Maybe String
             -> (Bool, Maybe String)
             -> Maybe O.Output
             -> O.Sign
             -> O.DryRun
             -> O.XmlOutput
             -> Maybe O.Summary
             -> Bool
             -> Maybe Bool
             -> Maybe String
             -> Bool
             -> Bool
             -> Maybe O.StdCmdAction
             -> Bool
             -> Bool
             -> O.Verbosity
             -> Bool
             -> O.Logfile
             -> O.RemoteRepos
             -> Maybe AbsolutePath
             -> Bool
             -> O.NetworkOptions
             -> O.UseCache
             -> Maybe String
             -> Bool
             -> Maybe String
             -> Bool
             -> a)
sendOpts = sendBasicOpts `withStdOpts` sendAdvancedOpts

patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
patchSelOpts flags = S.PatchSelectionOptions
    { S.verbosity = verbosity flags
    , S.matchFlags = parseFlags O.matchSeveral flags
    , S.interactive = isInteractive True flags
    , S.selectDeps = selectDeps flags
    , S.summary = hasSummary O.NoSummary flags
    , S.withContext = O.NoContext
    }

send :: DarcsCommand [DarcsFlag]
send = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "send"
    , commandHelp = Msg.cmdHelp
    , commandDescription = Msg.cmdDescription
    , commandExtraArgs = 1
    , commandExtraArgHelp = ["[REPOSITORY]"]
    , commandCommand = sendCmd
    , commandPrereq = amInHashedRepository
    , commandGetArgPossibilities = getPreflist "repos"
    , commandArgdefaults = defaultRepo
    , commandAdvancedOptions = odesc sendAdvancedOpts
    , commandBasicOptions = odesc sendBasicOpts
    , commandDefaults = defaultFlags sendOpts
    , commandCheckOptions = ocheck sendOpts
    , commandParseOptions = onormalise sendOpts
    }

sendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
sendCmd fps input_opts [""] = sendCmd fps input_opts []
sendCmd (_,o) input_opts [unfixedrepodir] =
 withRepository (useCache input_opts) $ RepoJob $
  \(repository :: Repository rt p wR wU wR) -> do
  context_ps <- the_context input_opts
  case context_ps of
    Just them -> do
        wtds <- decideOnBehavior input_opts (Nothing :: Maybe (Repository rt p wR wU wR))
        sendToThem repository input_opts wtds "CONTEXT" them
    Nothing -> do
        repodir <- fixUrl o unfixedrepodir
        -- Test to make sure we aren't trying to push to the current repo
        here <- getCurrentDirectory
        when (repodir == toFilePath here) $
           fail Msg.cannotSendToSelf
        old_default <- getPreflist "defaultrepo"
        when (old_default == [repodir] && Quiet `notElem` input_opts) $
             putDocLn (Msg.creatingPatch repodir)
        repo <- identifyRepositoryFor repository (useCache input_opts) repodir
        them <- readRepo repo
        addRepoSource repodir (dryRun input_opts) (remoteRepos input_opts) (setDefault False input_opts)
        wtds <- decideOnBehavior input_opts (Just repo)
        sendToThem repository input_opts wtds repodir them
    where the_context [] = return Nothing
          the_context (Context foo:_)
              = Just `fmap` scanContextFile (toFilePath foo)
          the_context (_:fs) = the_context fs
sendCmd _ _ _ = impossible

sendToThem :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
           => Repository rt p wR wU wT -> [DarcsFlag] -> [WhatToDo] -> String
           -> PatchSet rt p Origin wX -> IO ()
sendToThem repo opts wtds their_name them = do
#ifndef HAVE_MAPI
  -- Check if the user has sendmail or provided a --sendmail-cmd
  -- (unless -o/-O or --dry-run is used)
  sendmail <- haveSendmail
  sm_cmd <- getSendmailCmd opts
  when (isNothing (getOutput opts "") && DryRun `notElem` opts &&
        not sendmail && sm_cmd == "") $ do
      putInfo opts Msg.noWorkingSendmail
      exitWith $ ExitFailure 1
#endif
  us <- readRepo repo
  common :> us' <- return $ findCommonWithThem us them
  checkUnrelatedRepos (AllowUnrelatedRepos `elem` opts) us them
  case us' of
      NilFL -> do putInfo opts Msg.nothingSendable
                  exitSuccess
      _     -> putVerbose opts $ Msg.selectionIs (mapFL description us')
  pristine <- readRecorded repo
  let direction = if doReverse opts then FirstReversed else First
      context = selectionContext direction "send" (patchSelOpts opts) Nothing Nothing
  (to_be_sent :> _) <- runSelection us' context
  printDryRunMessageAndExit "send"
      (verbosity opts)
      (hasSummary O.NoSummary opts)
      (dryRun opts)
      O.NoXml
      (isInteractive True opts)
      to_be_sent
  when (nullFL to_be_sent) $ do
      putInfo opts Msg.selectionIsNull
      exitSuccess
  setEnvDarcsPatches to_be_sent

  let genFullBundle = prepareBundle opts common  (Right (pristine, us':\/:to_be_sent))
  bundle <- if not (minimize opts)
             then genFullBundle
             else do putInfo opts "Minimizing context, to send with full context hit ctrl-C..."
                     ( case minContext common to_be_sent of
                         Sealed (common' :> to_be_sent') -> prepareBundle opts common' (Left to_be_sent') )
                     `catchInterrupt` genFullBundle
  here   <- getCurrentDirectory
  let make_fname (tb:>:_) = patchFilename $ patchDesc tb
      make_fname _ = impossible
      fname = make_fname to_be_sent
      outname = case getOutput opts fname of
                    Just f  -> Just f
                    Nothing | Mail `elem` opts -> Nothing
                            | not $ null [ p | Post p <- wtds] -> Nothing
                            | otherwise        -> Just (makeAbsoluteOrStd here 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 rt p wX wY wZ. (RepoPatch p, ApplyState p ~ Tree)
              => [DarcsFlag] -> PatchSet rt p Origin wZ
              -> Either (FL (PatchInfoAnd rt p) wX wY)
                        (Tree IO, (FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wX wY)
              -> IO Doc
prepareBundle opts common e = do
  unsig_bundle <-
     case e of
       (Right (pristine, us' :\/: to_be_sent)) -> do
         pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine
         makeBundleN (Just pristine')
                     (unsafeCoerceP common)
                     (mapFL_FL hopefully to_be_sent)
       Left to_be_sent -> makeBundleN Nothing
                                      (unsafeCoerceP common)
                                      (mapFL_FL hopefully to_be_sent)
  signString (parseFlags O.sign opts) unsig_bundle

sendBundle :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree)
           => [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY
             -> Doc -> String -> [WhatToDo] -> String -> IO ()
sendBundle opts to_be_sent bundle fname wtds their_name=
         let
           auto_subject :: forall pp wA wB . FL (PatchInfoAnd rt pp) wA wB -> 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 (hasAuthor opts) False
           let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts
           (mailcontents, mailfile, mailcharset) <- getDescription opts their_name to_be_sent

           let warnMailBody = case mailfile of
                                  Just mf -> putDocLn $ Msg.emailBackedUp mf
                                  Nothing -> return ()

               warnCharset msg = do
                 confirmed <- promptYorn $ Msg.promptCharSetWarning msg
                 unless confirmed $ do
                    putDocLn Msg.charsetAborted
                    warnMailBody
                    exitSuccess

           thecharset <- case getCharset opts of
                              -- Always trust provided charset
                              providedCset@(Just _) -> return providedCset
                              Nothing ->
                                case mailcharset of
                                Nothing -> do
                                  warnCharset Msg.charsetCouldNotGuess
                                  return mailcharset
                                Just "utf-8" -> do
                                  -- Check the locale encoding for consistency
                                  encoding <- getSystemEncoding
                                  debugMessage $ Msg.currentEncodingIs encoding
                                  unless (isUTF8Locale encoding) $
                                    warnCharset Msg.charsetUtf8MailDiffLocale
                                  return mailcharset
                                -- Trust other cases (us-ascii)
                                Just _ -> return mailcharset

           let body = makeEmail their_name
                        (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts)
                        (Just mailcontents)
                        thecharset
                        bundle
                        (Just fname)
               contentAndBundle = Just (mailcontents, bundle)

               sendmail = do
                 sm_cmd <- getSendmailCmd opts
                 let to = generateEmailToString thetargets
                 sendEmailDoc from to thesubject (getCc opts)
                               sm_cmd contentAndBundle body >>
                  putInfo opts (Msg.success to (getCc opts))
                 `catch` \e -> do warnMailBody
                                  fail $ ioeGetErrorString e

           when (null [ p | Post p <- thetargets]) sendmail
           nbody <- withOpenTemp $ \ (fh,fn) -> do
               let to = generateEmailToString thetargets
               generateEmail fh from to thesubject (getCc opts) body
               hClose fh
               mmapFilePS fn
           forM_ [ p | Post p <- thetargets]
             (\url -> do
                putInfo opts $ Msg.postingPatch url
                postUrl url (BC.unpack nbody) "message/rfc822")
             `catch` (\(_ :: IOException) -> sendmail)
           cleanup opts mailfile

generateEmailToString :: [WhatToDo] -> String
generateEmailToString = intercalate " , " . filter (/= "") . map extractEmail
  where
    extractEmail (SendMail t) = t
    extractEmail _ = ""

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

writeBundleToFile :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree)
                  => [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> 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)
                         putDocLn (Msg.wroteBundle a)
           putstd = putDoc (d $$ bundle)
       useAbsoluteOrStd putabs putstd fname
       let to = generateEmailToString wtds
       unless (null to) $ putInfo opts $ Msg.savedButNotSent to
       cleanup opts f

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

decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Maybe (Repository rt p wR wU wT) -> IO [WhatToDo]
decideOnBehavior opts remote_repo =
    case the_targets of
    [] -> do wtds <- case remote_repo of
                     Nothing -> return []
                     Just r -> check_post r
             unless (null wtds) $ announce_recipients wtds
             return wtds
    ts -> do announce_recipients ts
             return ts
    where the_targets = collectTargets opts
          -- 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 the_remote_repo =
                       do p <- ((readPost . BC.unpack) `fmap`
                                fetchFilePS (prefsUrl the_remote_repo++"/post")
                                (MaxAge 600)) `catchall` return []
                          emails <- who_to_email the_remote_repo
                          return (p++emails)
          readPost = map parseLine . lines where
              parseLine t = maybe (Post t) SendMail $ stripPrefix "mailto:" t
          who_to_email the_remote_repo =
              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
                msg = Msg.willSendTo (dryRun opts) (map pn emails)
            in if DryRun `elem` opts
            then putInfo opts msg
            else when (null the_targets && isNothing (getOutput opts "")) $
                 putInfo opts msg

getTargets :: [WhatToDo] -> IO [WhatToDo]
getTargets [] = fmap ((:[]) . SendMail) $ askUser Msg.promptTarget
getTargets wtds = return wtds

collectTargets :: [DarcsFlag] -> [WhatToDo]
collectTargets flags = [ f t | Target t <- flags ] where
    f url | "http:" `isPrefixOf` url = Post url
    f em = SendMail em

getDescription :: (RepoPatch p, ApplyState p ~ Tree)
               => [DarcsFlag] -> String -> FL (PatchInfoAnd rt p) wX wY -> IO (Doc, Maybe String, Maybe String)
getDescription opts their_name patches =
    case get_filename of
        Just file -> do
                     when (editDescription opts) $ do
                       when (isNothing $ hasLogfile opts) $
                            writeDocBinFile file patchdesc
                       debugMessage $ Msg.aboutToEdit file
                       (_, changed) <- editFile file
                       unless changed $ do
                         confirmed <- promptYorn Msg.promptNoDescriptionChange
                         unless confirmed $ do putDocLn Msg.aborted
                                               exitSuccess
                       return ()
                     
                     updatedFile <- updateFilename file
                     doc <- readDocBinFile updatedFile
                     
                     return (doc, Just updatedFile, tryGetCharset doc)
        Nothing -> return (patchdesc, Nothing, tryGetCharset patchdesc)
    where patchdesc = text (show len)
                      <+> text (englishNum len (Noun "patch") "")
                      <+> text "for repository" <+> text their_name <> text ":"
                      $$ text ""
                      $$ vsep (mapFL description patches)
            where
              len = lengthFL patches
          updateFilename file = 
                maybe (renameFile file darcsSendMessageFinal >>
                       return darcsSendMessageFinal) (return . toFilePath) $ hasLogfile opts
          get_filename = case hasLogfile opts of
                                Just f -> Just $ toFilePath f
                                Nothing -> if editDescription opts
                                              then Just darcsSendMessage
                                              else Nothing
          tryGetCharset content = let body = renderPS Standard content in
                                  if isAscii body
                                  then Just "us-ascii"
                                  else either (const Nothing)
                                              (const $ Just "utf-8")
                                              (decodeUtf8' body)