{-# OPTIONS_GHC -cpp -fffi #-}

module Darcs.External (
    backupByRenaming, backupByCopying,
    copyFileOrUrl, speculateFileOrUrl, copyFilesOrUrls, copyLocal, cloneFile,
    cloneTree, cloneTreeExcept, clonePartialsTree, clonePaths,
    fetchFilePS, gzFetchFilePS,
    sendEmail, generateEmail, sendEmailDoc, resendEmail,
    signString, verifyPS,
    execDocPipe, execPipeIgnoreError,
    getTermNColors,
    pipeDoc, pipeDocSSH, execSSH,
    maybeURLCmd,
    Cachable(Cachable, Uncachable, MaxAge),
    viewDoc, viewDocWith,
  ) where

import Data.List ( intersperse )
import Control.Monad ( liftM, when, zipWithM_ )
import System.Exit ( ExitCode(..) )
import System.Environment ( getEnv )
import System.Cmd ( system )
import System.IO ( hPutStr, hPutStrLn, hGetContents, hClose,
                   openBinaryFile, IOMode( ReadMode ),
                   openBinaryTempFile,
                   hIsTerminalDevice, stdout, stderr, Handle )
import System.IO.Error ( isDoesNotExistError )
import System.IO.Unsafe ( unsafePerformIO )
import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )
import System.Directory ( createDirectory, getDirectoryContents,
                          doesFileExist, doesDirectoryExist,
                          renameFile, renameDirectory, copyFile )
import System.Process ( runProcess, runInteractiveProcess, waitForProcess )
import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )
import Control.Exception ( bracket, try, finally )
import Data.Char ( toUpper )
import Foreign.C ( CString, withCString, CInt )
import Foreign.Ptr ( nullPtr )
#ifdef HAVE_CURSES
import Foreign.C ( CChar )
import Foreign.Ptr ( Ptr )
import Foreign.Marshal.Alloc (allocaBytes)
import Autoconf ( use_color )
#endif
import Workaround ( createLink, createDirectoryIfMissing )

import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL, NoLinks,
                                Verify, VerifySSL ) )
import Darcs.Utils ( withCurrentDirectory, breakCommand, get_viewer, ortryrunning, )
import Darcs.Progress ( withoutProgress, progressList, debugMessage )
import FastPackedString ( PackedString, readFilePS, gzReadFilePS, writeFilePS,
                          hPutPS, unpackPS, linesPS, unlinesPS,
                          lengthPS, takePS, dropPS, packString,
                          nullPS, nilPS, concatPS, hGetContentsPS
                        )
import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, canonFilename, writeDocBinFile,
                    removeFileMayNotExist, )
import CommandLine ( parseCmd, addUrlencoded )
import Autoconf ( have_libcurl, have_libwww, have_HTTP, have_sendmail, have_mapi, sendmail_path, darcs_version )
import qualified URL ( copyUrl, copyUrlFirst, waitUrl )
import qualified HTTP ( copyUrl, exists )
import Ssh ( getSSH, copySSH, copySSHs, SSHCmd(..) )
import URL ( Cachable(..) )
import Exec ( exec, Redirect(..), withoutNonBlock )
import FileName ( fn2fp, fp2fn, norm_path )
import Darcs.URL ( is_file, is_url, is_ssh )
import Darcs.Utils ( catchall )
import Printer ( Doc, Printers, putDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), (<+>), renderPS,
                 simplePrinters,
                 text, empty, packedString, vcat, renderString )
#include "impossible.h"

backupByRenaming :: FilePath -> IO ()
backupByRenaming = backupBy rename
 where rename x y = do
         isD <- doesDirectoryExist x
         if isD then renameDirectory x y else renameFile x y

backupByCopying :: FilePath -> IO ()
backupByCopying = backupBy copy
 where
  copy x y = do
    isD <- doesDirectoryExist x
    if isD then do createDirectory y
                   cloneTree (do_norm x) (do_norm y)
           else copyFile x y
  do_norm f = fn2fp $ norm_path $ fp2fn f

backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()
backupBy backup f =
           do hasBF <- doesFileExist f
              hasBD <- doesDirectoryExist f
              when (hasBF || hasBD) $ helper (0::Int)
  where
  helper i = do existsF <- doesFileExist next
                existsD <- doesDirectoryExist next
                if (existsF || existsD)
                   then helper (i + 1)
                   else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"
                           backup f next
             where next = f ++ suffix
                   suffix = "-darcs-backup" ++ show i

fetchFilePS :: String -> Cachable -> IO PackedString
fetchFilePS fou _ | is_file fou = readFilePS fou
fetchFilePS fou cache = withTemp $ \t -> do copyFileOrUrl [] fou t cache
                                            readFilePS t

gzFetchFilePS :: String -> Cachable -> IO PackedString
gzFetchFilePS fou _ | is_file fou = gzReadFilePS fou
gzFetchFilePS fou cache = withTemp $ \t-> do copyFileOrUrl [] fou t cache
                                             gzReadFilePS t


copyFileOrUrl :: [DarcsFlag] -> FilePath -> FilePath -> Cachable -> IO ()
copyFileOrUrl opts fou out _     | is_file fou = copyLocal opts fou out
copyFileOrUrl _    fou out cache | is_url  fou = copyRemote fou out cache
copyFileOrUrl _    fou out _     | is_ssh  fou = copySSH fou out
copyFileOrUrl _    fou _   _     = fail $ "unknown transport protocol: " ++ fou

speculateFileOrUrl :: String -> FilePath -> IO ()
speculateFileOrUrl fou out | is_url fou = speculateRemote fou out
                           | otherwise = return ()

copyLocal  :: [DarcsFlag] -> String -> FilePath -> IO ()
copyLocal opts fou out | NoLinks `elem` opts = cloneFile fou out
                       | otherwise = createLink fou out `catchall` cloneFile fou out

clonePaths :: FilePath -> FilePath -> [FilePath] -> IO ()
clonePaths source dest = mapM_ (clonePath source dest)

clonePath :: FilePath -> FilePath -> FilePath -> IO ()
clonePath source dest path
 = do let source' = source ++ "/" ++ path
          dest' = dest ++ "/" ++ path
      fs <- getSymbolicLinkStatus source'
      if isDirectory fs then do
          createDirectoryIfMissing True dest'
       else if isRegularFile fs then do
          createDirectoryIfMissing True (dest ++ "/" ++ basename path)
          cloneFile source' dest'
       else fail ("clonePath: Bad file " ++ source')
   `catch` fail ("clonePath: Bad file " ++ source ++ "/" ++ path)
 where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse

clonePartialsTree :: FilePath -> FilePath -> [FilePath] -> IO ()
clonePartialsTree source dest = mapM_ (clonePartialTree source dest)

clonePartialTree :: FilePath -> FilePath -> FilePath -> IO ()
clonePartialTree source dest "" = cloneTree source dest
clonePartialTree source dest pref
 = do createDirectoryIfMissing True (dest ++ "/" ++ basename pref)
      cloneSubTree (source ++ "/" ++ pref) (dest ++ "/" ++ pref)
 where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse

cloneTree :: FilePath -> FilePath -> IO ()
cloneTree = cloneTreeExcept []

cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()
cloneTreeExcept except source dest =
 do fs <- getSymbolicLinkStatus source
    if isDirectory fs then do
        fps <- getDirectoryContents source
        let fps' = filter (`notElem` (".":"..":except)) fps
            mk_source fp = source ++ "/" ++ fp
            mk_dest   fp = dest   ++ "/" ++ fp
        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
     else fail ("cloneTreeExcept: Bad source " ++ source)
   `catch` fail ("cloneTreeExcept: Bad source " ++ source)

cloneSubTree :: FilePath -> FilePath -> IO ()
cloneSubTree source dest =
 do fs <- getSymbolicLinkStatus source
    if isDirectory fs then do
        createDirectory dest
        fps <- getDirectoryContents source
        let fps' = filter (`notElem` [".", ".."]) fps
            mk_source fp = source ++ "/" ++ fp
            mk_dest   fp = dest   ++ "/" ++ fp
        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
     else if isRegularFile fs then do
        cloneFile source dest
     else fail ("cloneSubTree: Bad source "++ source)
    `catch` (\e -> if isDoesNotExistError e
                   then return ()
                   else ioError e)

cloneFile :: FilePath -> FilePath -> IO ()
cloneFile = copyFile

maybeURLCmd :: String -> String -> IO(Maybe(String))
maybeURLCmd what url =
  do let prot = map toUpper $ takeWhile (/= ':') url
     liftM Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))
             `catch` \_ -> return Nothing

speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable
speculateRemote u v =
    do maybeget <- maybeURLCmd "GET" u
       case maybeget of
         Just _ -> return () -- can't pipeline these
         Nothing -> if have_libwww || have_libcurl
                    then URL.copyUrl u v Cachable
                    else return ()

copyRemote :: String -> FilePath -> Cachable -> IO ()
copyRemote u v cache =
    do maybeget <- maybeURLCmd "GET" u
       case maybeget of
         Nothing -> copyRemoteNormal u v cache
         Just get ->
           do let (cmd,args) = breakCommand get
              r <- exec cmd (args++[u]) (Null, File v, AsIs)
              when (r /= ExitSuccess) $
                  fail $ "(" ++ get ++ ") failed to fetch: " ++ u

copyRemoteNormal :: String -> FilePath -> Cachable -> IO ()
copyRemoteNormal u v cache = if have_libwww || have_libcurl
                             then URL.copyUrlFirst u v cache >> URL.waitUrl u
                             else if HTTP.exists
                                  then HTTP.copyUrl u v cache
                                  else copyRemoteCmd u v

copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO ()
copyFilesOrUrls opts dou ns out _ | is_file dou = copyLocals opts dou ns out
copyFilesOrUrls _ dou ns out c    | is_url  dou = copyRemotes dou ns out c
copyFilesOrUrls _ dou ns out _    | is_ssh  dou = copySSHs dou ns out
copyFilesOrUrls _ dou _  _   _    = fail $ "unknown transport protocol: "++dou


copyLocals :: [DarcsFlag] -> String -> [String] -> FilePath -> IO ()
copyLocals opts u ns d =
    doWithPatches (\n -> copyLocal opts (u++"/"++n) (d++"/"++n)) ns

copyRemotes :: String -> [String] -> FilePath -> Cachable -> IO()
copyRemotes u ns d cache =
    do maybeget <- maybeURLCmd "GET" u
       maybemget <- maybeURLCmd "MGET" u
       case (maybeget, maybemget) of
         (Nothing, _) -> copyRemotesNormal u ns d cache
         (Just _, Nothing) -> doWithPatches (\n -> copyRemote (u++"/"++n) (d++"/"++n) cache) ns
         (Just _, Just mget) -> mgetRemotes mget u ns d

stringToInt :: String -> Int -> Int
stringToInt num def = case reads num of [(x,"")] -> x
                                        _ -> def

mgetRemotes :: String -> String -> [String] -> FilePath -> IO()
mgetRemotes _ _ [] _ = return ()
mgetRemotes mget u ns d = do
    mgetmax <- getEnv "DARCS_MGETMAX" `catch` \_ -> return ""
    let (nsnow, nslater) = splitAt (stringToInt mgetmax 200) ns
        (cmd, args) = breakCommand mget
        urls = map (\n -> u++"/"++n) nsnow
    withCurrentDirectory d $ do
        r <- exec cmd (args++urls) (Null,Null,AsIs)
        when (r /= ExitSuccess) $
            fail $ unlines $
                ["(" ++ mget ++ ") failed to fetch files.",
                     "source directory: " ++ d,
                     "source files:"] ++ (upto 5 nsnow) ++
                     ["still to go:"] ++ (upto 5 nslater)
    mgetRemotes mget u nslater d
    where
    upto :: Integer -> [String] -> [String]
    upto _ [] = []
    upto 0 l = [ "(" ++ (show (length l)) ++ " more)" ]
    upto n (h : t) = h : (upto (n - 1) t)

copyRemotesNormal :: String -> [String] -> FilePath -> Cachable -> IO()
copyRemotesNormal u ns d cache =
    if have_libwww || have_libcurl
    then do mapM_ (\n -> URL.copyUrl (u++"/"++n) (d++"/"++n) cache) ns
            doWithPatches (\n -> URL.waitUrl (u++"/"++n)) ns
    else if have_HTTP
         then doWithPatches (\n -> copyRemote (u++"/"++n) (d++"/"++n) cache) ns
         else wgetRemotes u ns d

-- Argh, this means darcs get will fail if we don't have libcurl and don't
-- have wget.  :(
wgetRemotes :: String -> [String] -> FilePath -> IO ()
wgetRemotes u ns d = do wget_command <- getEnv "DARCS_WGET" `catch`
                                               \_ -> return "wget"
                        let (wget, wget_args) = breakCommand wget_command
                            input = unlines $ map (\n -> u++"/"++n) ns
                        withCurrentDirectory d $ withOpenTemp $ \(th,tn) ->
                            do hPutStr th input
                               hClose th
                               r <- exec wget (wget_args++["-i",tn])
                                         (Null,Null,AsIs)
                               when (r /= ExitSuccess) $
                                    fail $ unlines $
                                             ["(wget) failed to fetch files.",
                                              "source directory: " ++ d,
                                              "source files:"] ++ ns

copyRemoteCmd :: String -> FilePath -> IO ()
copyRemoteCmd s tmp = do
    let cmd = get_ext_cmd
    r <- stupidexec (cmd tmp s) (Null,Null,AsIs)
    when (r /= ExitSuccess) $
         fail $ "failed to fetch: " ++ s ++" " ++ show r
    where stupidexec [] = bug "stupidexec without a command"
          stupidexec xs = exec (head xs) (tail xs)

doWithPatches :: (String -> IO ()) -> [String] -> IO ()
doWithPatches f patches = mapM_ (\p -> seq p $ f p) $ progressList "Copying patch" patches

{-# NOINLINE get_ext_cmd #-}
get_ext_cmd :: String -> String -> [String]
-- Only need to find the command once..
get_ext_cmd = unsafePerformIO get_ext_cmd'

-- Would be better to read possible command lines from config-file..
get_ext_cmd' :: IO (String -> String -> [String])
get_ext_cmd' = try_cmd cmds
    where cmds = [("wget", (("--version",0),
                          -- use libcurl for proper cache control
                          \t s -> ["wget", "-q",
                                   "--header=Pragma: no-cache",
                                   "--header=Cache-Control: no-cache",
                                   "-O",t,s])),
                  ("curl", (("--version",2),
                            \t s -> ["curl", "-s", "-f", "-L",
                                     "-H", "Pragma: no-cache",
                                     "-H", "Cache-Control: no-cache",
                                     "-o",t,s]))]
          try_cmd [] = fail $ "I need one of: " ++ cs
              where cs = concat $ intersperse ", " (map fst cmds)
          try_cmd ((c,(ok_check,f)):cs) = do
            True <- can_execute ok_check c
            return f
           `catch` (\_ -> try_cmd cs)

-- | Run a command on a remote location without passing it any input or
--   reading its output.  Return its ExitCode
execSSH :: String -> String -> IO ExitCode
execSSH remoteAddr command =
    do (ssh, ssh_args) <- getSSH SSH remoteAddr
       debugMessage $ unwords (ssh:ssh_args++[remoteAddr,command])
       withoutProgress $ do hid <- runProcess ssh (ssh_args++[remoteAddr,command])
                                   Nothing Nothing Nothing Nothing Nothing
                            waitForProcess hid

pipeDoc :: String -> [String] -> Doc -> IO ExitCode
pipeDoc c args inp = withoutNonBlock $ withoutProgress $
    do debugMessage $ unwords (c:args)
       (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing
       mvare <- newEmptyMVar
       forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed
                hPutStr stderr)
               `finally` putMVar mvare ())
       mvaro <- newEmptyMVar
       forkIO ((hGetContents o >>= -- ratify hGetContents: it's immediately consumed
                hPutStr stdout)
               `finally` putMVar mvaro ())
       hPutDoc i inp
       hClose i
       rval <- waitForProcess pid
       takeMVar mvare
       takeMVar mvaro
       when (rval == ExitFailure 127) $
            putStrLn $ "Command not found:\n   "++ show (c:args)
       return rval

pipeDocSSH :: String -> [String] -> Doc -> IO ExitCode
pipeDocSSH remoteAddr args input =
    do (ssh, ssh_args) <- getSSH SSH remoteAddr
       pipeDoc ssh (ssh_args++ (remoteAddr:args)) input

sendEmail :: String -> String -> String -> String -> String -> String -> IO ()
sendEmail f t s cc scmd body =
  sendEmailDoc f t s cc scmd Nothing (text body)


generateEmail
    :: Handle  -- ^ handle to write email to
    -> String  -- ^ From
    -> String  -- ^ To
    -> String  -- ^ Subject
    -> String  -- ^ CC
    -> Doc     -- ^ body
    -> IO ()
generateEmail h f t s cc body = do
     hPutDocLn h $
           text "To:"      <+> text t
        $$ text "From:"    <+> text f
        $$ text "Subject:" <+> text s
        $$ formated_cc
        $$ text "X-Mail-Originator: Darcs Version Control System"
        $$ text ("X-Darcs-Version: " ++ darcs_version)
        $$ body
  where formated_cc = if cc == ""
                      then empty
                      else text "Cc:" <+> text cc

-- | Send an email, optionally containing a patch bundle
--   (more precisely, its description and the bundle itself)
sendEmailDoc :: String -> String -> String -> String -> String
             -> Maybe (Doc, Doc) -> Doc -> IO ()
sendEmailDoc _ "" _ "" _ _ _ = return ()
sendEmailDoc f "" s cc scmd mbundle body =
  sendEmailDoc f cc s "" scmd mbundle body
sendEmailDoc f t s cc scmd mbundle body =
  if have_sendmail || scmd /= "" then do
    withOpenTemp $ \(h,fn) -> do
     generateEmail h f t s cc body
     hClose h
     ftable' <- case mbundle of
                Just (content,bundle) ->
                  withOpenTemp $ \(hat,at) -> do
                    hPutDocLn hat $ bundle
                    hClose hat
                    return [ ('b', renderString content) , ('a', at) ]
                Nothing ->
                    return [ ('b', renderString body) ]
     let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable'
     r <- execSendmail ftable scmd fn
     when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t
                                     ++ "\nPerhaps sendmail is not configured.")
  else if have_mapi then do
     r <- withCString t $ \tp ->
           withCString f $ \fp ->
            withCString cc $ \ccp ->
             withCString s $ \sp ->
              withOpenTemp $ \(h,fn) -> do
               hPutDoc h body
               hClose h
               writeDocBinFile "mailed_patch" body
               cfn <- canonFilename fn
               withCString cfn $ \pcfn ->
                c_send_email fp tp ccp sp nullPtr pcfn
     when (r /= 0) $ fail ("failed to send mail to: " ++ t)
  else fail $ "no mail facility (sendmail or mapi) located at configure time!"
  where addressOnly a =
          case dropWhile (/= '<') a of
          ('<':a2) -> takeWhile (/= '>') a2
          _        -> a

resendEmail :: String -> String -> PackedString -> IO ()
resendEmail "" _ _ = return ()
resendEmail t scmd body =
  case (have_sendmail || scmd /= "", have_mapi) of
   (True, _) -> do
    withOpenTemp $ \(h,fn) -> do
     hPutStrLn h $ "To: "++ t
     hPutStrLn h $ find_from (linesPS body)
     hPutStrLn h $ find_subject (linesPS body)
     hPutDocLn h $ fixit $ linesPS body
     hClose h
     let ftable = [('t',t)]
     r <-  execSendmail ftable scmd fn
     when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t)
   (_, True) -> fail "Don't know how to resend email with MAPI"
   _ -> fail $ "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"
  where br = packString "\r"
        darcsurl = packString "DarcsURL:"
        content = packString "Content-"
        from_start = packString "From:"
        subject_start = packString "Subject:"
        fixit (l:ls)
         | nullPS l = packedString nilPS $$ vcat (map packedString ls)
         | l == br = packedString nilPS $$ vcat (map packedString ls)
         | takePS 9 l == darcsurl || takePS 8 l == content
            = packedString l $$ fixit ls
         | otherwise = fixit ls
        fixit [] = empty
        find_from (l:ls) | takePS 5 l == from_start = unpackPS l
                         | otherwise = find_from ls
        find_from [] = "From: unknown"
        find_subject (l:ls) | takePS 8 l == subject_start = unpackPS l
                            | otherwise = find_subject ls
        find_subject [] = "Subject: (no subject)"

execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode
execSendmail ftable scmd fn =
  if scmd == "" then
     exec sendmail_path ["-i", "-t"] (File fn, Null, AsIs)
  else case parseCmd (addUrlencoded ftable) scmd of
         Right (arg0:opts, wantstdin) ->
           do let stdin = if wantstdin then File fn else Null
              exec arg0 opts (stdin, Null, AsIs)
         Left e -> fail $ ("failed to send mail, invalid sendmail-command: "++(show e))
         _ -> fail $ ("failed to send mail, invalid sendmail-command")

#ifdef HAVE_MAPI
foreign import ccall "win32/send_email.h send_email" c_send_email
#else
c_send_email
#endif
             :: CString -> {- sender -}
                CString -> {- recipient -}
                CString -> {- cc -}
                CString -> {- subject -}
                CString -> {- body -}
                CString -> {- path -}
                IO Int
#ifndef HAVE_MAPI
c_send_email = impossible
#endif

execPSPipe :: String -> [String] -> PackedString -> IO PackedString
execPSPipe c args ps = liftM renderPS
                     $ execDocPipe c args
                     $ packedString ps

execDocPipe :: String -> [String] -> Doc -> IO Doc
execDocPipe c args instr = withoutProgress $
    do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing
       forkIO $ hPutDoc i instr >> hClose i
       mvare <- newEmptyMVar
       forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed
                hPutStr stderr)
               `finally` putMVar mvare ())
       out <- hGetContentsPS o
       rval <- waitForProcess pid
       takeMVar mvare
       case rval of
         ExitFailure ec ->fail $ "External program '"++c++
                          "' failed with exit code "++ show ec
         ExitSuccess -> return $ packedString out

-- The following is needed for diff, which returns non-zero whenever
-- the files differ.
execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc
execPipeIgnoreError c args instr = withoutProgress $
    do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing
       forkIO $ hPutDoc i instr >> hClose i
       mvare <- newEmptyMVar
       forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed
                hPutStr stderr)
               `finally` putMVar mvare ())
       out <- hGetContentsPS o
       waitForProcess pid
       takeMVar mvare
       return $ packedString out

signString :: [DarcsFlag] -> Doc -> IO Doc
signString [] d = return d
signString (Sign:_) d = signPGP [] d
signString (SignAs keyid:_) d = signPGP ["--local-user", keyid] d
signString (SignSSL idf:_) d = signSSL idf d
signString (_:os) d = signString os d

signPGP :: [String] -> Doc -> IO Doc
signPGP args t = execDocPipe "gpg" ("--clearsign":args) t

signSSL :: String -> Doc -> IO Doc
signSSL idfile t =
    withTemp $ \cert -> do
    opensslPS ["req", "-new", "-key", idfile,
               "-outform", "PEM", "-days", "365"]
                (packString "\n\n\n\n\n\n\n\n\n\n\n")
                >>= opensslPS ["x509", "-req", "-extensions",
                               "v3_ca", "-signkey", idfile,
                               "-outform", "PEM", "-days", "365"]
                >>= opensslPS ["x509", "-outform", "PEM"]
                >>= writeFilePS cert
    opensslDoc ["smime", "-sign", "-signer", cert,
                "-inkey", idfile, "-noattr", "-text"] t
    where opensslDoc = execDocPipe "openssl"
          opensslPS = execPSPipe "openssl"


verifyPS :: [DarcsFlag] -> PackedString -> IO (Maybe PackedString)
verifyPS [] ps = return $ Just ps
verifyPS (Verify pks:_) ps = verifyGPG pks ps
verifyPS (VerifySSL auks:_) ps = verifySSL auks ps
verifyPS (_:os) ps = verifyPS os ps

verifyGPG :: FilePath -> PackedString -> IO (Maybe PackedString)
verifyGPG goodkeys s =
    withOpenTemp $ \(th,tn) -> do
      hPutPS th s
      hClose th
      rval <- exec "gpg"  ["--batch","--no-default-keyring",
                           "--keyring",fix_path goodkeys, "--verify"]
                           (File tn, Null, Null)
      case rval of
          ExitSuccess -> return $ Just gpg_fixed_s
          _ -> return Nothing
      where gpg_fixed_s = let
                not_begin_signature x =
                    x /= packString "-----BEGIN PGP SIGNED MESSAGE-----"
                    &&
                    x /= packString "-----BEGIN PGP SIGNED MESSAGE-----\r"
                in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s
            fix_line x | lengthPS x < 3 = x
                       | takePS 3 x == packString "- -" = dropPS 2 x
                       | otherwise = x
#if defined(WIN32)
            fix_sep c | c=='/' = '\\'   | otherwise = c
            fix_path p = map fix_sep p
#else
            fix_path p = p
#endif

verifySSL :: FilePath -> PackedString -> IO (Maybe PackedString)
verifySSL goodkeys s = do
    certdata <- opensslPS ["smime", "-pk7out"] s
                >>= opensslPS ["pkcs7", "-print_certs"]
    cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata
    let key_used = concatPS $ tail $
                   takeWhile (/= packString"-----END PUBLIC KEY-----")
                           $ linesPS cruddy_pk
        in do allowed_keys <- linesPS `liftM` readFilePS goodkeys
              if not $ key_used `elem` allowed_keys
                then return Nothing -- Not an allowed key!
                else withTemp $ \cert ->
                     withTemp $ \on ->
                     withOpenTemp $ \(th,tn) -> do
                     hPutPS th s
                     hClose th
                     writeFilePS cert certdata
                     rval <- exec "openssl" ["smime", "-verify", "-CAfile",
                                             cert, "-certfile", cert]
                                             (File tn, File on, Null)
                     case rval of
                       ExitSuccess -> Just `liftM` readFilePS on
                       _ -> return Nothing
    where opensslPS = execPSPipe "openssl"

can_execute :: (String,Int) -> String -> IO Bool
can_execute (arg,expected_return_value) exe = do
 withTemp $ \junk -> do
  ec <- system (unwords [exe,arg,">",junk])
  case ec of
    ExitSuccess | expected_return_value == 0 -> return True
    ExitFailure r | r == expected_return_value -> return True
    _ -> return False


{-
  - This function returns number of colors supported by current terminal
  - or -1 if color output not supported or error occured.
  - Terminal type determined by TERM env. variable.
  -}
getTermNColors :: IO CInt

#ifdef HAVE_CURSES

foreign import ccall "tgetnum" c_tgetnum :: CString -> IO CInt
foreign import ccall "tgetent" c_tgetent :: Ptr CChar -> CString -> IO CInt

termioBufSize :: Int
termioBufSize = 4096

getTermNColors = if not use_color
                 then return (-1)
                 else do term <- getEnv "TERM"
                         allocaBytes termioBufSize (getTermNColorsImpl term)
                      `catch` \_ -> return (-1)

getTermNColorsImpl :: String -> Ptr CChar -> IO CInt
getTermNColorsImpl term buf = do rc <- withCString term $
                                       \termp -> c_tgetent buf termp
                                 if (rc /= 1) then return (-1)  else withCString "Co" $ \capap -> c_tgetnum capap

#else

getTermNColors = return (-1)

#endif

viewDoc :: Doc -> IO ()
viewDoc = viewDocWith simplePrinters

viewDocWith :: Printers -> Doc -> IO ()
viewDocWith pr msg = do
  isTerminal <- hIsTerminalDevice stdout
  if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg)
     then do viewer <- get_viewer
             pipeDocToPager viewer [] pr msg
               `ortryrunning` pipeDocToPager  "less" [] pr msg
               `ortryrunning` pipeDocToPager  "more" [] pr msg
               `ortryrunning` pipeDocToPager "" [] pr msg
     else pipeDocToPager "" [] pr msg
  return ()
              where lengthGreaterThan n _ | n <= 0 = True
                    lengthGreaterThan _ [] = False
                    lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs

pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode

pipeDocToPager "" _ pr inp = do
  putDocLnWith pr inp
  return ExitSuccess

pipeDocToPager c args pr inp = withoutNonBlock $ withoutProgress $ do
  tmp <- tempdir_loc
  bracket (openBinaryTempFile tmp "darcs-pager") cleanup $ \(fn,fh) ->
    do hPutDocWith pr fh inp
       hClose fh
       h <- openBinaryFile fn ReadMode
       x <- do pid <- runProcess c args Nothing Nothing (Just h) Nothing Nothing
               waitForProcess pid
       when (x == ExitFailure 127) $
            putStrLn $ "Command not found:\n   "++ show (c:args)
       return x
  where
    cleanup (f,h) = do try $ hClose h
                       removeFileMayNotExist f