module Darcs.External (
backupByRenaming, backupByCopying,
copyFileOrUrl, speculateFileOrUrl, copyFilesOrUrls, copyLocal, cloneFile,
cloneTree, cloneTreeExcept, clonePartialsTree, clonePaths,
fetchFilePS, gzFetchFilePS,
sendEmail, generateEmail, sendEmailDoc, resendEmail,
signString, verifyPS,
execDocPipe, execPipeIgnoreError,
getTermNColors,
pipeDoc, pipeDocSSH, execSSH,
maybeURLCmd,
Cachable(Cachable, Uncachable, MaxAge),
viewDoc, viewDocWith,
) where
import Data.List ( intersperse )
import Control.Monad ( when, zipWithM_ )
import System.Exit ( ExitCode(..) )
import System.Environment ( getEnv )
import System.Cmd ( system )
import System.IO ( hPutStr, hPutStrLn, hGetContents, hClose,
openBinaryFile, IOMode( ReadMode ),
openBinaryTempFile,
hIsTerminalDevice, stdout, stderr, Handle )
import System.IO.Error ( isDoesNotExistError )
import System.IO.Unsafe ( unsafePerformIO )
import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )
import System.Directory ( createDirectory, getDirectoryContents,
doesFileExist, doesDirectoryExist,
renameFile, renameDirectory, copyFile )
import System.Process ( runProcess, runInteractiveProcess, waitForProcess )
import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )
import Control.Exception ( bracket, try, finally )
import Data.Char ( toUpper )
import Foreign.C ( CString, withCString )
import Foreign.Ptr ( nullPtr )
#ifdef HAVE_TERMINFO
import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability )
#elif HAVE_CURSES
import Foreign.C ( CChar, CInt )
import Foreign.Ptr ( Ptr )
import Foreign.Marshal.Alloc (allocaBytes)
import Autoconf ( use_color )
#endif
import System.Posix.Files ( createLink )
import System.Directory ( createDirectoryIfMissing )
import System.FilePath.Posix ( (</>), takeDirectory, normalise )
import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL, NoLinks,
Verify, VerifySSL ) )
import Darcs.RepoPath ( AbsolutePath, toFilePath )
import Darcs.Utils ( withCurrentDirectory, breakCommand, get_viewer, ortryrunning, )
import Progress ( withoutProgress, progressList, debugMessage )
import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS)
import qualified Data.ByteString as B (ByteString, empty, null, readFile
,hGetContents, writeFile, hPut, length
,take, concat, drop, isPrefixOf)
import qualified Data.ByteString.Char8 as BC (unpack, pack)
import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, canonFilename, writeDocBinFile,
removeFileMayNotExist, )
import CommandLine ( parseCmd, addUrlencoded )
import Autoconf ( have_libcurl, have_libwww, have_HTTP, have_sendmail, have_mapi, sendmail_path, darcs_version )
import URL ( copyUrl, copyUrlFirst, waitUrl )
import Ssh ( getSSH, copySSH, copySSHs, SSHCmd(..) )
import URL ( Cachable(..) )
import Exec ( exec, Redirect(..), withoutNonBlock )
import Darcs.URL ( is_file, is_url, is_ssh )
import Darcs.Utils ( catchall )
import Printer ( Doc, Printers, putDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), (<+>), renderPS,
simplePrinters,
text, empty, packedString, vcat, renderString )
#include "impossible.h"
backupByRenaming :: FilePath -> IO ()
backupByRenaming = backupBy rename
where rename x y = do
isD <- doesDirectoryExist x
if isD then renameDirectory x y else renameFile x y
backupByCopying :: FilePath -> IO ()
backupByCopying = backupBy copy
where
copy x y = do
isD <- doesDirectoryExist x
if isD then do createDirectory y
cloneTree (normalise x) (normalise y)
else copyFile x y
backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()
backupBy backup f =
do hasBF <- doesFileExist f
hasBD <- doesDirectoryExist f
when (hasBF || hasBD) $ helper (0::Int)
where
helper i = do existsF <- doesFileExist next
existsD <- doesDirectoryExist next
if (existsF || existsD)
then helper (i + 1)
else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"
backup f next
where next = f ++ suffix
suffix = "-darcs-backup" ++ show i
fetchFilePS :: String -> Cachable -> IO B.ByteString
fetchFilePS fou _ | is_file fou = B.readFile fou
fetchFilePS fou cache = withTemp $ \t -> do copyFileOrUrl [] fou t cache
B.readFile t
gzFetchFilePS :: String -> Cachable -> IO B.ByteString
gzFetchFilePS fou _ | is_file fou = gzReadFilePS fou
gzFetchFilePS fou cache = withTemp $ \t-> do copyFileOrUrl [] fou t cache
gzReadFilePS t
copyFileOrUrl :: [DarcsFlag] -> FilePath -> FilePath -> Cachable -> IO ()
copyFileOrUrl opts fou out _ | is_file fou = copyLocal opts fou out
copyFileOrUrl _ fou out cache | is_url fou = copyRemote fou out cache
copyFileOrUrl _ fou out _ | is_ssh fou = copySSH fou out
copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ fou
speculateFileOrUrl :: String -> FilePath -> IO ()
speculateFileOrUrl fou out | is_url fou = speculateRemote fou out
| otherwise = return ()
copyLocal :: [DarcsFlag] -> String -> FilePath -> IO ()
copyLocal opts fou out | NoLinks `elem` opts = cloneFile fou out
| otherwise = createLink fou out `catchall` cloneFile fou out
clonePaths :: FilePath -> FilePath -> [FilePath] -> IO ()
clonePaths source dest = mapM_ (clonePath source dest)
clonePath :: FilePath -> FilePath -> FilePath -> IO ()
clonePath source dest path
= do let source' = source </> path
dest' = dest </> path
fs <- getSymbolicLinkStatus source'
if isDirectory fs then do
createDirectoryIfMissing True dest'
else if isRegularFile fs then do
createDirectoryIfMissing True (dest </> takeDirectory path)
cloneFile source' dest'
else fail ("clonePath: Bad file " ++ source')
`catch` fail ("clonePath: Bad file " ++ source </> path)
clonePartialsTree :: FilePath -> FilePath -> [FilePath] -> IO ()
clonePartialsTree source dest = mapM_ (clonePartialTree source dest)
clonePartialTree :: FilePath -> FilePath -> FilePath -> IO ()
clonePartialTree source dest "" = cloneTree source dest
clonePartialTree source dest pref
= do createDirectoryIfMissing True (dest </> takeDirectory pref)
cloneSubTree (source </> pref) (dest </> pref)
cloneTree :: FilePath -> FilePath -> IO ()
cloneTree = cloneTreeExcept []
cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()
cloneTreeExcept except source dest =
do fs <- getSymbolicLinkStatus source
if isDirectory fs then do
fps <- getDirectoryContents source
let fps' = filter (`notElem` (".":"..":except)) fps
mk_source fp = source </> fp
mk_dest fp = dest </> fp
zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
else fail ("cloneTreeExcept: Bad source " ++ source)
`catch` fail ("cloneTreeExcept: Bad source " ++ source)
cloneSubTree :: FilePath -> FilePath -> IO ()
cloneSubTree source dest =
do fs <- getSymbolicLinkStatus source
if isDirectory fs then do
createDirectory dest
fps <- getDirectoryContents source
let fps' = filter (`notElem` [".", ".."]) fps
mk_source fp = source </> fp
mk_dest fp = dest </> fp
zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
else if isRegularFile fs then do
cloneFile source dest
else fail ("cloneSubTree: Bad source "++ source)
`catch` (\e -> if isDoesNotExistError e
then return ()
else ioError e)
cloneFile :: FilePath -> FilePath -> IO ()
cloneFile = copyFile
maybeURLCmd :: String -> String -> IO(Maybe(String))
maybeURLCmd what url =
do let prot = map toUpper $ takeWhile (/= ':') url
fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))
`catch` \_ -> return Nothing
speculateRemote :: String -> FilePath -> IO ()
speculateRemote u v =
do maybeget <- maybeURLCmd "GET" u
case maybeget of
Just _ -> return ()
Nothing -> if have_libwww || have_libcurl || have_HTTP
then copyUrl u v Cachable
else return ()
copyRemote :: String -> FilePath -> Cachable -> IO ()
copyRemote u v cache =
do maybeget <- maybeURLCmd "GET" u
case maybeget of
Nothing -> copyRemoteNormal u v cache
Just get ->
do let (cmd,args) = breakCommand get
r <- exec cmd (args++[u]) (Null, File v, AsIs)
when (r /= ExitSuccess) $
fail $ "(" ++ get ++ ") failed to fetch: " ++ u
copyRemoteNormal :: String -> FilePath -> Cachable -> IO ()
copyRemoteNormal u v cache = if have_libwww || have_libcurl || have_HTTP
then copyUrlFirst u v cache >> waitUrl u
else copyRemoteCmd u v
copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO ()
copyFilesOrUrls opts dou ns out _ | is_file dou = copyLocals opts dou ns out
copyFilesOrUrls _ dou ns out c | is_url dou = copyRemotes dou ns out c
copyFilesOrUrls _ dou ns out _ | is_ssh dou = copySSHs dou ns out
copyFilesOrUrls _ dou _ _ _ = fail $ "unknown transport protocol: "++dou
copyLocals :: [DarcsFlag] -> String -> [String] -> FilePath -> IO ()
copyLocals opts u ns d =
doWithPatches (\n -> copyLocal opts (u++"/"++n) (d++"/"++n)) ns
copyRemotes :: String -> [String] -> FilePath -> Cachable -> IO()
copyRemotes u ns d cache =
do maybeget <- maybeURLCmd "GET" u
maybemget <- maybeURLCmd "MGET" u
case (maybeget, maybemget) of
(Nothing, _) -> copyRemotesNormal u ns d cache
(Just _, Nothing) -> doWithPatches (\n -> copyRemote (u++"/"++n) (d++"/"++n) cache) ns
(Just _, Just mget) -> mgetRemotes mget u ns d
stringToInt :: String -> Int -> Int
stringToInt num def = case reads num of [(x,"")] -> x
_ -> def
mgetRemotes :: String -> String -> [String] -> FilePath -> IO()
mgetRemotes _ _ [] _ = return ()
mgetRemotes mget u ns d = do
mgetmax <- getEnv "DARCS_MGETMAX" `catch` \_ -> return ""
let (nsnow, nslater) = splitAt (stringToInt mgetmax 200) ns
(cmd, args) = breakCommand mget
urls = map (\n -> u++"/"++n) nsnow
withCurrentDirectory d $ do
r <- exec cmd (args++urls) (Null,Null,AsIs)
when (r /= ExitSuccess) $
fail $ unlines $
["(" ++ mget ++ ") failed to fetch files.",
"source directory: " ++ d,
"source files:"] ++ (upto 5 nsnow) ++
["still to go:"] ++ (upto 5 nslater)
mgetRemotes mget u nslater d
where
upto :: Integer -> [String] -> [String]
upto _ [] = []
upto 0 l = [ "(" ++ (show (length l)) ++ " more)" ]
upto n (h : t) = h : (upto (n 1) t)
copyRemotesNormal :: String -> [String] -> FilePath -> Cachable -> IO()
copyRemotesNormal u ns d cache =
if have_libwww || have_libcurl || have_HTTP
then do mapM_ (\n -> copyUrl (u++"/"++n) (d++"/"++n) cache) ns
doWithPatches (\n -> waitUrl (u++"/"++n)) ns
else wgetRemotes u ns d
wgetRemotes :: String -> [String] -> FilePath -> IO ()
wgetRemotes u ns d = do wget_command <- getEnv "DARCS_WGET" `catch`
\_ -> return "wget"
let (wget, wget_args) = breakCommand wget_command
input = unlines $ map (\n -> u++"/"++n) ns
withCurrentDirectory d $ withOpenTemp $ \(th,tn) ->
do hPutStr th input
hClose th
r <- exec wget (wget_args++["-i",tn])
(Null,Null,AsIs)
when (r /= ExitSuccess) $
fail $ unlines $
["(wget) failed to fetch files.",
"source directory: " ++ d,
"source files:"] ++ ns
copyRemoteCmd :: String -> FilePath -> IO ()
copyRemoteCmd s tmp = do
let cmd = get_ext_cmd
r <- stupidexec (cmd tmp s) (Null,Null,AsIs)
when (r /= ExitSuccess) $
fail $ "failed to fetch: " ++ s ++" " ++ show r
where stupidexec [] = bug "stupidexec without a command"
stupidexec xs = exec (head xs) (tail xs)
doWithPatches :: (String -> IO ()) -> [String] -> IO ()
doWithPatches f patches = mapM_ (\p -> seq p $ f p) $ progressList "Copying patch" patches
get_ext_cmd :: String -> String -> [String]
get_ext_cmd = unsafePerformIO get_ext_cmd'
get_ext_cmd' :: IO (String -> String -> [String])
get_ext_cmd' = try_cmd cmds
where cmds = [("wget", (("--version",0),
\t s -> ["wget", "-q",
"--header=Pragma: no-cache",
"--header=Cache-Control: no-cache",
"-O",t,s])),
("curl", (("--version",2),
\t s -> ["curl", "-s", "-f", "-L",
"-H", "Pragma: no-cache",
"-H", "Cache-Control: no-cache",
"-o",t,s]))]
try_cmd [] = fail $ "I need one of: " ++ cs
where cs = concat $ intersperse ", " (map fst cmds)
try_cmd ((c,(ok_check,f)):cs) = do
True <- can_execute ok_check c
return f
`catch` (\_ -> try_cmd cs)
execSSH :: String -> String -> IO ExitCode
execSSH remoteAddr command =
do (ssh, ssh_args) <- getSSH SSH remoteAddr
debugMessage $ unwords (ssh:ssh_args++[remoteAddr,command])
withoutProgress $ do hid <- runProcess ssh (ssh_args++[remoteAddr,command])
Nothing Nothing Nothing Nothing Nothing
waitForProcess hid
pipeDoc :: String -> [String] -> Doc -> IO ExitCode
pipeDoc c args inp = withoutNonBlock $ withoutProgress $
do debugMessage $ unwords (c:args)
(i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing
mvare <- newEmptyMVar
forkIO ((hGetContents e >>=
hPutStr stderr)
`finally` putMVar mvare ())
mvaro <- newEmptyMVar
forkIO ((hGetContents o >>=
hPutStr stdout)
`finally` putMVar mvaro ())
hPutDoc i inp
hClose i
rval <- waitForProcess pid
takeMVar mvare
takeMVar mvaro
when (rval == ExitFailure 127) $
putStrLn $ "Command not found:\n "++ show (c:args)
return rval
pipeDocSSH :: String -> [String] -> Doc -> IO ExitCode
pipeDocSSH remoteAddr args input =
do (ssh, ssh_args) <- getSSH SSH remoteAddr
pipeDoc ssh (ssh_args++ (remoteAddr:args)) input
sendEmail :: String -> String -> String -> String -> String -> String -> IO ()
sendEmail f t s cc scmd body =
sendEmailDoc f t s cc scmd Nothing (text body)
generateEmail
:: Handle
-> String
-> String
-> String
-> String
-> Doc
-> IO ()
generateEmail h f t s cc body = do
hPutDocLn h $
text "To:" <+> text t
$$ text "From:" <+> text f
$$ text "Subject:" <+> text s
$$ formated_cc
$$ text "X-Mail-Originator: Darcs Version Control System"
$$ text ("X-Darcs-Version: " ++ darcs_version)
$$ body
where formated_cc = if cc == ""
then empty
else text "Cc:" <+> text cc
sendEmailDoc
:: String
-> String
-> String
-> String
-> String
-> Maybe (Doc, Doc)
-> Doc
-> IO ()
sendEmailDoc _ "" _ "" _ _ _ = return ()
sendEmailDoc f "" s cc scmd mbundle body =
sendEmailDoc f cc s "" scmd mbundle body
sendEmailDoc f t s cc scmd mbundle body =
if have_sendmail || scmd /= "" then do
withOpenTemp $ \(h,fn) -> do
generateEmail h f t s cc body
hClose h
withOpenTemp $ \(hat,at) -> do
ftable' <- case mbundle of
Just (content,bundle) -> do
hPutDocLn hat $ bundle
return [ ('b', renderString content) , ('a', at) ]
Nothing ->
return [ ('b', renderString body) ]
hClose hat
let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable'
r <- execSendmail ftable scmd fn
when (r /= ExitSuccess) $ fail ("failed to send mail to: "
++ t ++ cc_list cc
++ "\nPerhaps sendmail is not configured.")
else if have_mapi then 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 fail $ "no mail facility (sendmail or mapi) located at configure time!"
where addressOnly a =
case dropWhile (/= '<') a of
('<':a2) -> takeWhile (/= '>') a2
_ -> a
cc_list [] = []
cc_list c = " and cc'ed " ++ c
resendEmail :: String -> String -> B.ByteString -> IO ()
resendEmail "" _ _ = return ()
resendEmail t scmd body =
case (have_sendmail || scmd /= "", have_mapi) of
(True, _) -> do
withOpenTemp $ \(h,fn) -> do
hPutStrLn h $ "To: "++ t
hPutStrLn h $ find_from (linesPS body)
hPutStrLn h $ find_subject (linesPS body)
hPutDocLn h $ fixit $ linesPS body
hClose h
let ftable = [('t',t)]
r <- execSendmail ftable scmd fn
when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t)
(_, True) -> fail "Don't know how to resend email with MAPI"
_ -> fail $ "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"
where br = BC.pack "\r"
darcsurl = BC.pack "DarcsURL:"
content = BC.pack "Content-"
from_start = BC.pack "From:"
subject_start = BC.pack "Subject:"
fixit (l:ls)
| B.null l = packedString B.empty $$ vcat (map packedString ls)
| l == br = packedString B.empty $$ vcat (map packedString ls)
| B.take 9 l == darcsurl || B.take 8 l == content
= packedString l $$ fixit ls
| otherwise = fixit ls
fixit [] = empty
find_from (l:ls) | B.take 5 l == from_start = BC.unpack l
| otherwise = find_from ls
find_from [] = "From: unknown"
find_subject (l:ls) | B.take 8 l == subject_start = BC.unpack l
| otherwise = find_subject ls
find_subject [] = "Subject: (no subject)"
execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode
execSendmail ftable scmd fn =
if scmd == "" then
exec sendmail_path ["-i", "-t"] (File fn, Null, AsIs)
else case parseCmd (addUrlencoded ftable) scmd of
Right (arg0:opts, wantstdin) ->
do let stdin = if wantstdin then File fn else Null
exec arg0 opts (stdin, Null, AsIs)
Left e -> fail $ ("failed to send mail, invalid sendmail-command: "++(show e))
_ -> fail $ ("failed to send mail, invalid sendmail-command")
#ifdef HAVE_MAPI
foreign import ccall "win32/send_email.h send_email" c_send_email
#else
c_send_email
#endif
:: CString ->
CString ->
CString ->
CString ->
CString ->
CString ->
IO Int
#ifndef HAVE_MAPI
c_send_email = impossible
#endif
execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString
execPSPipe c args ps = fmap renderPS
$ execDocPipe c args
$ packedString ps
execDocPipe :: String -> [String] -> Doc -> IO Doc
execDocPipe c args instr = withoutProgress $
do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing
forkIO $ hPutDoc i instr >> hClose i
mvare <- newEmptyMVar
forkIO ((hGetContents e >>=
hPutStr stderr)
`finally` putMVar mvare ())
out <- B.hGetContents o
rval <- waitForProcess pid
takeMVar mvare
case rval of
ExitFailure ec ->fail $ "External program '"++c++
"' failed with exit code "++ show ec
ExitSuccess -> return $ packedString out
execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc
execPipeIgnoreError c args instr = withoutProgress $
do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing
forkIO $ hPutDoc i instr >> hClose i
mvare <- newEmptyMVar
forkIO ((hGetContents e >>=
hPutStr stderr)
`finally` putMVar mvare ())
out <- B.hGetContents o
waitForProcess pid
takeMVar mvare
return $ packedString out
signString :: [DarcsFlag] -> Doc -> IO Doc
signString [] d = return d
signString (Sign:_) d = signPGP [] d
signString (SignAs keyid:_) d = signPGP ["--local-user", keyid] d
signString (SignSSL idf:_) d = signSSL idf d
signString (_:os) d = signString os d
signPGP :: [String] -> Doc -> IO Doc
signPGP args t = execDocPipe "gpg" ("--clearsign":args) t
signSSL :: String -> Doc -> IO Doc
signSSL idfile t =
withTemp $ \cert -> do
opensslPS ["req", "-new", "-key", idfile,
"-outform", "PEM", "-days", "365"]
(BC.pack "\n\n\n\n\n\n\n\n\n\n\n")
>>= opensslPS ["x509", "-req", "-extensions",
"v3_ca", "-signkey", idfile,
"-outform", "PEM", "-days", "365"]
>>= opensslPS ["x509", "-outform", "PEM"]
>>= B.writeFile cert
opensslDoc ["smime", "-sign", "-signer", cert,
"-inkey", idfile, "-noattr", "-text"] t
where opensslDoc = execDocPipe "openssl"
opensslPS = execPSPipe "openssl"
verifyPS :: [DarcsFlag] -> B.ByteString -> IO (Maybe B.ByteString)
verifyPS [] ps = return $ Just ps
verifyPS (Verify pks:_) ps = verifyGPG pks ps
verifyPS (VerifySSL auks:_) ps = verifySSL auks ps
verifyPS (_:os) ps = verifyPS os ps
verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)
verifyGPG goodkeys s =
withOpenTemp $ \(th,tn) -> do
B.hPut th s
hClose th
rval <- exec "gpg" ["--batch","--no-default-keyring",
"--keyring",fix_path $ toFilePath goodkeys, "--verify"]
(File tn, Null, Null)
case rval of
ExitSuccess -> return $ Just gpg_fixed_s
_ -> return Nothing
where gpg_fixed_s = let
not_begin_signature x =
x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"
&&
x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r"
in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s
fix_line x | B.length x < 3 = x
| BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x
| otherwise = x
#if defined(WIN32)
fix_sep c | c=='/' = '\\' | otherwise = c
fix_path p = map fix_sep p
#else
fix_path p = p
#endif
verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)
verifySSL goodkeys s = do
certdata <- opensslPS ["smime", "-pk7out"] s
>>= opensslPS ["pkcs7", "-print_certs"]
cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata
let key_used = B.concat $ tail $
takeWhile (/= BC.pack"-----END PUBLIC KEY-----")
$ linesPS cruddy_pk
in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys)
if not $ key_used `elem` allowed_keys
then return Nothing
else withTemp $ \cert ->
withTemp $ \on ->
withOpenTemp $ \(th,tn) -> do
B.hPut th s
hClose th
B.writeFile cert certdata
rval <- exec "openssl" ["smime", "-verify", "-CAfile",
cert, "-certfile", cert]
(File tn, File on, Null)
case rval of
ExitSuccess -> Just `fmap` B.readFile on
_ -> return Nothing
where opensslPS = execPSPipe "openssl"
can_execute :: (String,Int) -> String -> IO Bool
can_execute (arg,expected_return_value) exe = do
withTemp $ \junk -> do
ec <- system (unwords [exe,arg,">",junk])
case ec of
ExitSuccess | expected_return_value == 0 -> return True
ExitFailure r | r == expected_return_value -> return True
_ -> return False
getTermNColors :: IO Int
#ifdef HAVE_TERMINFO
getTermNColors = do
t <- setupTermFromEnv
return $ case getCapability t $ tiGetNum "colors" of
Nothing -> (1)
Just x -> x
#elif HAVE_CURSES
foreign import ccall "tgetnum" c_tgetnum :: CString -> IO CInt
foreign import ccall "tgetent" c_tgetent :: Ptr CChar -> CString -> IO CInt
termioBufSize :: Int
termioBufSize = 4096
getTermNColors = if not use_color
then return (1)
else do term <- getEnv "TERM"
allocaBytes termioBufSize (getTermNColorsImpl term)
`catch` \_ -> return (1)
getTermNColorsImpl :: String -> Ptr CChar -> IO Int
getTermNColorsImpl term buf = do rc <- withCString term $
\termp -> c_tgetent buf termp
x <- if (rc /= 1) then return (1) else withCString "Co" $ \capap -> c_tgetnum capap
return $ fromIntegral x
#else
getTermNColors = return (1)
#endif
viewDoc :: Doc -> IO ()
viewDoc = viewDocWith simplePrinters
viewDocWith :: Printers -> Doc -> IO ()
viewDocWith pr msg = do
isTerminal <- hIsTerminalDevice stdout
if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg)
then do viewer <- get_viewer
pipeDocToPager viewer [] pr msg
`ortryrunning` pipeDocToPager "less" [] pr msg
`ortryrunning` pipeDocToPager "more" [] pr msg
#ifdef WIN32
`ortryrunning` pipeDocToPager "more.com" [] pr msg
#endif
`ortryrunning` pipeDocToPager "" [] pr msg
else pipeDocToPager "" [] pr msg
return ()
where lengthGreaterThan n _ | n <= 0 = True
lengthGreaterThan _ [] = False
lengthGreaterThan n (_:xs) = lengthGreaterThan (n1) xs
pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode
pipeDocToPager "" _ pr inp = do
putDocLnWith pr inp
return ExitSuccess
pipeDocToPager c args pr inp = withoutNonBlock $ withoutProgress $ do
tmp <- tempdir_loc
bracket (openBinaryTempFile tmp "darcs-pager") cleanup $ \(fn,fh) ->
do hPutDocWith pr fh inp
hClose fh
bracket (openBinaryFile fn ReadMode) hClose $ \h ->
do x <- do pid <- runProcess c args Nothing Nothing (Just h) Nothing Nothing
waitForProcess pid
when (x == ExitFailure 127) $
putStrLn $ "Command not found:\n "++ show (c:args)
return x
where
cleanup (f,h) = do try $ hClose h
removeFileMayNotExist f