1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
    2 
    3 module Darcs.External (
    4     backupByRenaming, backupByCopying,
    5     copyFileOrUrl, speculateFileOrUrl, copyFilesOrUrls, copyLocal, cloneFile,
    6     cloneTree, cloneTreeExcept, clonePartialsTree, clonePaths,
    7     fetchFilePS, gzFetchFilePS,
    8     sendEmail, generateEmail, sendEmailDoc, resendEmail,
    9     signString, verifyPS,
   10     execDocPipe, execPipeIgnoreError,
   11     getTermNColors,
   12     pipeDoc, pipeDocSSH, execSSH,
   13     maybeURLCmd,
   14     Cachable(Cachable, Uncachable, MaxAge),
   15     viewDoc, viewDocWith,
   16     sendmail_path, diff_program
   17   ) where
   18 
   19 import Data.Maybe ( isJust, isNothing, maybeToList )
   20 import Control.Monad ( when, zipWithM_, filterM, liftM2 )
   21 import System.Exit ( ExitCode(..) )
   22 import System.Environment ( getEnv )
   23 import System.IO ( hPutStr, hPutStrLn, hGetContents, hClose,
   24                    openBinaryFile, IOMode( ReadMode ),
   25                    openBinaryTempFile,
   26                    hIsTerminalDevice, stdout, stderr, Handle )
   27 import System.IO.Error ( isDoesNotExistError )
   28 import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )
   29 import System.Directory ( createDirectory, getDirectoryContents,
   30                           doesFileExist, doesDirectoryExist,
   31                           renameFile, renameDirectory, copyFile,
   32                           findExecutable )
   33 import System.Process ( runProcess, runInteractiveProcess, waitForProcess )
   34 import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )
   35 import Control.Exception ( bracket, try, finally )
   36 import Data.Char ( toUpper )
   37 #if defined (HAVE_MAPI)
   38 import Foreign.C ( CString, withCString )
   39 #endif
   40 #ifdef HAVE_MAPI
   41 import Foreign.Ptr ( nullPtr )
   42 import Darcs.Lock ( canonFilename, writeDocBinFile )
   43 #endif
   44 #ifdef HAVE_TERMINFO
   45 import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability )
   46 #endif
   47 import System.Posix.Files ( createLink )
   48 import System.Directory ( createDirectoryIfMissing )
   49 import System.FilePath.Posix ( (</>), takeDirectory, normalise )
   50 
   51 import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL, NoLinks,
   52                                 Verify, VerifySSL ) )
   53 import Darcs.RepoPath ( AbsolutePath, toFilePath )
   54 import Darcs.Utils ( withCurrentDirectory, breakCommand, get_viewer, ortryrunning, )
   55 import Progress ( withoutProgress, progressList, debugMessage )
   56 
   57 import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS)
   58 import qualified Data.ByteString as B (ByteString, empty, null, readFile -- ratify readFile: Just an import from ByteString
   59             ,hGetContents, writeFile, hPut, length -- ratify hGetContents: importing from ByteString
   60             ,take, concat, drop, isPrefixOf, singleton, append)
   61 import qualified Data.ByteString.Char8 as BC (unpack, pack)
   62 
   63 import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, removeFileMayNotExist )
   64 import CommandLine ( parseCmd, addUrlencoded )
   65 import URL ( copyUrl, copyUrlFirst, waitUrl )
   66 import Ssh ( getSSH, copySSH, copySSHs, SSHCmd(..) )
   67 import URL ( Cachable(..) )
   68 import Exec ( exec, Redirect(..), withoutNonBlock )
   69 import Darcs.URL ( is_file, is_url, is_ssh )
   70 import Darcs.Utils ( catchall )
   71 import Printer ( Doc, Printers, putDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS,
   72                  simplePrinters,
   73                  text, empty, packedString, vcat, renderString )
   74 import Darcs.Email ( formatHeader )
   75 
   76 sendmail_path :: IO String
   77 sendmail_path = do
   78   l <- filterM doesFileExist $ liftM2 (</>)
   79                 [ "/usr/sbin", "/sbin", "/usr/lib" ]
   80                 [ "sendmail" ]
   81   ex <- findExecutable "sendmail"
   82   when (isNothing ex && null l) $ fail "Cannot find the \"sendmail\" program."
   83   return $ head $ maybeToList ex ++ l
   84 
   85 diff_program :: IO String
   86 diff_program = do
   87   l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ]
   88   when (null l) $ fail "Cannot find the \"diff\" program."
   89   return $ head l
   90 
   91 backupByRenaming :: FilePath -> IO ()
   92 backupByRenaming = backupBy rename
   93  where rename x y = do
   94          isD <- doesDirectoryExist x
   95          if isD then renameDirectory x y else renameFile x y
   96 
   97 backupByCopying :: FilePath -> IO ()
   98 backupByCopying = backupBy copy
   99  where
  100   copy x y = do
  101     isD <- doesDirectoryExist x
  102     if isD then do createDirectory y
  103                    cloneTree (normalise x) (normalise y)
  104            else copyFile x y
  105 
  106 backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()
  107 backupBy backup f =
  108            do hasBF <- doesFileExist f
  109               hasBD <- doesDirectoryExist f
  110               when (hasBF || hasBD) $ helper (0::Int)
  111   where
  112   helper i = do existsF <- doesFileExist next
  113                 existsD <- doesDirectoryExist next
  114                 if (existsF || existsD)
  115                    then helper (i + 1)
  116                    else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"
  117                            backup f next
  118              where next = f ++ suffix
  119                    suffix = "-darcs-backup" ++ show i
  120 
  121 -- | @fetchFile fileOrUrl cache@ returns the content of its argument
  122 -- (either a file or an URL). If it has to download an url, then it
  123 -- will use a cache as required by its second argument.
  124 fetchFilePS :: String -> Cachable -> IO B.ByteString
  125 fetchFilePS fou _ | is_file fou = B.readFile fou
  126 fetchFilePS fou cache = withTemp $ \t -> do copyFileOrUrl [] fou t cache
  127                                             B.readFile t
  128 
  129 gzFetchFilePS :: String -> Cachable -> IO B.ByteString
  130 gzFetchFilePS fou _ | is_file fou = gzReadFilePS fou
  131 gzFetchFilePS fou cache = withTemp $ \t-> do copyFileOrUrl [] fou t cache
  132                                              gzReadFilePS t
  133 
  134 
  135 copyFileOrUrl :: [DarcsFlag] -> FilePath -> FilePath -> Cachable -> IO ()
  136 copyFileOrUrl opts fou out _     | is_file fou = copyLocal opts fou out
  137 copyFileOrUrl _    fou out cache | is_url  fou = copyRemote fou out cache
  138 copyFileOrUrl _    fou out _     | is_ssh  fou = copySSH fou out
  139 copyFileOrUrl _    fou _   _     = fail $ "unknown transport protocol: " ++ fou
  140 
  141 speculateFileOrUrl :: String -> FilePath -> IO ()
  142 speculateFileOrUrl fou out | is_url fou = speculateRemote fou out
  143                            | otherwise = return ()
  144 
  145 copyLocal  :: [DarcsFlag] -> String -> FilePath -> IO ()
  146 copyLocal opts fou out | NoLinks `elem` opts = cloneFile fou out
  147                        | otherwise = createLink fou out `catchall` cloneFile fou out
  148 
  149 clonePaths :: FilePath -> FilePath -> [FilePath] -> IO ()
  150 clonePaths source dest = mapM_ (clonePath source dest)
  151 
  152 clonePath :: FilePath -> FilePath -> FilePath -> IO ()
  153 clonePath source dest path
  154  = do let source' = source </> path
  155           dest' = dest </> path
  156       fs <- getSymbolicLinkStatus source'
  157       if isDirectory fs then do
  158           createDirectoryIfMissing True dest'
  159        else if isRegularFile fs then do
  160           createDirectoryIfMissing True (dest </> takeDirectory path)
  161           cloneFile source' dest'
  162        else fail ("clonePath: Bad file " ++ source')
  163    `catch` fail ("clonePath: Bad file " ++ source </> path)
  164 
  165 clonePartialsTree :: FilePath -> FilePath -> [FilePath] -> IO ()
  166 clonePartialsTree source dest = mapM_ (clonePartialTree source dest)
  167 
  168 clonePartialTree :: FilePath -> FilePath -> FilePath -> IO ()
  169 clonePartialTree source dest "" = cloneTree source dest
  170 clonePartialTree source dest pref
  171  = do createDirectoryIfMissing True (dest </> takeDirectory pref)
  172       cloneSubTree (source </> pref) (dest </> pref)
  173 
  174 cloneTree :: FilePath -> FilePath -> IO ()
  175 cloneTree = cloneTreeExcept []
  176 
  177 cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()
  178 cloneTreeExcept except source dest =
  179  do fs <- getSymbolicLinkStatus source
  180     if isDirectory fs then do
  181         fps <- getDirectoryContents source
  182         let fps' = filter (`notElem` (".":"..":except)) fps
  183             mk_source fp = source </> fp
  184             mk_dest   fp = dest   </> fp
  185         zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
  186      else fail ("cloneTreeExcept: Bad source " ++ source)
  187    `catch` fail ("cloneTreeExcept: Bad source " ++ source)
  188 
  189 cloneSubTree :: FilePath -> FilePath -> IO ()
  190 cloneSubTree source dest =
  191  do fs <- getSymbolicLinkStatus source
  192     if isDirectory fs then do
  193         createDirectory dest
  194         fps <- getDirectoryContents source
  195         let fps' = filter (`notElem` [".", ".."]) fps
  196             mk_source fp = source </> fp
  197             mk_dest   fp = dest   </> fp
  198         zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
  199      else if isRegularFile fs then do
  200         cloneFile source dest
  201      else fail ("cloneSubTree: Bad source "++ source)
  202     `catch` (\e -> if isDoesNotExistError e
  203                    then return ()
  204                    else ioError e)
  205 
  206 cloneFile :: FilePath -> FilePath -> IO ()
  207 cloneFile = copyFile
  208 
  209 maybeURLCmd :: String -> String -> IO(Maybe(String))
  210 maybeURLCmd what url =
  211   do let prot = map toUpper $ takeWhile (/= ':') url
  212      fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))
  213              `catch` \_ -> return Nothing
  214 
  215 speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable
  216 #if defined(HAVE_CURL) || defined(HAVE_HTTP)
  217 speculateRemote u v =
  218     do maybeget <- maybeURLCmd "GET" u
  219        case maybeget of
  220          Just _ -> return () -- can't pipeline these
  221          Nothing -> copyUrl u v Cachable
  222 #else
  223 speculateRemote u _ = maybeURLCmd "GET" u >> return ()
  224 #endif
  225 
  226 copyRemote :: String -> FilePath -> Cachable -> IO ()
  227 copyRemote u v cache =
  228     do maybeget <- maybeURLCmd "GET" u
  229        case maybeget of
  230          Nothing -> copyRemoteNormal u v cache
  231          Just get ->
  232            do let (cmd,args) = breakCommand get
  233               r <- exec cmd (args++[u]) (Null, File v, AsIs)
  234               when (r /= ExitSuccess) $
  235                   fail $ "(" ++ get ++ ") failed to fetch: " ++ u
  236 
  237 copyRemoteNormal :: String -> FilePath -> Cachable -> IO ()
  238 copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u
  239 
  240 copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO ()
  241 copyFilesOrUrls opts dou ns out _ | is_file dou = copyLocals opts dou ns out
  242 copyFilesOrUrls _ dou ns out c    | is_url  dou = copyRemotes dou ns out c
  243 copyFilesOrUrls _ dou ns out _    | is_ssh  dou = copySSHs dou ns out
  244 copyFilesOrUrls _ dou _  _   _    = fail $ "unknown transport protocol: "++dou
  245 
  246 
  247 copyLocals :: [DarcsFlag] -> String -> [String] -> FilePath -> IO ()
  248 copyLocals opts u ns d =
  249     doWithPatches (\n -> copyLocal opts (u++"/"++n) (d++"/"++n)) ns
  250 
  251 copyRemotes :: String -> [String] -> FilePath -> Cachable -> IO()
  252 copyRemotes u ns d cache =
  253     do maybeget <- maybeURLCmd "GET" u
  254        maybemget <- maybeURLCmd "MGET" u
  255        case (maybeget, maybemget) of
  256          (Nothing, _) -> copyRemotesNormal u ns d cache
  257          (Just _, Nothing) -> doWithPatches (\n -> copyRemote (u++"/"++n) (d++"/"++n) cache) ns
  258          (Just _, Just mget) -> mgetRemotes mget u ns d
  259 
  260 stringToInt :: String -> Int -> Int
  261 stringToInt num def = case reads num of [(x,"")] -> x
  262                                         _ -> def
  263 
  264 mgetRemotes :: String -> String -> [String] -> FilePath -> IO()
  265 mgetRemotes _ _ [] _ = return ()
  266 mgetRemotes mget u ns d = do
  267     mgetmax <- getEnv "DARCS_MGETMAX" `catch` \_ -> return ""
  268     let (nsnow, nslater) = splitAt (stringToInt mgetmax 200) ns
  269         (cmd, args) = breakCommand mget
  270         urls = map (\n -> u++"/"++n) nsnow
  271     withCurrentDirectory d $ do
  272         r <- exec cmd (args++urls) (Null,Null,AsIs)
  273         when (r /= ExitSuccess) $
  274             fail $ unlines $
  275                 ["(" ++ mget ++ ") failed to fetch files.",
  276                      "source directory: " ++ d,
  277                      "source files:"] ++ (upto 5 nsnow) ++
  278                      ["still to go:"] ++ (upto 5 nslater)
  279     mgetRemotes mget u nslater d
  280     where
  281     upto :: Integer -> [String] -> [String]
  282     upto _ [] = []
  283     upto 0 l = [ "(" ++ (show (length l)) ++ " more)" ]
  284     upto n (h : t) = h : (upto (n - 1) t)
  285 
  286 copyRemotesNormal :: String -> [String] -> FilePath -> Cachable -> IO()
  287 copyRemotesNormal u ns d cache =
  288     do mapM_ (\n -> copyUrl (u++"/"++n) (d++"/"++n) cache) ns
  289        doWithPatches (\n -> waitUrl (u++"/"++n)) ns
  290 
  291 doWithPatches :: (String -> IO ()) -> [String] -> IO ()
  292 doWithPatches f patches = mapM_ (\p -> seq p $ f p) $ progressList "Copying patch" patches
  293 
  294 -- | Run a command on a remote location without passing it any input or
  295 --   reading its output.  Return its ExitCode
  296 execSSH :: String -> String -> IO ExitCode
  297 execSSH remoteAddr command =
  298     do (ssh, ssh_args) <- getSSH SSH remoteAddr
  299        debugMessage $ unwords (ssh:ssh_args++[remoteAddr,command])
  300        withoutProgress $ do hid <- runProcess ssh (ssh_args++[remoteAddr,command])
  301                                    Nothing Nothing Nothing Nothing Nothing
  302                             waitForProcess hid
  303 
  304 pipeDoc :: String -> [String] -> Doc -> IO ExitCode
  305 pipeDoc c args inp = withoutNonBlock $ withoutProgress $
  306     do debugMessage $ unwords (c:args)
  307        (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing
  308        mvare <- newEmptyMVar
  309        forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed
  310                 hPutStr stderr)
  311                `finally` putMVar mvare ())
  312        mvaro <- newEmptyMVar
  313        forkIO ((hGetContents o >>= -- ratify hGetContents: it's immediately consumed
  314                 hPutStr stdout)
  315                `finally` putMVar mvaro ())
  316        hPutDoc i inp
  317        hClose i
  318        rval <- waitForProcess pid
  319        takeMVar mvare
  320        takeMVar mvaro
  321        when (rval == ExitFailure 127) $
  322             putStrLn $ "Command not found:\n   "++ show (c:args)
  323        return rval
  324 
  325 pipeDocSSH :: String -> [String] -> Doc -> IO ExitCode
  326 pipeDocSSH remoteAddr args input =
  327     do (ssh, ssh_args) <- getSSH SSH remoteAddr
  328        pipeDoc ssh (ssh_args++ (remoteAddr:args)) input
  329 
  330 sendEmail :: String -> String -> String -> String -> String -> String -> IO ()
  331 sendEmail f t s cc scmd body =
  332   sendEmailDoc f t s cc scmd Nothing (text body)
  333 
  334 
  335 generateEmail
  336     :: Handle  -- ^ handle to write email to
  337     -> String  -- ^ From
  338     -> String  -- ^ To
  339     -> String  -- ^ Subject
  340     -> String  -- ^ CC
  341     -> Doc     -- ^ body
  342     -> IO ()
  343 generateEmail h f t s cc body = do
  344      putHeader "To" t
  345      putHeader "From" f
  346      putHeader "Subject" s
  347      when (not (null cc)) (putHeader "Cc" cc)
  348      putHeader "X-Mail-Originator" "Darcs Version Control System"
  349      hPutDocLn h body
  350   where putHeader field value
  351             = B.hPut h (B.append (formatHeader field value) newline)
  352         newline = B.singleton 10
  353 
  354 have_sendmail :: IO Bool
  355 have_sendmail = (sendmail_path >> return True) `catch` (\_ -> return False)
  356 
  357 -- | Send an email, optionally containing a patch bundle
  358 --   (more precisely, its description and the bundle itself)
  359 sendEmailDoc
  360   :: String           -- ^ from
  361   -> String           -- ^ to
  362   -> String           -- ^ subject
  363   -> String           -- ^ cc
  364   -> String           -- ^ send command
  365   -> Maybe (Doc, Doc) -- ^ (content,bundle)
  366   -> Doc              -- ^ body
  367   -> IO ()
  368 sendEmailDoc _ "" _ "" _ _ _ = return ()
  369 sendEmailDoc f "" s cc scmd mbundle body =
  370   sendEmailDoc f cc s "" scmd mbundle body
  371 sendEmailDoc f t s cc scmd mbundle body = do
  372   use_sendmail <- have_sendmail
  373   if use_sendmail || scmd /= "" then do
  374     withOpenTemp $ \(h,fn) -> do
  375       generateEmail h f t s cc body
  376       hClose h
  377       withOpenTemp $ \(hat,at) -> do
  378         ftable' <- case mbundle of
  379                    Just (content,bundle) -> do
  380                        hPutDocLn hat $ bundle
  381                        return [ ('b', renderString content) , ('a', at) ]
  382                    Nothing ->
  383                        return [ ('b', renderString body) ]
  384         hClose hat
  385         let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable'
  386         r <- execSendmail ftable scmd fn
  387         when (r /= ExitSuccess) $ fail ("failed to send mail to: "
  388                                        ++ t ++ cc_list cc
  389                                        ++ "\nPerhaps sendmail is not configured.")
  390 #ifdef HAVE_MAPI
  391    else do
  392      r <- withCString t $ \tp ->
  393            withCString f $ \fp ->
  394             withCString cc $ \ccp ->
  395              withCString s $ \sp ->
  396               withOpenTemp $ \(h,fn) -> do
  397                hPutDoc h body
  398                hClose h
  399                writeDocBinFile "mailed_patch" body
  400                cfn <- canonFilename fn
  401                withCString cfn $ \pcfn ->
  402                 c_send_email fp tp ccp sp nullPtr pcfn
  403      when (r /= 0) $ fail ("failed to send mail to: " ++ t)
  404 #else
  405    else fail $ "no mail facility (sendmail or mapi) located at configure time!"
  406 #endif
  407   where addressOnly a =
  408           case dropWhile (/= '<') a of
  409           ('<':a2) -> takeWhile (/= '>') a2
  410           _        -> a
  411 
  412         cc_list [] = []
  413         cc_list c = " and cc'ed " ++ c
  414 
  415 resendEmail :: String -> String -> B.ByteString -> IO ()
  416 resendEmail "" _ _ = return ()
  417 resendEmail t scmd body = do
  418   use_sendmail <- have_sendmail
  419   if use_sendmail || scmd /= ""
  420    then do
  421     withOpenTemp $ \(h,fn) -> do
  422      hPutStrLn h $ "To: "++ t
  423      hPutStrLn h $ find_from (linesPS body)
  424      hPutStrLn h $ find_subject (linesPS body)
  425      hPutDocLn h $ fixit $ linesPS body
  426      hClose h
  427      let ftable = [('t',t)]
  428      r <-  execSendmail ftable scmd fn
  429      when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t)
  430    else
  431 #ifdef HAVE_MAPI
  432     fail "Don't know how to resend email with MAPI"
  433 #else
  434     fail "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"
  435 #endif
  436   where br            = BC.pack "\r"
  437         darcsurl      = BC.pack "DarcsURL:"
  438         content       = BC.pack "Content-"
  439         from_start    = BC.pack "From:"
  440         subject_start = BC.pack "Subject:"
  441         fixit (l:ls)
  442          | B.null l = packedString B.empty $$ vcat (map packedString ls)
  443          | l == br = packedString B.empty $$ vcat (map packedString ls)
  444          | B.take 9 l == darcsurl || B.take 8 l == content
  445             = packedString l $$ fixit ls
  446          | otherwise = fixit ls
  447         fixit [] = empty
  448         find_from (l:ls) | B.take 5 l == from_start = BC.unpack l
  449                          | otherwise = find_from ls
  450         find_from [] = "From: unknown"
  451         find_subject (l:ls) | B.take 8 l == subject_start = BC.unpack l
  452                             | otherwise = find_subject ls
  453         find_subject [] = "Subject: (no subject)"
  454 
  455 execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode
  456 execSendmail ftable scmd fn =
  457   if scmd == "" then do
  458      cmd <- sendmail_path
  459      exec cmd ["-i", "-t"] (File fn, Null, AsIs)
  460   else case parseCmd (addUrlencoded ftable) scmd of
  461          Right (arg0:opts, wantstdin) ->
  462            do let stdin = if wantstdin then File fn else Null
  463               exec arg0 opts (stdin, Null, AsIs)
  464          Left e -> fail $ ("failed to send mail, invalid sendmail-command: "++(show e))
  465          _ -> fail $ ("failed to send mail, invalid sendmail-command")
  466 
  467 #ifdef HAVE_MAPI
  468 foreign import ccall "win32/send_email.h send_email" c_send_email
  469              :: CString -> {- sender -}
  470                 CString -> {- recipient -}
  471                 CString -> {- cc -}
  472                 CString -> {- subject -}
  473                 CString -> {- body -}
  474                 CString -> {- path -}
  475                 IO Int
  476 #endif
  477 
  478 execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString
  479 execPSPipe c args ps = fmap renderPS
  480                      $ execDocPipe c args
  481                      $ packedString ps
  482 
  483 execDocPipe :: String -> [String] -> Doc -> IO Doc
  484 execDocPipe c args instr = withoutProgress $
  485     do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing
  486        forkIO $ hPutDoc i instr >> hClose i
  487        mvare <- newEmptyMVar
  488        forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed
  489                 hPutStr stderr)
  490                `finally` putMVar mvare ())
  491        out <- B.hGetContents o
  492        rval <- waitForProcess pid
  493        takeMVar mvare
  494        case rval of
  495          ExitFailure ec ->fail $ "External program '"++c++
  496                           "' failed with exit code "++ show ec
  497          ExitSuccess -> return $ packedString out
  498 
  499 -- The following is needed for diff, which returns non-zero whenever
  500 -- the files differ.
  501 execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc
  502 execPipeIgnoreError c args instr = withoutProgress $
  503     do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing
  504        forkIO $ hPutDoc i instr >> hClose i
  505        mvare <- newEmptyMVar
  506        forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed
  507                 hPutStr stderr)
  508                `finally` putMVar mvare ())
  509        out <- B.hGetContents o
  510        waitForProcess pid
  511        takeMVar mvare
  512        return $ packedString out
  513 
  514 signString :: [DarcsFlag] -> Doc -> IO Doc
  515 signString [] d = return d
  516 signString (Sign:_) d = signPGP [] d
  517 signString (SignAs keyid:_) d = signPGP ["--local-user", keyid] d
  518 signString (SignSSL idf:_) d = signSSL idf d
  519 signString (_:os) d = signString os d
  520 
  521 signPGP :: [String] -> Doc -> IO Doc
  522 signPGP args t = execDocPipe "gpg" ("--clearsign":args) t
  523 
  524 signSSL :: String -> Doc -> IO Doc
  525 signSSL idfile t =
  526     withTemp $ \cert -> do
  527     opensslPS ["req", "-new", "-key", idfile,
  528                "-outform", "PEM", "-days", "365"]
  529                 (BC.pack "\n\n\n\n\n\n\n\n\n\n\n")
  530                 >>= opensslPS ["x509", "-req", "-extensions",
  531                                "v3_ca", "-signkey", idfile,
  532                                "-outform", "PEM", "-days", "365"]
  533                 >>= opensslPS ["x509", "-outform", "PEM"]
  534                 >>= B.writeFile cert
  535     opensslDoc ["smime", "-sign", "-signer", cert,
  536                 "-inkey", idfile, "-noattr", "-text"] t
  537     where opensslDoc = execDocPipe "openssl"
  538           opensslPS = execPSPipe "openssl"
  539 
  540 
  541 verifyPS :: [DarcsFlag] -> B.ByteString -> IO (Maybe B.ByteString)
  542 verifyPS [] ps = return $ Just ps
  543 verifyPS (Verify pks:_) ps = verifyGPG pks ps
  544 verifyPS (VerifySSL auks:_) ps = verifySSL auks ps
  545 verifyPS (_:os) ps = verifyPS os ps
  546 
  547 verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)
  548 verifyGPG goodkeys s =
  549     withOpenTemp $ \(th,tn) -> do
  550       B.hPut th s
  551       hClose th
  552       rval <- exec "gpg"  ["--batch","--no-default-keyring",
  553                            "--keyring",fix_path $ toFilePath goodkeys, "--verify"]
  554                            (File tn, Null, Null)
  555       case rval of
  556           ExitSuccess -> return $ Just gpg_fixed_s
  557           _ -> return Nothing
  558       where gpg_fixed_s = let
  559                 not_begin_signature x =
  560                     x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"
  561                     &&
  562                     x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r"
  563                 in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s
  564             fix_line x | B.length x < 3 = x
  565                        | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x
  566                        | otherwise = x
  567 #if defined(WIN32)
  568             fix_sep c | c=='/' = '\\'   | otherwise = c
  569             fix_path p = map fix_sep p
  570 #else
  571             fix_path p = p
  572 #endif
  573 
  574 verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)
  575 verifySSL goodkeys s = do
  576     certdata <- opensslPS ["smime", "-pk7out"] s
  577                 >>= opensslPS ["pkcs7", "-print_certs"]
  578     cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata
  579     let key_used = B.concat $ tail $
  580                    takeWhile (/= BC.pack"-----END PUBLIC KEY-----")
  581                            $ linesPS cruddy_pk
  582         in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys)
  583               if not $ key_used `elem` allowed_keys
  584                 then return Nothing -- Not an allowed key!
  585                 else withTemp $ \cert ->
  586                      withTemp $ \on ->
  587                      withOpenTemp $ \(th,tn) -> do
  588                      B.hPut th s
  589                      hClose th
  590                      B.writeFile cert certdata
  591                      rval <- exec "openssl" ["smime", "-verify", "-CAfile",
  592                                              cert, "-certfile", cert]
  593                                              (File tn, File on, Null)
  594                      case rval of
  595                        ExitSuccess -> Just `fmap` B.readFile on
  596                        _ -> return Nothing
  597     where opensslPS = execPSPipe "openssl"
  598 
  599 
  600 {-
  601   - This function returns number of colors supported by current terminal
  602   - or -1 if color output not supported or error occured.
  603   - Terminal type determined by TERM env. variable.
  604   -}
  605 getTermNColors :: IO Int
  606 #ifdef HAVE_TERMINFO
  607 getTermNColors = do
  608   t <- setupTermFromEnv
  609   return $ case getCapability t $ tiGetNum "colors" of
  610     Nothing -> (-1)
  611     Just x -> x
  612 #else
  613 getTermNColors = return (-1)
  614 #endif
  615 
  616 viewDoc :: Doc -> IO ()
  617 viewDoc = viewDocWith simplePrinters
  618 
  619 viewDocWith :: Printers -> Doc -> IO ()
  620 viewDocWith pr msg = do
  621   isTerminal <- hIsTerminalDevice stdout
  622   if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg)
  623      then do viewer <- get_viewer
  624              pipeDocToPager viewer [] pr msg
  625                `ortryrunning` pipeDocToPager  "less" [] pr msg
  626                `ortryrunning` pipeDocToPager  "more" [] pr msg
  627 #ifdef WIN32
  628                `ortryrunning` pipeDocToPager  "more.com" [] pr msg
  629 #endif
  630                `ortryrunning` pipeDocToPager "" [] pr msg
  631      else pipeDocToPager "" [] pr msg
  632   return ()
  633               where lengthGreaterThan n _ | n <= 0 = True
  634                     lengthGreaterThan _ [] = False
  635                     lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs
  636 
  637 pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode
  638 
  639 pipeDocToPager "" _ pr inp = do
  640   putDocLnWith pr inp
  641   return ExitSuccess
  642 
  643 pipeDocToPager c args pr inp = withoutNonBlock $ withoutProgress $ do
  644   tmp <- tempdir_loc
  645   bracket (openBinaryTempFile tmp "darcs-pager") cleanup $ \(fn,fh) ->
  646     do hPutDocWith pr fh inp
  647        hClose fh
  648        bracket (openBinaryFile fn ReadMode) hClose $ \h ->
  649          do x <- do pid <- runProcess c args Nothing Nothing (Just h) Nothing Nothing
  650                     waitForProcess pid
  651             when (x == ExitFailure 127) $
  652                  putStrLn $ "Command not found:\n   "++ show (c:args)
  653             return x
  654   where
  655     cleanup (f,h) = do try $ hClose h
  656                        removeFileMayNotExist f