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