src/Darcs/RemoteApply.lhs

   1 \begin{code}
   2 module Darcs.RemoteApply ( remote_apply, apply_as ) where
   3
   4 import System.Exit ( ExitCode )
   5
   6 import Darcs.Flags ( DarcsFlag( ApplyAs, Debug ) )
   7 import Darcs.Utils ( breakCommand )
   8 import Darcs.URL ( is_url, is_ssh )
   9 import Darcs.External
  10 import Printer
  11 \end{code}
  12
  13 This module is used by the push and put commands to apply the a bundle to a
  14 remote repository. By remote I do not necessarily mean a repository on another
  15 machine, it is just not the repository we're located in.
  16
  17 \begin{code}
  18 remote_apply :: [DarcsFlag] -> String -> Doc -> IO ExitCode
  19 remote_apply opts repodir bundle
  20     = case apply_as opts of
  21         Nothing -> if is_ssh repodir
  22                    then apply_via_ssh opts repodir bundle
  23                    else if is_url repodir
  24                         then apply_via_url opts repodir bundle
  25                         else apply_via_local opts repodir bundle
  26         Just un -> if is_ssh repodir
  27                    then apply_via_ssh_and_sudo repodir un bundle
  28                    else apply_via_sudo un repodir bundle
  29
  30 apply_as :: [DarcsFlag] -> Maybe String
  31 apply_as (ApplyAs user:_) = Just user
  32 apply_as (_:fs) = apply_as fs
  33 apply_as [] = Nothing
  34 apply_via_sudo :: String -> String -> Doc -> IO ExitCode
  35 apply_via_sudo user repo bundle =
  36     pipeDoc "sudo" ["-u",user,"darcs","apply","--all","--repodir",repo] bundle
  37 apply_via_local :: [DarcsFlag] -> String -> Doc -> IO ExitCode
  38 apply_via_local opts repo bundle =
  39     pipeDoc "darcs" ("apply":"--all":"--repodir":repo:applyopts opts) bundle
  40
  41 apply_via_url :: [DarcsFlag] -> String -> Doc -> IO ExitCode
  42 apply_via_url opts repo bundle =
  43     do maybeapply <- maybeURLCmd "APPLY" repo
  44        case maybeapply of
  45          Nothing -> apply_via_local opts repo bundle
  46          Just apply ->
  47            do let (cmd, args) = breakCommand apply
  48               pipeDoc cmd (args ++ [repo]) bundle
  49
  50 apply_via_ssh :: [DarcsFlag] -> String -> Doc -> IO ExitCode
  51 apply_via_ssh opts repo bundle =
  52     pipeDocSSH addr ["darcs apply --all "++unwords (applyopts opts)++" --repodir '"++path++"'"] bundle
  53         where (addr,':':path) = break (==':') repo
  54
  55 apply_via_ssh_and_sudo :: String -> String -> Doc -> IO ExitCode
  56 apply_via_ssh_and_sudo repo username bundle =
  57     pipeDocSSH addr ["sudo -u "++username++
  58                          " darcs apply --all --repodir '"++path++"'"] bundle
  59         where (addr,':':path) = break (==':') repo
  60
  61 applyopts :: [DarcsFlag] -> [String]
  62 applyopts opts = if Debug `elem` opts then ["--debug"] else []
  63
  64 \end{code}