External.hs

{-# LANGUAGE CPP, ForeignFunctionInterface #-}

module Darcs.UI.External
    ( sendEmail
    , generateEmail
    , sendEmailDoc
    , signString
    , verifyPS
    , execDocPipe
    , pipeDoc
    , pipeDocSSH
    , viewDoc
    , viewDocWith
    , checkDefaultSendmail
    , diffProgram
    , darcsProgram
    , editText
    , editFile
    --  * Locales
    , setDarcsEncodings
    ) where

import Darcs.Prelude

import Data.Maybe ( isJust )
import Safe ( tailErr )
import Control.Monad ( unless, when, filterM, void )
#ifndef WIN32
import Control.Monad ( liftM2 )
#endif
import System.Exit ( ExitCode(..) )
import System.Environment
    ( getEnv
    , getExecutablePath
    )
import System.Directory ( doesFileExist, findExecutable )
import System.IO
    ( Handle
    , hClose
    , hIsTerminalDevice
    , stderr
    , stdout
    )
#ifndef WIN32
import System.FilePath.Posix ( (</>) )
#endif
import System.Process ( createProcess, proc, CreateProcess(..), runInteractiveProcess, waitForProcess, StdStream(..) )

#ifndef WIN32
import GHC.IO.Encoding
    ( getFileSystemEncoding
    , setForeignEncoding
    , setLocaleEncoding )
#endif

import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )
import Control.Exception ( IOException, finally, try )
import System.IO.Error ( ioeGetErrorType )
import GHC.IO.Exception ( IOErrorType(ResourceVanished) )
#ifdef WIN32
import Foreign.C ( withCString )
import Foreign.C.String ( CString )
import Foreign.Ptr ( nullPtr )
import Darcs.Util.Lock ( writeDocBinFile )
import System.Directory ( canonicalizePath )
#endif

import Darcs.UI.Options.All ( Sign(..), Verify(..), Compression(..) )
import Darcs.Util.Path
    ( AbsolutePath
    , toFilePath
    , FilePathLike
    )
import Darcs.Util.Progress ( withoutProgress, debugMessage )

import Darcs.Util.ByteString (linesPS, unlinesPS)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC

import Darcs.Util.File ( withOpenTemp, withTemp )
import Darcs.Util.Lock ( withNamedTemp )
import Darcs.Util.Ssh ( getSSH, SSHCmd(..) )
import Darcs.Util.CommandLine ( parseCmd, addUrlencoded )
#ifndef WIN32
import Darcs.Util.English ( orClauses )
#endif
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Exec ( execInteractive, exec, Redirect(..), withoutNonBlock )
import Darcs.Util.URL ( SshFilePath, sshUhost )
import Darcs.Util.Printer
    ( Doc
    , Printers
    , hPutDoc
    , hPutDocCompr
    , hPutDocLn
    , hPutDocLnWith
    , hPutDocWith
    , packedString
    , renderPS
    , renderString
    , simplePrinters
    , text
    )
import Darcs.UI.Email ( formatHeader )

#ifndef WIN32
sendmailPath :: IO String
sendmailPath = do
  let searchPath = [ "/usr/sbin", "/sbin", "/usr/lib" ]
  l <- filterM doesFileExist $ liftM2 (</>)
                searchPath
                [ "sendmail" ]
  ex <- findExecutable "sendmail"
  case (ex, l) of
    (Just v, _) -> return v
    (_, v:_) -> return v
    _ -> fail $ "Cannot find the 'sendmail' program in " ++
      orClauses ("your PATH" : searchPath) ++ "."
#endif

diffProgram :: IO String
diffProgram = do
  l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ]
  case l of
    [] -> fail "Cannot find the \"diff\" program."
    v:_ -> return v

-- |Get the name of the darcs executable (as supplied by @getExecutablePath@)
darcsProgram :: IO String
darcsProgram = getExecutablePath

pipeDoc :: String -> [String] -> Doc -> IO ExitCode
pipeDoc = pipeDocInternal (PipeToOther simplePrinters)

data WhereToPipe = PipeToSsh Compression -- ^ if pipe to ssh, can choose to compress or not
                 | PipeToOther Printers  -- ^ otherwise, can specify printers

pipeDocInternal :: WhereToPipe -> String -> [String] -> Doc -> IO ExitCode
pipeDocInternal whereToPipe c args inp = withoutNonBlock $ withoutProgress $
    do debugMessage $ "Exec: " ++ unwords (map show (c:args))
       (Just i,_,_,pid) <- createProcess (proc c args){ std_in = CreatePipe
                                                      , delegate_ctlc = True}
       debugMessage "Start transferring data"
       case whereToPipe of
          PipeToSsh GzipCompression -> hPutDocCompr i inp
          PipeToSsh NoCompression   -> hPutDoc i inp
          PipeToOther printers      -> hPutDocWith printers i inp
       hClose i
       rval <- waitForProcess pid
       debugMessage "Finished transferring data"
       when (rval == ExitFailure 127) $
            putStrLn $ "Command not found:\n   "++ show (c:args)
       return rval

pipeDocSSH :: Compression -> SshFilePath -> [String] -> Doc -> IO ExitCode
pipeDocSSH compress remoteAddr args input = do
    (ssh, ssh_args) <- getSSH SSH
    pipeDocInternal (PipeToSsh compress) ssh (ssh_args ++ ("--":sshUhost remoteAddr:args)) input

sendEmail :: String -> String -> String -> String -> Maybe 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
     putHeader "To" t
     putHeader "From" f
     putHeader "Subject" s
     unless (null cc) $ putHeader "Cc" cc
     putHeader "X-Mail-Originator" "Darcs Version Control System"
     hPutDocLn h body
  where putHeader field value
            = B.hPut h (B.append (formatHeader field value) newline)
        newline = B.singleton 10

checkDefaultSendmail :: IO ()
#ifndef WIN32
checkDefaultSendmail = void sendmailPath
#else
-- FIXME find a way to detect if sending via MAPI would work
checkDefaultSendmail = return ()
{-
  TODO do we want a warning message like this one here?
  hPutStr stderr
    "Warning: Using MAPI for sending mail. This may hang indefinitely " ++
    "if not properly configured.\n"
-}
#endif

-- | Send an email, optionally containing a patch bundle
--   (more precisely, its description and the bundle itself)
sendEmailDoc
  :: String           -- ^ from
  -> String           -- ^ to
  -> String           -- ^ subject
  -> String           -- ^ cc
  -> Maybe String     -- ^ send command
  -> Maybe (Doc, Doc) -- ^ (content,bundle)
  -> Doc              -- ^ body
  -> IO ()
sendEmailDoc _ "" _ "" _ _ _ = return ()
sendEmailDoc f "" s cc scmd mbundle body =
  sendEmailDoc f cc s "" scmd mbundle body
#ifdef WIN32
sendEmailDoc f t s cc Nothing _mbundle body = 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 <- canonicalizePath fn
               withCString cfn $ \pcfn ->
                c_send_email fp tp ccp sp nullPtr pcfn
  when (r /= 0) $ do
    fail $ "Failed to send mail via MAPI to: " ++ recipients t cc
#endif
sendEmailDoc f t s cc scmd mbundle body =
  withOpenTemp $ \(h,fn) -> do
    generateEmail h f t s cc body
    hClose h
    withOpenTemp $ \(hat,at) -> do
      ftable' <- case mbundle of
                 Just (content,bundle) -> do
                     hPutDocLn hat bundle
                     return [ ('b', renderString content) , ('a', at) ]
                 Nothing ->
                     return [ ('b', renderString body) ]
      hClose hat
      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: " ++ recipients t cc)
  where addressOnly a =
          case dropWhile (/= '<') a of
          ('<':a2) -> takeWhile (/= '>') a2
          _        -> a

recipients :: String -> String -> String
recipients to "" = to
recipients to cc = to ++ " and cc'ed " ++ cc

execSendmail :: [(Char,String)] -> Maybe String -> String -> IO ExitCode
#ifdef WIN32
execSendmail _ Nothing _ = error "impossible"
#else
execSendmail _ Nothing fn = do
  scmd <- sendmailPath
  exec scmd ["-i", "-t"] (File fn, Null, AsIs)
#endif
execSendmail ftable (Just scmd) fn =
  case parseCmd (addUrlencoded ftable) scmd of
    Right (arg0:opts, wantstdin) ->
      let stdin = if wantstdin then File fn else Null
      in do
        debugMessage $ unwords $ "execSendmail:" : map show (arg0 : opts)
        exec arg0 opts (stdin, Null, AsIs)
    Right ([], _) ->
      fail $ "Invalid sendmail-command "++show scmd
    Left e ->
      fail $ "Invalid sendmail-command "++show scmd++"\n"++show e

#ifdef WIN32
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
#endif

execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString
execPSPipe command args input =
  withoutProgress $ do
    (hi, ho, he, pid) <- runInteractiveProcess command args Nothing Nothing
    _ <- forkIO $ B.hPut hi input >> hClose hi
    done <- newEmptyMVar
    _ <- forkIO $ (B.hGetContents he >>= B.hPut stderr) `finally` putMVar done ()
    output <- B.hGetContents ho
    rval <- waitForProcess pid
    takeMVar done
    case rval of
      ExitFailure ec ->
        fail $
        "External program '" ++ command ++ "' failed with exit code " ++ show ec
      ExitSuccess -> return output

execDocPipe :: String -> [String] -> Doc -> IO Doc
execDocPipe command args input =
  packedString <$> execPSPipe command args (renderPS input)

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

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

signSSL :: String -> Doc -> IO Doc
signSSL idfile t =
    withTemp $ \cert -> do
    opensslPS ["req", "-new", "-key", idfile,
               "-outform", "PEM", "-days", "365"]
                (BC.pack "\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"]
                >>= B.writeFile cert
    opensslDoc ["smime", "-sign", "-signer", cert,
                "-inkey", idfile, "-noattr", "-text"] t
    where opensslDoc = execDocPipe "openssl"
          opensslPS = execPSPipe "openssl"


verifyPS :: Verify -> B.ByteString -> IO (Maybe B.ByteString)
verifyPS NoVerify ps = return $ Just ps
verifyPS (VerifyKeyring pks) ps = verifyGPG pks ps
verifyPS (VerifySSL auks) ps = verifySSL auks ps

verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)
verifyGPG goodkeys s =
    withOpenTemp $ \(th,tn) -> do
      B.hPut th s
      hClose th
      rval <- exec "gpg"  ["--batch","--no-default-keyring",
                           "--keyring",fix_path $ toFilePath 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 /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"
                    &&
                    x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r"
                in unlinesPS $ map fix_line $ tailErr $ dropWhile not_begin_signature $ linesPS s
            fix_line x | B.length x < 3 = x
                       | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x
                       | otherwise = x
#ifdef WIN32
            fix_sep c | c=='/' = '\\'   | otherwise = c
            fix_path p = map fix_sep p
#else
            fix_path p = p
#endif

verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)
verifySSL goodkeys s = do
    certdata <- opensslPS ["smime", "-pk7out"] s
                >>= opensslPS ["pkcs7", "-print_certs"]
    cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata
    let key_used = B.concat $ tailErr $
                   takeWhile (/= BC.pack"-----END PUBLIC KEY-----")
                           $ linesPS cruddy_pk
        in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys)
              if key_used `notElem` allowed_keys
                then return Nothing -- Not an allowed key!
                else withTemp $ \cert ->
                     withTemp $ \on ->
                     withOpenTemp $ \(th,tn) -> do
                     B.hPut th s
                     hClose th
                     B.writeFile cert certdata
                     rval <- exec "openssl" ["smime", "-verify", "-CAfile",
                                             cert, "-certfile", cert]
                                             (File tn, File on, Null)
                     case rval of
                       ExitSuccess -> Just `fmap` B.readFile on
                       _ -> return Nothing
    where opensslPS = execPSPipe "openssl"

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

viewDocWith :: Printers -> Doc -> IO ()
viewDocWith pr msg = do
  isTerminal <- hIsTerminalDevice stdout
  void $ if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg)
     then do mbViewerPlusArgs <- getViewer
             case mbViewerPlusArgs of
                  Just viewerPlusArgs -> do
                    case words viewerPlusArgs of
                      [] -> pipeDocToPager "" [] pr msg
                      (viewer : args) -> pipeDocToPager viewer args pr msg
                  Nothing -> return $ ExitFailure 127 -- No such command
               `ortryrunning` pipeDocToPager  "less" ["-R"] pr msg
               `ortryrunning` pipeDocToPager  "more" [] pr msg
#ifdef WIN32
               `ortryrunning` pipeDocToPager  "more.com" [] pr msg
#endif
               `ortryrunning` pipeDocToPager "" [] pr msg
     else pipeDocToPager "" [] pr msg
              where lengthGreaterThan n _ | n <= 0 = True
                    lengthGreaterThan _ [] = False
                    lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs

getViewer :: IO (Maybe String)
getViewer = Just `fmap` (getEnv "DARCS_PAGER" `catchall` getEnv "PAGER")
            `catchall`
            return Nothing

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

pipeDocToPager "" _ pr inp = do
  hPutDocLnWith pr stdout inp
  return ExitSuccess

pipeDocToPager c args pr inp = pipeDocInternal (PipeToOther pr) c args inp

-- | Given two shell commands as arguments, execute the former.  The
-- latter is then executed if the former failed because the executable
-- wasn't found (code 127), wasn't executable (code 126) or some other
-- exception occurred (save from a resource vanished/broken pipe error).
-- Other failures (such as the user holding ^C)
-- do not cause the second command to be tried.
ortryrunning :: IO ExitCode
             -> IO ExitCode
             -> IO ExitCode
a `ortryrunning` b = do
  ret <- try a
  case ret of
    (Right (ExitFailure 126)) -> b -- command not executable
    (Right (ExitFailure 127)) -> b -- command not found
#ifdef WIN32
    (Right (ExitFailure 9009)) -> b -- command not found by cmd.exe on Windows
#endif
    (Right x) -> return x          -- legitimate success/failure
    (Left (e :: IOException)) -> case ioeGetErrorType e of
                                   -- case where pager is quit before darcs has fed it entirely:
                                   ResourceVanished -> return ExitSuccess
                                   -- other exception:
                                   _                -> b


editText :: String -> B.ByteString -> IO B.ByteString
editText desc txt = withNamedTemp desc $ \f -> do
  B.writeFile f txt
  _ <- runEditor f
  B.readFile f

-- | @editFile f@ lets the user edit a file which could but does not need to
-- already exist. This function returns the exit code from the text editor and a
-- flag indicating if the user made any changes.
editFile :: FilePathLike p
         => p
         -> IO (ExitCode, Bool)
editFile ff = do
    old_content <- file_content
    ec <- runEditor f
    new_content <- file_content
    return (ec, new_content /= old_content)
  where
    f = toFilePath ff
    file_content = do
      exists <- doesFileExist f
      if exists then do content <- B.readFile f
                        return $ Just content
                else return Nothing


runEditor :: FilePath
          -> IO ExitCode
runEditor f = do
    ed <- getEditor
    let mf = Just f
    execInteractive ed mf
         `ortryrunning` execInteractive "vi" mf
         `ortryrunning` execInteractive "emacs" mf
         `ortryrunning` execInteractive "emacs -nw" mf
#ifdef WIN32
         `ortryrunning` execInteractive "edit" mf
#endif


getEditor :: IO String
getEditor = getEnv "DARCS_EDITOR" `catchall`
             getEnv "VISUAL" `catchall`
             getEnv "EDITOR" `catchall` return "nano"

-- | On Posix systems, GHC by default uses the user's locale encoding to
-- determine how to decode/encode the raw byte sequences in the Posix API
-- to/from 'String'. It also uses certain special variants of this
-- encoding to determine how to handle encoding errors.
--
-- See "GHC.IO.Encoding" for details.
--
-- In particular, the default variant used for command line arguments and
-- environment variables is //ROUNDTRIP, which means that /any/ byte sequence
-- can be decoded and re-encoded w/o failure or loss of information. To
-- enable this, GHC uses code points that are outside the range of the regular
-- unicode set. This is what you get with 'getFileSystemEncoding'.
--
-- We need to preserve the raw bytes e.g. for file names passed in by the
-- user and also when reading file names from disk; also when re-generating
-- files from patches, and when we display them to the user.
--
-- So we want to use this encoding variant for *all* IO and for (almost) all
-- conversions between raw bytes and 'String's. The encoding used for IO from
-- and to handles is controlled by 'setLocaleEncoding' which we use here to
-- make it equal to the //ROUNDTRIP variant.
--
-- @setDarcsEncoding@ should be called before the
-- first time any darcs operation is run, and again if anything else might have
-- set those encodings to different values.
--
-- Note that it isn't thread-safe and has a global effect on your program.
--
-- On Windows, this function does (and should) not do anything.
setDarcsEncodings :: IO ()
#ifdef WIN32
setDarcsEncodings = return ()
#else
setDarcsEncodings = do
    e <- getFileSystemEncoding
    -- TODO check if we have to set this, too.
    setForeignEncoding e
    setLocaleEncoding e
#endif