module External (
    copyFileOrUrl,
    fetchFilePS, gzFetchFilePS,
    sendEmail, resendEmail,
    signString, verifyPS,
    execPipe, execPipeIgnoreError,
    getTermNColors,
    pipeSSH_IgnoreError,
    Cachable(Cachable, Uncachable, MaxAge)
  ) where

import List ( intersperse )
import Monad ( liftM, when )
import System ( ExitCode(..), system, getEnv )
import IO ( hPutStr, hClose, try )
import System.IO.Unsafe ( unsafePerformIO )
import Foreign.C ( CString, withCString )
import Foreign.Ptr ( nullPtr )
#ifdef HAVE_CURSES
import Foreign.C ( CChar )
import Foreign.Ptr ( Ptr )
import Foreign.Marshal.Alloc (allocaBytes)
#endif
import Workaround ( createLink )

import DarcsFlags ( DarcsFlag( SignAs, Sign, SignSSL,
                               Verify, VerifySSL ) )
import FastPackedString ( PackedString, readFilePS, gzReadFilePS, writeFilePS,
                          hPutPS, unpackPS, linesPS, unlinesPS,
                          lengthPS, takePS, dropPS, packString,
                        )
import Lock ( withTemp, withOpenTemp, readBinFile, canonFilename, writeBinFile )
import Autoconf ( have_libcurl, have_sendmail, have_mapi, sendmail_path, use_color )
import Curl ( readUrlPS, copyUrl )
import Curl ( Cachable(..) )
import Exec ( exec )
import DarcsURL ( is_file, is_url )
import DarcsUtils ( catchall )
#include "impossible.h"

fetchFilePS :: String -> Cachable -> IO PackedString
fetchFilePS fou _ | is_file fou = readFilePS fou
fetchFilePS fou cache = readRemotePS fou cache

gzFetchFilePS :: String -> Cachable -> IO PackedString
gzFetchFilePS fou cache = withTemp $ \t-> do copyFileOrUrl fou t cache
                                             gzReadFilePS t

copyRemote :: String -> FilePath -> Cachable -> IO ()
copyRemote u v cache | is_url u = if have_libcurl
                                  then Curl.copyUrl u v cache
                                  else copyRemoteCmd u v
copyRemote u v _ = copySSH u v

copyRemoteCmd :: String -> FilePath -> IO ()
copyRemoteCmd s tmp = do
    let cmd = get_ext_cmd
    r <- stupidexec (cmd tmp s) "/dev/null" "/dev/null"
    when (r /= ExitSuccess) $
         fail $ "failed to fetch: " ++ s ++" " ++ show r
    where stupidexec (c:args) inf outf = exec c args inf outf
          stupidexec [] _ _ = bug "stupidexec without a command"

{-# 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", "-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)

readRemotePS :: String -> Cachable -> IO PackedString
readRemotePS s cache | is_url s =
 if have_libcurl then readUrlPS s cache
 else
  withTemp $ \tmp -> do
    copyRemoteCmd s tmp
    readFilePS tmp
readRemotePS s _ = readSSH_PS s

{- '$' in filenames is troublesome for scp, for some reason.. -}
escape_hash :: String -> String
escape_hash = concatMap f
 where f '$' = "\\$"
       f c = [c]

pipeSSH_IgnoreError :: [String] -> String -> IO String
pipeSSH_IgnoreError args input =
    do p <- try $ getEnv "SSH_PORT" -- or DARCS_SSH_PORT ?
       ssh_command <- getEnv "DARCS_SSH" `catch`
                      \_ -> return "ssh"
       let port = either (const []) (\x->["-p",x]) p
           ssh = head $ words ssh_command
           ssh_args = tail $ words ssh_command
       execPipeIgnoreError ssh (ssh_args++port++args) input

copySSH :: String -> FilePath -> IO ()
copySSH u f = do p <- try $ getEnv "SSH_PORT" -- or DARCS_SSH_PORT ?
                 scp_command <- getEnv "DARCS_SCP" `catch`
                                \_ -> return "scp"
                 let port = either (const []) (\x->["-P",x]) p
                     scp = head $ words scp_command
                     scp_args = tail $ words scp_command
                 r <- exec scp (scp_args++port++[escape_hash u,f])
                      "/dev/null" "/dev/null"
                 when (r /= ExitSuccess) $
                      fail $ "(scp) failed to fetch: " ++ u

readSSH_PS :: String -> IO PackedString
readSSH_PS path =
  withTemp $ \tmp -> do copySSH path tmp
                        readFilePS tmp

copyFileOrUrl :: FilePath -> FilePath -> Cachable -> IO ()
copyFileOrUrl fou out _ | is_file fou =
    createLink fou out `catchall` do c <- readFilePS fou
                                     writeFilePS out c
copyFileOrUrl fou out cache = copyRemote fou out cache


sendEmail :: String -> String -> String -> String -> String -> IO ()
sendEmail _ "" _ "" _ = return ()
sendEmail f "" s cc body = sendEmail f cc s "" body
sendEmail f t s cc body =
  case (have_sendmail, have_mapi) of
   (True, _) -> do
    withOpenTemp $ \(h,fn) -> do
     hPutStr h $
        "To: "      ++ t ++ "\n" ++
        "From: "    ++ f ++ "\n" ++
        "Subject: " ++ s ++ "\n" ++
        formated_cc ++
        body
     hClose h
     r <- exec sendmail_path ["-t"] fn "/dev/null"
     when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t)
   (_, True) -> do
     r <- withCString t $ \tp ->
           withCString f $ \fp ->
            withCString cc $ \ccp -> 
             withCString s $ \sp ->
              withOpenTemp $ \(h,fn) -> do
               hPutStr h body
               hClose h
               writeBinFile "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)
   _ -> fail $ "no mail facility (sendmail or mapi) located at configure time!"
  where formated_cc = if cc == ""
                      then ""
                      else "Cc: "++cc++"\n"

resendEmail :: String -> String -> IO ()
resendEmail "" _ = return ()
resendEmail t body =
  case (have_sendmail, have_mapi) of
   (True, _) -> do
    withOpenTemp $ \(h,fn) -> do
     hPutStr h $ "To: "++ t ++ "\n"
     hPutStr h $ find_from (lines body) ++ "\n"
     hPutStr h $ find_subject (lines body) ++ "\n"
     hPutStr h $ unlines $ fixit $ lines body
     hClose h
     r <- exec sendmail_path ["-t"] fn "/dev/null"
     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!"
  where fixit ("":ls) = "": ls
        fixit ("\r":ls) = "": ls
        fixit (l:ls) | l `starts_with` "DarcsURL:" ||
                       l `starts_with` "Content-"
                         = l : fixit ls
        fixit (_:ls) = fixit ls
        fixit [] = []
        find_from (l:ls) | take 5 l == "From:" = l
                         | otherwise = find_from ls
        find_from [] = "From: unknown"
        find_subject (l:ls) | take 8 l == "Subject:" = l
                            | otherwise = find_subject ls
        find_subject [] = "Subject: (no subject)"
        _ `starts_with` [] = True
        (a:as) `starts_with` (b:bs) = a == b && as `starts_with` bs
        _ `starts_with` _ = False

foreign import ccall "win32/send_email.h send_email" c_send_email ::
                CString -> {- sender -}
                CString -> {- recipient -}
                CString -> {- cc -}
                CString -> {- subject -}
                CString -> {- body -}
                CString -> {- path -}
                IO Int

execPipe :: String -> [String] -> String -> IO String
execPipe c args instr =
    withOpenTemp $ \(th,tn) -> do
      hPutStr th instr
      hClose th
      withTemp $ \on -> do
        rval <- exec c args tn on
        if rval == ExitSuccess
           then readBinFile on
           else fail $ "Error running external program '"++c++"'"

-- The following is needed for diff, which returns non-zero whenever
-- the files differ.
execPipeIgnoreError :: String -> [String] -> String -> IO String
execPipeIgnoreError c args instr =
    withOpenTemp $ \(th,tn) -> do
      hPutStr th instr
      hClose th
      withTemp $ \on -> do exec c args tn on
                           readBinFile on

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

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

signSSL :: String -> String -> IO String
signSSL idfile t =
    withTemp $ \cert -> do
    openssl ["req", "-new", "-key", idfile,
             "-outform", "PEM", "-days", "365"]
                "\n\n\n\n\n\n\n\n\n\n\n"
                >>= openssl ["x509", "-req", "-extensions",
                             "v3_ca", "-signkey", idfile,
                             "-outform", "PEM", "-days", "365"]
                >>= openssl ["x509", "-outform", "PEM"]
                >>= writeFile cert
    openssl ["smime", "-sign", "-signer", cert,
             "-inkey", idfile, "-noattr", "-text"] t
    where openssl = execPipe "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",goodkeys, "--verify"] tn "/dev/null"
      case rval of
          ExitSuccess -> return $ Just gpg_fixed_s
          _ -> return Nothing
      where gpg_fixed_s = unlinesPS $ map fix_line $ tail $
                          dropWhile (/= packString "-----BEGIN PGP SIGNED MESSAGE-----") $ linesPS s
            fix_line x | lengthPS x < 3 = x
                       | takePS 3 x == packString "- -" = dropPS 2 x
                       | otherwise = x

verifySSL :: FilePath -> PackedString -> IO (Maybe PackedString)
verifySSL goodkeys s = do
    certdata <- openssl ["smime", "-pk7out"] (unpackPS s)
                >>= openssl ["pkcs7", "-print_certs"]
    cruddy_pk <- openssl ["x509", "-pubkey"] certdata
    let key_used = concat $ tail $
                   takeWhile (/="-----END PUBLIC KEY-----") $ lines cruddy_pk
        in do allowed_keys <- lines `liftM` readBinFile 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
                     writeFile cert certdata
                     rval <- exec "openssl" ["smime", "-verify", "-CAfile",
                                             cert, "-certfile", cert] tn on
                     case rval of
                       ExitSuccess -> Just `liftM` readFilePS on
                       _ -> return Nothing
    where openssl = execPipe "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 colours supported by current terminal
  - or -1 if colour output not supported or error occured.
  - Terminal type determined by TERM env. variable.
  -}
getTermNColors :: IO Int

#ifdef HAVE_CURSES

foreign import ccall "term.h tgetnum" c_tgetnum :: CString -> IO Int
foreign import ccall "term.h tgetent" c_tgetent :: Ptr CChar -> CString -> IO Int

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 Int
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