{-# 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 )
#ifndef WIN32
import Data.Maybe ( isNothing, maybeToList )
#endif
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 :: IO String
sendmailPath = do
  let searchPath :: [String]
searchPath = [ String
"/usr/sbin", String
"/sbin", String
"/usr/lib" ]
  [String]
l <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> String -> String) -> [String] -> [String] -> [String]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 String -> String -> String
(</>)
                [String]
searchPath
                [ String
"sendmail" ]
  Maybe String
ex <- String -> IO (Maybe String)
findExecutable String
"sendmail"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
ex Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
l) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot find the 'sendmail' program in " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      [String] -> String
orClauses (String
"your PATH" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
searchPath) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
ex [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
l
#endif

diffProgram :: IO String
diffProgram :: IO String
diffProgram = do
  [String]
l <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (IO (Maybe String) -> IO Bool)
-> (String -> IO (Maybe String)) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
findExecutable) [ String
"gdiff", String
"gnudiff", String
"diff" ]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
l) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot find the \"diff\" program."
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
l

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

pipeDoc :: String -> [String] -> Doc -> IO ExitCode
pipeDoc :: String -> [String] -> Doc -> IO ExitCode
pipeDoc = WhereToPipe -> String -> [String] -> Doc -> IO ExitCode
pipeDocInternal (Printers -> WhereToPipe
PipeToOther Printers
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 -> String -> [String] -> Doc -> IO ExitCode
pipeDocInternal WhereToPipe
whereToPipe String
c [String]
args Doc
inp = IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
withoutNonBlock (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
withoutProgress (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$
    do String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Exec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. Show a => a -> String
show (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args))
       (Just Handle
i,Maybe Handle
_,Maybe Handle
_,ProcessHandle
pid) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
proc String
c [String]
args){ std_in = CreatePipe
                                                      , delegate_ctlc = True}
       String -> IO ()
debugMessage String
"Start transferring data"
       case WhereToPipe
whereToPipe of
          PipeToSsh Compression
GzipCompression -> Handle -> Doc -> IO ()
hPutDocCompr Handle
i Doc
inp
          PipeToSsh Compression
NoCompression   -> Handle -> Doc -> IO ()
hPutDoc Handle
i Doc
inp
          PipeToOther Printers
printers      -> Printers -> Handle -> Doc -> IO ()
hPutDocWith Printers
printers Handle
i Doc
inp
       Handle -> IO ()
hClose Handle
i
       ExitCode
rval <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
       String -> IO ()
debugMessage String
"Finished transferring data"
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
rval ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ExitCode
ExitFailure Int
127) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Command not found:\n   "String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args)
       ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
rval

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

sendEmail :: String -> String -> String -> String -> Maybe String -> String -> IO ()
sendEmail :: String
-> String -> String -> String -> Maybe String -> String -> IO ()
sendEmail String
f String
t String
s String
cc Maybe String
scmd String
body =
  String
-> String
-> String
-> String
-> Maybe String
-> Maybe (Doc, Doc)
-> Doc
-> IO ()
sendEmailDoc String
f String
t String
s String
cc Maybe String
scmd Maybe (Doc, Doc)
forall a. Maybe a
Nothing (String -> Doc
text String
body)


generateEmail
    :: Handle  -- ^ handle to write email to
    -> String  -- ^ From
    -> String  -- ^ To
    -> String  -- ^ Subject
    -> String  -- ^ CC
    -> Doc     -- ^ body
    -> IO ()
generateEmail :: Handle -> String -> String -> String -> String -> Doc -> IO ()
generateEmail Handle
h String
f String
t String
s String
cc Doc
body = do
     String -> String -> IO ()
putHeader String
"To" String
t
     String -> String -> IO ()
putHeader String
"From" String
f
     String -> String -> IO ()
putHeader String
"Subject" String
s
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cc) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
putHeader String
"Cc" String
cc
     String -> String -> IO ()
putHeader String
"X-Mail-Originator" String
"Darcs Version Control System"
     Handle -> Doc -> IO ()
hPutDocLn Handle
h Doc
body
  where putHeader :: String -> String -> IO ()
putHeader String
field String
value
            = Handle -> ByteString -> IO ()
B.hPut Handle
h (ByteString -> ByteString -> ByteString
B.append (String -> String -> ByteString
formatHeader String
field String
value) ByteString
newline)
        newline :: ByteString
newline = Word8 -> ByteString
B.singleton Word8
10

checkDefaultSendmail :: IO ()
#ifndef WIN32
checkDefaultSendmail :: IO ()
checkDefaultSendmail = IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO String
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 :: String
-> String
-> String
-> String
-> Maybe String
-> Maybe (Doc, Doc)
-> Doc
-> IO ()
sendEmailDoc String
_ String
"" String
_ String
"" Maybe String
_ Maybe (Doc, Doc)
_ Doc
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendEmailDoc String
f String
"" String
s String
cc Maybe String
scmd Maybe (Doc, Doc)
mbundle Doc
body =
  String
-> String
-> String
-> String
-> Maybe String
-> Maybe (Doc, Doc)
-> Doc
-> IO ()
sendEmailDoc String
f String
cc String
s String
"" Maybe String
scmd Maybe (Doc, Doc)
mbundle Doc
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 String
f String
t String
s String
cc Maybe String
scmd Maybe (Doc, Doc)
mbundle Doc
body =
  ((Handle, String) -> IO ()) -> IO ()
forall a. ((Handle, String) -> IO a) -> IO a
withOpenTemp (((Handle, String) -> IO ()) -> IO ())
-> ((Handle, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Handle
h,String
fn) -> do
    Handle -> String -> String -> String -> String -> Doc -> IO ()
generateEmail Handle
h String
f String
t String
s String
cc Doc
body
    Handle -> IO ()
hClose Handle
h
    ((Handle, String) -> IO ()) -> IO ()
forall a. ((Handle, String) -> IO a) -> IO a
withOpenTemp (((Handle, String) -> IO ()) -> IO ())
-> ((Handle, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Handle
hat,String
at) -> do
      [(Char, String)]
ftable' <- case Maybe (Doc, Doc)
mbundle of
                 Just (Doc
content,Doc
bundle) -> do
                     Handle -> Doc -> IO ()
hPutDocLn Handle
hat Doc
bundle
                     [(Char, String)] -> IO [(Char, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Char
'b', Doc -> String
renderString Doc
content) , (Char
'a', String
at) ]
                 Maybe (Doc, Doc)
Nothing ->
                     [(Char, String)] -> IO [(Char, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Char
'b', Doc -> String
renderString Doc
body) ]
      Handle -> IO ()
hClose Handle
hat
      let ftable :: [(Char, String)]
ftable = [ (Char
't',String -> String
addressOnly String
t),(Char
'c',String
cc),(Char
'f',String
f),(Char
's',String
s) ] [(Char, String)] -> [(Char, String)] -> [(Char, String)]
forall a. [a] -> [a] -> [a]
++ [(Char, String)]
ftable'
      ExitCode
r <- [(Char, String)] -> Maybe String -> String -> IO ExitCode
execSendmail [(Char, String)]
ftable Maybe String
scmd String
fn
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
r ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to send mail to: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
recipients String
t String
cc)
  where addressOnly :: String -> String
addressOnly String
a =
          case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'<') String
a of
          (Char
'<':String
a2) -> (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>') String
a2
          String
_        -> String
a

recipients :: String -> String -> String
recipients :: String -> String -> String
recipients String
to String
"" = String
to
recipients String
to String
cc = String
to String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and cc'ed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cc

execSendmail :: [(Char,String)] -> Maybe String -> String -> IO ExitCode
#ifdef WIN32
execSendmail _ Nothing _ = error "impossible"
#else
execSendmail :: [(Char, String)] -> Maybe String -> String -> IO ExitCode
execSendmail [(Char, String)]
_ Maybe String
Nothing String
fn = do
  String
scmd <- IO String
sendmailPath
  String -> [String] -> Redirects -> IO ExitCode
exec String
scmd [String
"-i", String
"-t"] (String -> Redirect
File String
fn, Redirect
Null, Redirect
AsIs)
#endif
execSendmail [(Char, String)]
ftable (Just String
scmd) String
fn =
  case [(Char, String)] -> String -> Either ParseError ([String], Bool)
parseCmd ([(Char, String)] -> [(Char, String)]
addUrlencoded [(Char, String)]
ftable) String
scmd of
    Right (String
arg0:[String]
opts, Bool
wantstdin) ->
      let stdin :: Redirect
stdin = if Bool
wantstdin then String -> Redirect
File String
fn else Redirect
Null
      in do
        String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"execSendmail:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. Show a => a -> String
show (String
arg0 String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
opts)
        String -> [String] -> Redirects -> IO ExitCode
exec String
arg0 [String]
opts (Redirect
stdin, Redirect
Null, Redirect
AsIs)
    Right ([], Bool
_) ->
      String -> IO ExitCode
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ExitCode) -> String -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ String
"Invalid sendmail-command "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
scmd
    Left ParseError
e ->
      String -> IO ExitCode
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ExitCode) -> String -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ String
"Invalid sendmail-command "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
scmdString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++ParseError -> String
forall a. Show a => a -> String
show ParseError
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 :: String -> [String] -> ByteString -> IO ByteString
execPSPipe String
command [String]
args ByteString
input =
  IO ByteString -> IO ByteString
forall a. IO a -> IO a
withoutProgress (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
    (Handle
hi, Handle
ho, Handle
he, ProcessHandle
pid) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
command [String]
args Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
B.hPut Handle
hi ByteString
input IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
hi
    MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (Handle -> IO ByteString
B.hGetContents Handle
he IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> ByteString -> IO ()
B.hPut Handle
stderr) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()
    ByteString
output <- Handle -> IO ByteString
B.hGetContents Handle
ho
    ExitCode
rval <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done
    case ExitCode
rval of
      ExitFailure Int
ec ->
        String -> IO ByteString
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$
        String
"External program '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
command String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' failed with exit code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ec
      ExitCode
ExitSuccess -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
output

execDocPipe :: String -> [String] -> Doc -> IO Doc
execDocPipe :: String -> [String] -> Doc -> IO Doc
execDocPipe String
command [String]
args Doc
input =
  ByteString -> Doc
packedString (ByteString -> Doc) -> IO ByteString -> IO Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> ByteString -> IO ByteString
execPSPipe String
command [String]
args (Doc -> ByteString
renderPS Doc
input)

signString :: Sign -> Doc -> IO Doc
signString :: Sign -> Doc -> IO Doc
signString Sign
NoSign Doc
d = Doc -> IO Doc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
d
signString Sign
Sign Doc
d = [String] -> Doc -> IO Doc
signPGP [] Doc
d
signString (SignAs String
keyid) Doc
d = [String] -> Doc -> IO Doc
signPGP [String
"--local-user", String
keyid] Doc
d
signString (SignSSL String
idf) Doc
d = String -> Doc -> IO Doc
signSSL String
idf Doc
d

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

signSSL :: String -> Doc -> IO Doc
signSSL :: String -> Doc -> IO Doc
signSSL String
idfile Doc
t =
    (String -> IO Doc) -> IO Doc
forall a. (String -> IO a) -> IO a
withTemp ((String -> IO Doc) -> IO Doc) -> (String -> IO Doc) -> IO Doc
forall a b. (a -> b) -> a -> b
$ \String
cert -> do
    [String] -> ByteString -> IO ByteString
opensslPS [String
"req", String
"-new", String
"-key", String
idfile,
               String
"-outform", String
"PEM", String
"-days", String
"365"]
                (String -> ByteString
BC.pack String
"\n\n\n\n\n\n\n\n\n\n\n")
                IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> ByteString -> IO ByteString
opensslPS [String
"x509", String
"-req", String
"-extensions",
                               String
"v3_ca", String
"-signkey", String
idfile,
                               String
"-outform", String
"PEM", String
"-days", String
"365"]
                IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> ByteString -> IO ByteString
opensslPS [String
"x509", String
"-outform", String
"PEM"]
                IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ByteString -> IO ()
B.writeFile String
cert
    [String] -> Doc -> IO Doc
opensslDoc [String
"smime", String
"-sign", String
"-signer", String
cert,
                String
"-inkey", String
idfile, String
"-noattr", String
"-text"] Doc
t
    where opensslDoc :: [String] -> Doc -> IO Doc
opensslDoc = String -> [String] -> Doc -> IO Doc
execDocPipe String
"openssl"
          opensslPS :: [String] -> ByteString -> IO ByteString
opensslPS = String -> [String] -> ByteString -> IO ByteString
execPSPipe String
"openssl"


verifyPS :: Verify -> B.ByteString -> IO (Maybe B.ByteString)
verifyPS :: Verify -> ByteString -> IO (Maybe ByteString)
verifyPS Verify
NoVerify ByteString
ps = Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
ps
verifyPS (VerifyKeyring AbsolutePath
pks) ByteString
ps = AbsolutePath -> ByteString -> IO (Maybe ByteString)
verifyGPG AbsolutePath
pks ByteString
ps
verifyPS (VerifySSL AbsolutePath
auks) ByteString
ps = AbsolutePath -> ByteString -> IO (Maybe ByteString)
verifySSL AbsolutePath
auks ByteString
ps

verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)
verifyGPG :: AbsolutePath -> ByteString -> IO (Maybe ByteString)
verifyGPG AbsolutePath
goodkeys ByteString
s =
    ((Handle, String) -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
forall a. ((Handle, String) -> IO a) -> IO a
withOpenTemp (((Handle, String) -> IO (Maybe ByteString))
 -> IO (Maybe ByteString))
-> ((Handle, String) -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \(Handle
th,String
tn) -> do
      Handle -> ByteString -> IO ()
B.hPut Handle
th ByteString
s
      Handle -> IO ()
hClose Handle
th
      ExitCode
rval <- String -> [String] -> Redirects -> IO ExitCode
exec String
"gpg"  [String
"--batch",String
"--no-default-keyring",
                           String
"--keyring",String -> String
forall {p}. p -> p
fix_path (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
goodkeys, String
"--verify"]
                           (String -> Redirect
File String
tn, Redirect
Null, Redirect
Null)
      case ExitCode
rval of
          ExitCode
ExitSuccess -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
gpg_fixed_s
          ExitCode
_ -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
      where gpg_fixed_s :: ByteString
gpg_fixed_s = let
                not_begin_signature :: ByteString -> Bool
not_begin_signature ByteString
x =
                    ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.pack String
"-----BEGIN PGP SIGNED MESSAGE-----"
                    Bool -> Bool -> Bool
&&
                    ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.pack String
"-----BEGIN PGP SIGNED MESSAGE-----\r"
                in [ByteString] -> ByteString
unlinesPS ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
fix_line ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. HasCallStack => [a] -> [a]
tail ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ByteString -> Bool
not_begin_signature ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
linesPS ByteString
s
            fix_line :: ByteString -> ByteString
fix_line ByteString
x | ByteString -> Int
B.length ByteString
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3 = ByteString
x
                       | String -> ByteString
BC.pack String
"- -" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
x = Int -> ByteString -> ByteString
B.drop Int
2 ByteString
x
                       | Bool
otherwise = ByteString
x
#ifdef WIN32
            fix_sep c | c=='/' = '\\'   | otherwise = c
            fix_path p = map fix_sep p
#else
            fix_path :: p -> p
fix_path p
p = p
p
#endif

verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)
verifySSL :: AbsolutePath -> ByteString -> IO (Maybe ByteString)
verifySSL AbsolutePath
goodkeys ByteString
s = do
    ByteString
certdata <- [String] -> ByteString -> IO ByteString
opensslPS [String
"smime", String
"-pk7out"] ByteString
s
                IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> ByteString -> IO ByteString
opensslPS [String
"pkcs7", String
"-print_certs"]
    ByteString
cruddy_pk <- [String] -> ByteString -> IO ByteString
opensslPS [String
"x509", String
"-pubkey"] ByteString
certdata
    let key_used :: ByteString
key_used = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. HasCallStack => [a] -> [a]
tail ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
                   (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.packString
"-----END PUBLIC KEY-----")
                           ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
linesPS ByteString
cruddy_pk
        in do [ByteString]
allowed_keys <- ByteString -> [ByteString]
linesPS (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO ByteString
B.readFile (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
goodkeys)
              if ByteString
key_used ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ByteString]
allowed_keys
                then Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing -- Not an allowed key!
                else (String -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a. (String -> IO a) -> IO a
withTemp ((String -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (String -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \String
cert ->
                     (String -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a. (String -> IO a) -> IO a
withTemp ((String -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (String -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \String
on ->
                     ((Handle, String) -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
forall a. ((Handle, String) -> IO a) -> IO a
withOpenTemp (((Handle, String) -> IO (Maybe ByteString))
 -> IO (Maybe ByteString))
-> ((Handle, String) -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \(Handle
th,String
tn) -> do
                     Handle -> ByteString -> IO ()
B.hPut Handle
th ByteString
s
                     Handle -> IO ()
hClose Handle
th
                     String -> ByteString -> IO ()
B.writeFile String
cert ByteString
certdata
                     ExitCode
rval <- String -> [String] -> Redirects -> IO ExitCode
exec String
"openssl" [String
"smime", String
"-verify", String
"-CAfile",
                                             String
cert, String
"-certfile", String
cert]
                                             (String -> Redirect
File String
tn, String -> Redirect
File String
on, Redirect
Null)
                     case ExitCode
rval of
                       ExitCode
ExitSuccess -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO ByteString
B.readFile String
on
                       ExitCode
_ -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
    where opensslPS :: [String] -> ByteString -> IO ByteString
opensslPS = String -> [String] -> ByteString -> IO ByteString
execPSPipe String
"openssl"

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

viewDocWith :: Printers -> Doc -> IO ()
viewDocWith :: Printers -> Doc -> IO ()
viewDocWith Printers
pr Doc
msg = do
  Bool
isTerminal <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
  IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
isTerminal Bool -> Bool -> Bool
&& Int -> [String] -> Bool
forall {t} {a}. (Ord t, Num t) => t -> [a] -> Bool
lengthGreaterThan (Int
20 :: Int) (String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString Doc
msg)
     then do Maybe String
mbViewerPlusArgs <- IO (Maybe String)
getViewer
             case Maybe String
mbViewerPlusArgs of
                  Just String
viewerPlusArgs -> do
                    case String -> [String]
words String
viewerPlusArgs of
                      [] -> String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager String
"" [] Printers
pr Doc
msg
                      (String
viewer : [String]
args) -> String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager String
viewer [String]
args Printers
pr Doc
msg
                  Maybe String
Nothing -> ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode) -> ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
127 -- No such command
               IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager  String
"less" [String
"-R"] Printers
pr Doc
msg
               IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager  String
"more" [] Printers
pr Doc
msg
#ifdef WIN32
               `ortryrunning` pipeDocToPager  "more.com" [] pr msg
#endif
               IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager String
"" [] Printers
pr Doc
msg
     else String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager String
"" [] Printers
pr Doc
msg
              where lengthGreaterThan :: t -> [a] -> Bool
lengthGreaterThan t
n [a]
_ | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = Bool
True
                    lengthGreaterThan t
_ [] = Bool
False
                    lengthGreaterThan t
n (a
_:[a]
xs) = t -> [a] -> Bool
lengthGreaterThan (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [a]
xs

getViewer :: IO (Maybe String)
getViewer :: IO (Maybe String)
getViewer = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (String -> IO String
getEnv String
"DARCS_PAGER" IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
`catchall` String -> IO String
getEnv String
"PAGER")
            IO (Maybe String) -> IO (Maybe String) -> IO (Maybe String)
forall a. IO a -> IO a -> IO a
`catchall`
            Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

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

pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager String
"" [String]
_ Printers
pr Doc
inp = do
  Printers -> Handle -> Doc -> IO ()
hPutDocLnWith Printers
pr Handle
stdout Doc
inp
  ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess

pipeDocToPager String
c [String]
args Printers
pr Doc
inp = WhereToPipe -> String -> [String] -> Doc -> IO ExitCode
pipeDocInternal (Printers -> WhereToPipe
PipeToOther Printers
pr) String
c [String]
args Doc
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
IO ExitCode
a ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` IO ExitCode
b = do
  Either IOException ExitCode
ret <- IO ExitCode -> IO (Either IOException ExitCode)
forall e a. Exception e => IO a -> IO (Either e a)
try IO ExitCode
a
  case Either IOException ExitCode
ret of
    (Right (ExitFailure Int
126)) -> IO ExitCode
b -- command not executable
    (Right (ExitFailure Int
127)) -> IO ExitCode
b -- command not found
#ifdef WIN32
    (Right (ExitFailure 9009)) -> b -- command not found by cmd.exe on Windows
#endif
    (Right ExitCode
x) -> ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
x          -- legitimate success/failure
    (Left (IOException
e :: IOException)) -> case IOException -> IOErrorType
ioeGetErrorType IOException
e of
                                   -- case where pager is quit before darcs has fed it entirely:
                                   IOErrorType
ResourceVanished -> ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
                                   -- other exception:
                                   IOErrorType
_                -> IO ExitCode
b


editText :: String -> B.ByteString -> IO B.ByteString
editText :: String -> ByteString -> IO ByteString
editText String
desc ByteString
txt = String -> (String -> IO ByteString) -> IO ByteString
forall a. String -> (String -> IO a) -> IO a
withNamedTemp String
desc ((String -> IO ByteString) -> IO ByteString)
-> (String -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \String
f -> do
  String -> ByteString -> IO ()
B.writeFile String
f ByteString
txt
  ExitCode
_ <- String -> IO ExitCode
runEditor String
f
  String -> IO ByteString
B.readFile String
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 :: forall p. FilePathLike p => p -> IO (ExitCode, Bool)
editFile p
ff = do
    Maybe ByteString
old_content <- IO (Maybe ByteString)
file_content
    ExitCode
ec <- String -> IO ExitCode
runEditor String
f
    Maybe ByteString
new_content <- IO (Maybe ByteString)
file_content
    (ExitCode, Bool) -> IO (ExitCode, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ec, Maybe ByteString
new_content Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ByteString
old_content)
  where
    f :: String
f = p -> String
forall a. FilePathLike a => a -> String
toFilePath p
ff
    file_content :: IO (Maybe ByteString)
file_content = do
      Bool
exists <- String -> IO Bool
doesFileExist String
f
      if Bool
exists then do ByteString
content <- String -> IO ByteString
B.readFile String
f
                        Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
content
                else Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing


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


getEditor :: IO String
getEditor :: IO String
getEditor = String -> IO String
getEnv String
"DARCS_EDITOR" IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
`catchall`
             String -> IO String
getEnv String
"VISUAL" IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
`catchall`
             String -> IO String
getEnv String
"EDITOR" IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
`catchall` String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"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 :: IO ()
setDarcsEncodings = do
    TextEncoding
e <- IO TextEncoding
getFileSystemEncoding
    -- TODO check if we have to set this, too.
    TextEncoding -> IO ()
setForeignEncoding TextEncoding
e
    TextEncoding -> IO ()
setLocaleEncoding TextEncoding
e
#endif