{-# LANGUAGE CPP, ForeignFunctionInterface #-}

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

import Prelude ()
import Darcs.Prelude
import Darcs.Util.Text ( showCommandLine )

import Data.Maybe ( isJust, isNothing, maybeToList )
import Control.Monad ( unless, when, filterM, liftM2, void )
import GHC.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 )

import GHC.IO.Encoding
    ( getFileSystemEncoding
    , setForeignEncoding
    , setLocaleEncoding )

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.Util.SignalHandler ( catchNonSignal )
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.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
(</>)
                [ "/usr/sbin", "/sbin", "/usr/lib" ]
                [ "sendmail" ]
  Maybe String
ex <- String -> IO (Maybe String)
findExecutable "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 "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) [ "gdiff", "gnudiff", "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 "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
whereToPipe c :: String
c args :: [String]
args inp :: 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
$ "Exec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
showCommandLine (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args)
       (Just i :: Handle
i,_,_,pid :: 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 "Start transferring data"
       case WhereToPipe
whereToPipe of
          PipeToSsh GzipCompression -> Handle -> Doc -> IO ()
hPutDocCompr Handle
i Doc
inp
          PipeToSsh NoCompression   -> Handle -> Doc -> IO ()
hPutDoc Handle
i Doc
inp
          PipeToOther printers :: 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 "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 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
$ "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 compress :: Compression
compress remoteAddr :: SshFilePath
remoteAddr args :: [String]
args input :: Doc
input = do
    (ssh :: String
ssh, ssh_args :: [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]
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 f :: String
f t :: String
t s :: String
s cc :: String
cc scmd :: String
scmd body :: 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 h :: Handle
h f :: String
f t :: String
t s :: String
s cc :: String
cc body :: Doc
body = do
     String -> String -> IO ()
putHeader "To" String
t
     String -> String -> IO ()
putHeader "From" String
f
     String -> String -> IO ()
putHeader "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 "Cc" String
cc
     String -> String -> IO ()
putHeader "X-Mail-Originator" "Darcs Version Control System"
     Handle -> Doc -> IO ()
hPutDocLn Handle
h Doc
body
  where putHeader :: String -> String -> IO ()
putHeader field :: String
field value :: 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 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 _ "" _ "" _ _ _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendEmailDoc f :: String
f "" s :: String
s cc :: String
cc scmd :: String
scmd mbundle :: Maybe (Doc, Doc)
mbundle body :: Doc
body =
  String
-> String
-> String
-> String
-> String
-> Maybe (Doc, Doc)
-> Doc
-> IO ()
sendEmailDoc String
f String
cc String
s "" String
scmd Maybe (Doc, Doc)
mbundle Doc
body
sendEmailDoc f :: String
f t :: String
t s :: String
s cc :: String
cc scmd :: String
scmd mbundle :: Maybe (Doc, Doc)
mbundle body :: 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
/= "" 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
$ \(h :: Handle
h,fn :: 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
$ \(hat :: Handle
hat,at :: String
at) -> do
        [(Char, String)]
ftable' <- case Maybe (Doc, Doc)
mbundle of
                   Just (content :: Doc
content,bundle :: 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 [ ('b', Doc -> String
renderString Doc
content) , ('a', String
at) ]
                   Nothing ->
                       [(Char, String)] -> IO [(Char, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ ('b', Doc -> String
renderString Doc
body) ]
        Handle -> IO ()
hClose Handle
hat
        let ftable :: [(Char, String)]
ftable = [ ('t',String -> String
addressOnly String
t),('c',String
cc),('f',String
f),('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 ("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]
++ "\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 "no mail facility (sendmail or mapi) located at configure time!"
#endif
  where addressOnly :: String -> String
addressOnly a :: String
a =
          case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '<') String
a of
          ('<':a2 :: String
a2) -> (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '>') String
a2
          _        -> String
a

        cc_list :: String -> String
cc_list [] = []
        cc_list c :: String
c = " 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 "" _ _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
resendEmail t :: String
t scmd :: String
scmd body :: 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
/= ""
   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
$ \(h :: Handle
h,fn :: String
fn) -> do
     Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "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 = [('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 ("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 "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"
#endif
  where br :: ByteString
br            = String -> ByteString
BC.pack "\r"
        darcsurl :: ByteString
darcsurl      = String -> ByteString
BC.pack "DarcsURL:"
        content :: ByteString
content       = String -> ByteString
BC.pack "Content-"
        from_start :: ByteString
from_start    = String -> ByteString
BC.pack "From:"
        subject_start :: ByteString
subject_start = String -> ByteString
BC.pack "Subject:"
        fixit :: [ByteString] -> Doc
fixit (l :: ByteString
l:ls :: [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 9 ByteString
l ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
darcsurl Bool -> Bool -> Bool
|| Int -> ByteString -> ByteString
B.take 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 (l :: ByteString
l:ls :: [ByteString]
ls) | Int -> ByteString -> ByteString
B.take 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 [] = "From: unknown"
        find_subject :: [ByteString] -> String
find_subject (l :: ByteString
l:ls :: [ByteString]
ls) | Int -> ByteString -> ByteString
B.take 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 [] = "Subject: (no subject)"

execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode
execSendmail :: [(Char, String)] -> String -> String -> IO ExitCode
execSendmail ftable :: [(Char, String)]
ftable scmd :: String
scmd fn :: String
fn =
  if String
scmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" then do
     String
cmd <- IO String
sendmailPath
     String -> [String] -> Redirects -> IO ExitCode
exec String
cmd ["-i", "-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 (arg0 :: String
arg0:opts :: [String]
opts, wantstdin :: 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 e :: 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
$ "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
         _ -> String -> IO ExitCode
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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 c :: String
c args :: [String]
args ps :: 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 c :: String
c args :: [String]
args instr :: Doc
instr = do
       (i :: Handle
i,o :: Handle
o,e :: Handle
e,pid :: 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 c :: String
c args :: [String]
args instr :: 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
       (pid :: ProcessHandle
pid, mvare :: MVar ()
mvare, out :: 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 ec :: 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
$ "External program '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cString -> String -> String
forall a. [a] -> [a] -> [a]
++
                          "' failed with exit code "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ec
         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

-- The following is needed for diff, which returns non-zero whenever
-- the files differ.
execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc
execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc
execPipeIgnoreError c :: String
c args :: [String]
args instr :: 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
       (pid :: ProcessHandle
pid, mvare :: MVar ()
mvare, out :: ByteString
out) <- String
-> [String] -> Doc -> IO (ProcessHandle, MVar (), ByteString)
execAndGetOutput String
c [String]
args Doc
instr
       ExitCode
_ <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
       MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvare
       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
$ if ByteString -> Bool
B.null ByteString
out then Doc
empty else ByteString -> Doc
packedString ByteString
out

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

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

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


verifyPS :: Verify -> B.ByteString -> IO (Maybe B.ByteString)
verifyPS :: Verify -> ByteString -> IO (Maybe ByteString)
verifyPS NoVerify ps :: 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 pks :: AbsolutePath
pks) ps :: ByteString
ps = AbsolutePath -> ByteString -> IO (Maybe ByteString)
verifyGPG AbsolutePath
pks ByteString
ps
verifyPS (VerifySSL auks :: AbsolutePath
auks) ps :: 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 goodkeys :: AbsolutePath
goodkeys s :: 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
$ \(th :: Handle
th,tn :: 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 "gpg"  ["--batch","--no-default-keyring",
                           "--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, "--verify"]
                           (String -> Redirect
File String
tn, Redirect
Null, Redirect
Null)
      case ExitCode
rval of
          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
          _ -> 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 x :: ByteString
x =
                    ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"
                    Bool -> Bool -> Bool
&&
                    ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.pack "-----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 x :: ByteString
x | ByteString -> Int
B.length ByteString
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 3 = ByteString
x
                       | String -> ByteString
BC.pack "- -" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
x = Int -> ByteString -> ByteString
B.drop 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
p
#endif

verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)
verifySSL :: AbsolutePath -> ByteString -> IO (Maybe ByteString)
verifySSL goodkeys :: AbsolutePath
goodkeys s :: ByteString
s = do
    ByteString
certdata <- [String] -> ByteString -> IO ByteString
opensslPS ["smime", "-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 ["pkcs7", "-print_certs"]
    ByteString
cruddy_pk <- [String] -> ByteString -> IO ByteString
opensslPS ["x509", "-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.pack"-----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
$ \cert :: 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
$ \on :: 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
$ \(th :: Handle
th,tn :: 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 "openssl" ["smime", "-verify", "-CAfile",
                                             String
cert, "-certfile", String
cert]
                                             (String -> Redirect
File String
tn, String -> Redirect
File String
on, Redirect
Null)
                     case ExitCode
rval of
                       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
                       _ -> 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 "openssl"

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

viewDocWith :: Printers -> Doc -> IO ()
viewDocWith :: Printers -> Doc -> IO ()
viewDocWith pr :: Printers
pr msg :: 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 (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 viewerPlusArgs :: String
viewerPlusArgs -> do
                    let (viewer :: String
viewer : args :: [String]
args) = String -> [String]
words String
viewerPlusArgs
                    String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager String
viewer [String]
args Printers
pr Doc
msg
                  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 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  "less" ["-RK"] Printers
pr Doc
msg
               IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager  "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 "" [] Printers
pr Doc
msg
     else String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager "" [] Printers
pr Doc
msg
              where lengthGreaterThan :: t -> [a] -> Bool
lengthGreaterThan n :: t
n _ | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = Bool
True
                    lengthGreaterThan _ [] = Bool
False
                    lengthGreaterThan n :: t
n (_:xs :: [a]
xs) = t -> [a] -> Bool
lengthGreaterThan (t
nt -> t -> t
forall a. Num a => a -> a -> a
-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 "DARCS_PAGER" IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
`catchall` String -> IO String
getEnv "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 "" _ pr :: Printers
pr inp :: 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 c :: String
c args :: [String]
args pr :: Printers
pr inp :: 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
a :: IO ExitCode
a ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` b :: 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 126)) -> IO ExitCode
b -- command not executable
    (Right (ExitFailure 127)) -> IO ExitCode
b -- command not found
#ifdef WIN32
    (Right (ExitFailure 9009)) -> b -- command not found by cmd.exe on Windows
#endif
    (Right x :: 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:
                                   ResourceVanished -> ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
                                   -- other exception:
                                   _                -> IO ExitCode
b


editText :: String -> B.ByteString -> IO B.ByteString
editText :: String -> ByteString -> IO ByteString
editText desc :: String
desc txt :: 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
$ \f :: 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 ff :: 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 f :: String
f = do
    String
ed <- IO String
getEditor
    String -> String -> IO ExitCode
execInteractive String
ed String
f
         IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` String -> String -> IO ExitCode
execInteractive "vi" String
f
         IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` String -> String -> IO ExitCode
execInteractive "emacs" String
f
         IO ExitCode -> IO ExitCode -> IO ExitCode
`ortryrunning` String -> String -> IO ExitCode
execInteractive "emacs -nw" String
f
#ifdef WIN32
         `ortryrunning` execInteractive "edit" f
#endif


getEditor :: IO String
getEditor :: IO String
getEditor = String -> IO String
getEnv "DARCS_EDITOR" IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
`catchall`
             String -> IO String
getEnv "VISUAL" IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
`catchall`
             String -> IO String
getEnv "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 "nano"

catchall :: IO a
         -> IO a
         -> IO a
a :: IO a
a catchall :: IO a -> IO a -> IO a
`catchall` b :: IO a
b = IO a
a IO a -> (SomeException -> IO a) -> IO a
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchNonSignal` (\_ -> IO a
b)


-- | 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 codeName :: String
codeName = case String -> String
normalizeEncoding String
codeName of
    -- ASCII
    "ascii"              -> Bool
True
    "646"                -> Bool
True
    "ansi_x3_4_1968"     -> Bool
True
    "ansi_x3.4_1986"     -> Bool
True
    "cp367"              -> Bool
True
    "csascii"            -> Bool
True
    "ibm367"             -> Bool
True
    "iso646_us"          -> Bool
True
    "iso_646.irv_1991"   -> Bool
True
    "iso_ir_6"           -> Bool
True
    "us"                 -> Bool
True
    "us_ascii"           -> Bool
True
    -- UTF-8
    "utf_8"              -> Bool
True
    "u8"                 -> Bool
True
    "utf"                -> Bool
True
    "utf8"               -> Bool
True
    "utf8_ucs2"          -> Bool
True
    "utf8_ucs4"          -> Bool
True
    -- Everything else
    _                    -> Bool
False
  where
    normalizeEncoding :: String -> String
normalizeEncoding s :: 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 "_"
    sep :: Regex
sep = String -> Regex
mkRegex "[^0-9A-Za-z]+"