{-# LANGUAGE CPP, ForeignFunctionInterface #-}

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

import Darcs.Prelude

import Data.Maybe ( isJust, isNothing, maybeToList )
import Control.Monad ( unless, when, filterM, liftM2, void )
import Control.Concurrent.MVar ( MVar )
import System.Exit ( ExitCode(..) )
import System.Environment
    ( getEnv
    , getExecutablePath
    )
import System.IO ( hPutStr, hPutStrLn, hClose,
                   hIsTerminalDevice, stdout, stderr, Handle )
import System.Directory ( doesFileExist,
                          findExecutable )
import System.FilePath.Posix ( (</>) )
import System.Process ( createProcess, proc, CreateProcess(..), runInteractiveProcess, waitForProcess, StdStream(..) )
import System.Process.Internals ( ProcessHandle )

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

import Foreign.C.String ( CString, peekCString )

import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )
import Control.Exception
    ( try, finally, catch, IOException )
import System.IO.Error ( ioeGetErrorType )
import GHC.IO.Exception ( IOErrorType(ResourceVanished) )
import Data.Char ( toLower )
import Text.Regex
#if defined (HAVE_MAPI)
import Foreign.C ( withCString )
#endif
#ifdef HAVE_MAPI
import Foreign.Ptr ( nullPtr )
import Darcs.Util.Lock ( canonFilename, writeDocBinFile )
#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 (ByteString, empty, null, readFile
            ,hGetContents, writeFile, hPut, length
            ,take, concat, drop, isPrefixOf, singleton, append)
import qualified Data.ByteString.Char8 as BC (unpack, pack)

import Darcs.Util.Lock
    ( withTemp
    , withNamedTemp
    , withOpenTemp
    )
import Darcs.Util.Ssh ( getSSH, SSHCmd(..) )
import Darcs.Util.CommandLine ( parseCmd, addUrlencoded )
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, hPutDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS,
                 simplePrinters,
                 hPutDocCompr,
                 text, empty, packedString, vcat, renderString )
import qualified Darcs.Util.Ratified as Ratified
import Darcs.UI.Email ( formatHeader )

sendmailPath :: IO String
sendmailPath :: IO String
sendmailPath = do
  [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
"/usr/sbin", String
"/sbin", String
"/usr/lib" ]
                [ 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 (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
l) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot find the \"sendmail\" program."
  String -> IO String
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. [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

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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
l) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot find the \"diff\" program."
  String -> IO String
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. [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 :: StdStream
std_in = StdStream
CreatePipe
                                                      , delegate_ctlc :: Bool
delegate_ctlc = Bool
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 (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 -> String -> String -> IO ()
sendEmail :: String -> String -> String -> String -> String -> String -> IO ()
sendEmail String
f String
t String
s String
cc String
scmd String
body =
  String
-> String
-> String
-> String
-> String
-> Maybe (Doc, Doc)
-> Doc
-> IO ()
sendEmailDoc String
f String
t String
s String
cc 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 (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

haveSendmail :: IO Bool
haveSendmail :: IO Bool
haveSendmail = (IO String
sendmailPath IO String -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) IO Bool -> (IOException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

-- | 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
  -> String           -- ^ send command
  -> Maybe (Doc, Doc) -- ^ (content,bundle)
  -> Doc              -- ^ body
  -> IO ()
sendEmailDoc :: String
-> String
-> String
-> String
-> String
-> Maybe (Doc, Doc)
-> Doc
-> IO ()
sendEmailDoc String
_ String
"" String
_ String
"" String
_ Maybe (Doc, Doc)
_ Doc
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendEmailDoc String
f String
"" String
s String
cc String
scmd Maybe (Doc, Doc)
mbundle Doc
body =
  String
-> String
-> String
-> String
-> String
-> Maybe (Doc, Doc)
-> Doc
-> IO ()
sendEmailDoc String
f String
cc String
s String
"" String
scmd Maybe (Doc, Doc)
mbundle Doc
body
sendEmailDoc String
f String
t String
s String
cc String
scmd Maybe (Doc, Doc)
mbundle Doc
body = do
  Bool
use_sendmail <- IO Bool
haveSendmail
  if Bool
use_sendmail Bool -> Bool -> Bool
|| String
scmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" then
    ((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 (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 (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)] -> String -> String -> IO ExitCode
execSendmail [(Char, String)]
ftable 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 (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"failed to send mail to: "
                                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cc_list String
cc
                                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nPerhaps sendmail is not configured.")
#ifdef HAVE_MAPI
   else 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
   else String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no mail facility (sendmail or mapi) located at configure time!"
#endif
  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

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

resendEmail :: String -> String -> B.ByteString -> IO ()
resendEmail :: String -> String -> ByteString -> IO ()
resendEmail String
"" String
_ ByteString
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
resendEmail String
t String
scmd ByteString
body = do
  Bool
use_sendmail <- IO Bool
haveSendmail
  if Bool
use_sendmail Bool -> Bool -> Bool
|| String
scmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
   then
    ((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 -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"To: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t
     Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> String
find_from (ByteString -> [ByteString]
linesPS ByteString
body)
     Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> String
find_subject (ByteString -> [ByteString]
linesPS ByteString
body)
     Handle -> Doc -> IO ()
hPutDocLn Handle
h (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Doc
fixit ([ByteString] -> Doc) -> [ByteString] -> Doc
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
linesPS ByteString
body
     Handle -> IO ()
hClose Handle
h
     let ftable :: [(Char, String)]
ftable = [(Char
't',String
t)]
     ExitCode
r <-  [(Char, String)] -> String -> String -> IO ExitCode
execSendmail [(Char, String)]
ftable 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 (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"failed to send mail to: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t)
   else
#ifdef HAVE_MAPI
    fail "Don't know how to resend email with MAPI"
#else
    String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"
#endif
  where br :: ByteString
br            = String -> ByteString
BC.pack String
"\r"
        darcsurl :: ByteString
darcsurl      = String -> ByteString
BC.pack String
"DarcsURL:"
        content :: ByteString
content       = String -> ByteString
BC.pack String
"Content-"
        from_start :: ByteString
from_start    = String -> ByteString
BC.pack String
"From:"
        subject_start :: ByteString
subject_start = String -> ByteString
BC.pack String
"Subject:"
        fixit :: [ByteString] -> Doc
fixit (ByteString
l:[ByteString]
ls)
         | ByteString -> Bool
B.null ByteString
l = ByteString -> Doc
packedString ByteString
B.empty Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((ByteString -> Doc) -> [ByteString] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Doc
packedString [ByteString]
ls)
         | ByteString
l ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
br = ByteString -> Doc
packedString ByteString
B.empty Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((ByteString -> Doc) -> [ByteString] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Doc
packedString [ByteString]
ls)
         | Int -> ByteString -> ByteString
B.take Int
9 ByteString
l ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
darcsurl Bool -> Bool -> Bool
|| Int -> ByteString -> ByteString
B.take Int
8 ByteString
l ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
content
            = ByteString -> Doc
packedString ByteString
l Doc -> Doc -> Doc
$$ [ByteString] -> Doc
fixit [ByteString]
ls
         | Bool
otherwise = [ByteString] -> Doc
fixit [ByteString]
ls
        fixit [] = Doc
empty
        find_from :: [ByteString] -> String
find_from (ByteString
l:[ByteString]
ls) | Int -> ByteString -> ByteString
B.take Int
5 ByteString
l ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
from_start = ByteString -> String
BC.unpack ByteString
l
                         | Bool
otherwise = [ByteString] -> String
find_from [ByteString]
ls
        find_from [] = String
"From: unknown"
        find_subject :: [ByteString] -> String
find_subject (ByteString
l:[ByteString]
ls) | Int -> ByteString -> ByteString
B.take Int
8 ByteString
l ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
subject_start = ByteString -> String
BC.unpack ByteString
l
                            | Bool
otherwise = [ByteString] -> String
find_subject [ByteString]
ls
        find_subject [] = String
"Subject: (no subject)"

execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode
execSendmail :: [(Char, String)] -> String -> String -> IO ExitCode
execSendmail [(Char, String)]
ftable String
scmd String
fn =
  if String
scmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then do
     String
cmd <- IO String
sendmailPath
     String -> [String] -> Redirects -> IO ExitCode
exec String
cmd [String
"-i", String
"-t"] (String -> Redirect
File String
fn, Redirect
Null, Redirect
AsIs)
  else 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) ->
           do let stdin :: Redirect
stdin = if Bool
wantstdin then String -> Redirect
File String
fn else Redirect
Null
              String -> [String] -> Redirects -> IO ExitCode
exec String
arg0 [String]
opts (Redirect
stdin, Redirect
Null, Redirect
AsIs)
         Left ParseError
e -> String -> IO ExitCode
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ExitCode) -> String -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ String
"failed to send mail, invalid sendmail-command: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ParseError -> String
forall a. Show a => a -> String
show ParseError
e
         Either ParseError ([String], Bool)
_ -> String -> IO ExitCode
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to send mail, invalid sendmail-command"

#ifdef HAVE_MAPI
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
c [String]
args ByteString
ps = (Doc -> ByteString) -> IO Doc -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> ByteString
renderPS
                     (IO Doc -> IO ByteString) -> IO Doc -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Doc -> IO Doc
execDocPipe String
c [String]
args
                     (Doc -> IO Doc) -> Doc -> IO Doc
forall a b. (a -> b) -> a -> b
$ ByteString -> Doc
packedString ByteString
ps

execAndGetOutput :: FilePath -> [String] -> Doc
                 -> IO (ProcessHandle, MVar (), B.ByteString)
execAndGetOutput :: String
-> [String] -> Doc -> IO (ProcessHandle, MVar (), ByteString)
execAndGetOutput String
c [String]
args Doc
instr = do
       (Handle
i,Handle
o,Handle
e,ProcessHandle
pid) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
c [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 -> Doc -> IO ()
hPutDoc Handle
i Doc
instr IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
i
       MVar ()
mvare <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
       ThreadId
_ <- IO () -> IO ThreadId
forkIO ((Handle -> IO String
Ratified.hGetContents Handle
e IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= -- ratify: immediately consumed
                Handle -> String -> IO ()
hPutStr 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 ()
mvare ())
       ByteString
out <- Handle -> IO ByteString
B.hGetContents Handle
o
       (ProcessHandle, MVar (), ByteString)
-> IO (ProcessHandle, MVar (), ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle
pid, MVar ()
mvare, ByteString
out)

execDocPipe :: String -> [String] -> Doc -> IO Doc
execDocPipe :: String -> [String] -> Doc -> IO Doc
execDocPipe String
c [String]
args Doc
instr = IO Doc -> IO Doc
forall a. IO a -> IO a
withoutProgress (IO Doc -> IO Doc) -> IO Doc -> IO Doc
forall a b. (a -> b) -> a -> b
$ do
       (ProcessHandle
pid, MVar ()
mvare, ByteString
out) <- String
-> [String] -> Doc -> IO (ProcessHandle, MVar (), ByteString)
execAndGetOutput String
c [String]
args Doc
instr
       ExitCode
rval <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
       MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvare
       case ExitCode
rval of
         ExitFailure Int
ec ->String -> IO Doc
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Doc) -> String -> IO Doc
forall a b. (a -> b) -> a -> b
$ String
"External program '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cString -> 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 -> Doc -> IO Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> IO Doc) -> Doc -> IO Doc
forall a b. (a -> b) -> a -> b
$ ByteString -> Doc
packedString ByteString
out

signString :: Sign -> Doc -> IO Doc
signString :: Sign -> Doc -> IO Doc
signString Sign
NoSign Doc
d = Doc -> IO Doc
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 (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 (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 (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 (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 (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 (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. [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
#if defined(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 (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. [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 (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 (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 (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 (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
                    let (String
viewer : [String]
args) = String -> [String]
words String
viewerPlusArgs
                    String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager String
viewer [String]
args Printers
pr Doc
msg
                  Maybe String
Nothing -> ExitCode -> IO ExitCode
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
               -- TEMPORARY passing the -K option should be removed as soon as
               -- we can use the delegate_ctrl_c feature in process
               IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager  String
"less" [String
"-RK"] 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 (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 (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 (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 (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 (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 :: 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 (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 (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 (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 (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

-- The following functions are copied from the encoding package (BSD3
-- licence, by Henning Günther).

-- | @getSystemEncoding@ fetches the current encoding from locale
foreign import ccall "system_encoding.h get_system_encoding"
     get_system_encoding :: IO CString


getSystemEncoding :: IO String
getSystemEncoding :: IO String
getSystemEncoding = do
    CString
enc <- IO CString
get_system_encoding
    CString -> IO String
peekCString CString
enc


-- | @isUTF8@ checks if an encoding is UTF-8 (or ascii, since it is a
-- subset of UTF-8).
isUTF8Locale :: String -> Bool
isUTF8Locale :: String -> Bool
isUTF8Locale String
codeName = case String -> String
normalizeEncoding String
codeName of
    -- ASCII
    String
"ascii"              -> Bool
True
    String
"646"                -> Bool
True
    String
"ansi_x3_4_1968"     -> Bool
True
    String
"ansi_x3.4_1986"     -> Bool
True
    String
"cp367"              -> Bool
True
    String
"csascii"            -> Bool
True
    String
"ibm367"             -> Bool
True
    String
"iso646_us"          -> Bool
True
    String
"iso_646.irv_1991"   -> Bool
True
    String
"iso_ir_6"           -> Bool
True
    String
"us"                 -> Bool
True
    String
"us_ascii"           -> Bool
True
    -- UTF-8
    String
"utf_8"              -> Bool
True
    String
"u8"                 -> Bool
True
    String
"utf"                -> Bool
True
    String
"utf8"               -> Bool
True
    String
"utf8_ucs2"          -> Bool
True
    String
"utf8_ucs4"          -> Bool
True
    -- Everything else
    String
_                    -> Bool
False
  where
    normalizeEncoding :: String -> String
normalizeEncoding String
s = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Regex -> String -> String -> String
subRegex Regex
sep String
s String
"_"
    sep :: Regex
sep = String -> Regex
mkRegex String
"[^0-9A-Za-z]+"