{-# 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
, 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
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
| PipeToOther 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
-> String
-> String
-> String
-> String
-> Doc
-> 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)
sendEmailDoc
:: String
-> String
-> String
-> String
-> String
-> Maybe (Doc, Doc)
-> Doc
-> 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 ->
CString ->
CString ->
CString ->
CString ->
CString ->
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
>>=
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
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
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
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
"" _ 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
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
(Right (ExitFailure 127)) -> IO ExitCode
b
#ifdef WIN32
(Right (ExitFailure 9009)) -> b
#endif
(Right x :: ExitCode
x) -> ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
x
(Left (IOException
e :: IOException)) -> case IOException -> IOErrorType
ioeGetErrorType IOException
e of
ResourceVanished -> ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
_ -> 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 :: 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)
setDarcsEncodings :: IO ()
#ifdef WIN32
setDarcsEncodings = return ()
#else
setDarcsEncodings :: IO ()
setDarcsEncodings = do
TextEncoding
e <- IO TextEncoding
getFileSystemEncoding
TextEncoding -> IO ()
setForeignEncoding TextEncoding
e
TextEncoding -> IO ()
setLocaleEncoding TextEncoding
e
#endif
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
isUTF8Locale :: String -> Bool
isUTF8Locale :: String -> Bool
isUTF8Locale codeName :: String
codeName = case String -> String
normalizeEncoding String
codeName of
"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" -> Bool
True
"u8" -> Bool
True
"utf" -> Bool
True
"utf8" -> Bool
True
"utf8_ucs2" -> Bool
True
"utf8_ucs4" -> Bool
True
_ -> 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]+"