src/Darcs/External.hs

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