{-# LANGUAGE CPP, ForeignFunctionInterface #-}moduleSsh(grabSSH,runSSH,getSSH,copySSH,copySSHs,SSHCmd(..),environmentHelpSsh,environmentHelpScp,environmentHelpSshPort)whereimportPreludehiding(lookup,catch)importqualifiedRatified(hGetContents)importSystem.Exit(ExitCode(..))importSystem.Environment(getEnv)#ifndef WIN32importSystem.Posix.Process(getProcessID)#elseimportDarcs.Utils(showHexLen)importData.Bits((.&.))importSystem.Random(randomIO)#endifimportSystem.IO(Handle,hPutStr,hPutStrLn,hGetLine,hClose,hFlush)importSystem.IO.Unsafe(unsafePerformIO)importSystem.Directory(doesFileExist,createDirectoryIfMissing)importControl.Monad(when)importSystem.Process(runInteractiveProcess)importData.Map(Map,empty,insert,lookup)importData.IORef(IORef,newIORef,readIORef,modifyIORef)importDarcs.SignalHandler(catchNonSignal)importDarcs.Utils(withCurrentDirectory,breakCommand,prettyException,catchall)importDarcs.Global(atexit,sshControlMasterDisabled,darcsdir,withDebugMode)importDarcs.Lock(withTemp,withOpenTemp,tempdir_loc,removeFileMayNotExist)importExec(exec,Redirects,Redirect(..),)importProgress(withoutProgress,debugMessage,debugFail,progressList)importqualifiedData.ByteStringasB(ByteString,hGet,writeFile,readFile)importqualifiedData.ByteString.Char8asBC(unpack)#include "impossible.h"{-# NOINLINE sshConnections #-}sshConnections::IORef(MapString(MaybeConnection))sshConnections=unsafePerformIO$newIORefemptydataConnection=C{inp::!Handle,out::!Handle,err::!Handle,deb::String->IO()}withSSHConnection::String->String->(Connection->IOa)->IOa->IOawithSSHConnectionrdarcsrepoidwithconnectionwithoutconnection=withoutProgress$docs<-readIORefsshConnectionsletuhost=takeWhile(/=':')repoidurl=cleanrepourlrepoidcaselookupurl(cs::MapString(MaybeConnection))ofJustNothing->withoutconnectionJust(Justc)->withconnectioncNothing->domc<-do(ssh,sshargs_)<-getSSHOnlySSHletsshargs=sshargs_++[uhost,rdarcs,"transfer-mode","--repodir",cleanrepodirrepoid]debugMessage$"ssh "++unwordssshargs(i,o,e,_)<-runInteractiveProcesssshsshargsNothingNothingl<-hGetLineoifl=="Hello user, I am darcs transfer mode"thenreturn()elsedebugFail"Couldn't start darcs transfer-mode on server"letc=C{inp=i,out=o,err=e,deb=\s->debugMessage("with ssh (transfer-mode) "++uhost++": "++s)}modifyIORefsshConnections(inserturl(Justc))return$Justc`catchNonSignal`\e->dodebugMessage$"Failed to start ssh connection:\n "++prettyExceptioneseverSSHConnectionrepoiddebugMessage$unlines$["NOTE: the server may be running a version of darcs prior to 2.0.0.","","Installing darcs 2 on the server will speed up ssh-based commands."]returnNothingmaybewithoutconnectionwithconnectionmcseverSSHConnection::String->IO()severSSHConnectionx=dodebugMessage$"Severing ssh failed connection to "++xmodifyIORefsshConnections(insert(cleanrepourlx)Nothing)cleanrepourl::String->Stringcleanrepourlzzz|take(lengthdd)zzz==dd=""wheredd=darcsdir++"/"cleanrepourl(z:zs)=z:cleanrepourlzscleanrepourl""=""cleanrepodir::String->Stringcleanrepodir=cleanrepourl.drop1.dropWhile(/=':')grabSSH::String->Connection->IOB.ByteStringgrabSSHxc=doletdir=drop1$dropWhile(/=':')xdd=darcsdir++"/"cleanzzz|take(lengthdd)zzz==dd=drop(lengthdd)zzzclean(_:zs)=cleanzsclean""=bug$"Buggy path in grabSSH: "++xfile=cleandirfailwithe=doseverSSHConnectionx-- hGetContents is ok here because we're-- only grabbing stderr, and we're also-- about to throw the contents.eee<-Ratified.hGetContents(errc)debugFail$e++" grabbing ssh file "++x++"\n"++eeedebc$"get "++filehPutStrLn(inpc)$"get "++filehFlush(inpc)l2<-hGetLine(outc)ifl2=="got "++filethendoshowlen<-hGetLine(outc)casereadsshowlenof[(len,"")]->B.hGet(outc)len_->failwith"Couldn't get length"elseifl2=="error "++filethendoe<-hGetLine(outc)casereadseof(msg,_):_->debugFail$"Error reading file remotely:\n"++msg[]->failwith"An error occurred"elsefailwith"Error"sshStdErrMode::IORedirectsshStdErrMode=withDebugMode$\amdebugging->return$ifamdebuggingthenAsIselseNullcopySSH::String->String->FilePath->IO()copySSHrdarcsuRawf=withSSHConnectionrdarcsuRaw(\c->grabSSHuRawc>>=B.writeFilef)$doletu=escape_dollaruRawstderr_behavior<-sshStdErrModer<-runSSHSCPu[][u,f](AsIs,AsIs,stderr_behavior)when(r/=ExitSuccess)$debugFail$"(scp) failed to fetch: "++uwhere{- '$' in filenames is troublesome for scp, for some reason.. -}escape_dollar::String->Stringescape_dollar=concatMaptrwheretr'$'="\\$"trc=[c]copySSHs::String->String->[String]->FilePath->IO()copySSHsrdarcsunsd=withSSHConnectionrdarcsu(\c->withCurrentDirectoryd$mapM_(\n->grabSSH(u++"/"++n)c>>=B.writeFilen)$progressList"Copying via ssh"ns)$doletpath=drop1$dropWhile(/=':')uhost=takeWhile(/=':')ucd="cd "++path++"\n"input=cd++(unlines$map("get "++)ns)withCurrentDirectoryd$withOpenTemp$\(th,tn)->withTemp$\sftpoutput->dohPutStrthinputhClosethstderr_behavior<-sshStdErrModer<-runSSHSFTPu[][host](Filetn,Filesftpoutput,stderr_behavior)letfiles=iflengthns>5then(take5ns)++["and "++(show(lengthns-5))++" more"]elsenshint=iftake1path=="~"then["sftp doesn't expand ~, use path/ instead of ~/path/"]else[]when(r/=ExitSuccess)$dooutputPS<-B.readFilesftpoutputdebugFail$unlines$["(sftp) failed to fetch files.","source directory: "++path,"source files:"]++files++["sftp output:",BC.unpackoutputPS]++hint-- ----------------------------------------------------------------------- older ssh helper functions-- ---------------------------------------------------------------------dataSSHCmd=SSH|SCP|SFTPinstanceShowSSHCmdwhereshowSSH="ssh"showSCP="scp"showSFTP="sftp"runSSH::SSHCmd->String->[String]->[String]->Redirects->IOExitCoderunSSHcmdremoteAddrpreArgspostArgsredirs=do(ssh,args)<-getSSHcmdremoteAddrexecssh(preArgs++args++postArgs)redirs-- | Return the command and arguments needed to run an ssh command-- along with any extra features like use of the control master.-- See 'getSSHOnly'getSSH::SSHCmd->String-- ^ remote path->IO(String,[String])getSSHcmdremoteAddr=do(ssh,ssh_args)<-getSSHOnlycmdcm_args<-ifsshControlMasterDisabledthenreturn[]elsedo-- control mastercmPath<-controlMasterPathremoteAddrhasLaunchedCm<-doesFileExistcmPathwhen(nothasLaunchedCm)$launchSSHControlMasterremoteAddrhasCmFeature<-doesFileExistcmPathreturn$ifhasCmFeaturethen["-o ControlPath="++cmPath]else[]letverbosity=casecmdofSCP->["-q"]-- (p)scp is the only one that recognises -q-- sftp and (p)sftp do not, and plink neither_->[]--return(ssh,verbosity++ssh_args++cm_args)-- | Return the command and arguments needed to run an ssh command.-- First try the appropriate darcs environment variable and SSH_PORT-- defaulting to "ssh" and no specified port.getSSHOnly::SSHCmd->IO(String,[String])getSSHOnlycmd=dossh_command<-getEnv(evarcmd)`catchall`return(showcmd)-- portport<-(portFlagcmd`fmap`getEnv"SSH_PORT")`catchall`return[]let(ssh,ssh_args)=breakCommandssh_command--return(ssh,ssh_args++port)whereevarSSH="DARCS_SSH"evarSCP="DARCS_SCP"evarSFTP="DARCS_SFTP"portFlagSSHx=["-p",x]portFlagSCPx=["-P",x]portFlagSFTPx=["-oPort="++x]environmentHelpSsh::([String],[String])environmentHelpSsh=(["DARCS_SSH"],["Repositories of the form [user@]host:[dir] are taken to be remote","repositories, which Darcs accesses with the external program ssh(1).","","The environment variable $DARCS_SSH can be used to specify an","alternative SSH client. Arguments may be included, separated by","whitespace. The value is not interpreted by a shell, so shell","constructs cannot be used; in particular, it is not possible for the","program name to contain whitespace by using quoting or escaping."])environmentHelpScp::([String],[String])environmentHelpScp=(["DARCS_SCP","DARCS_SFTP"],["When reading from a remote repository, Darcs will attempt to run","`darcs transfer-mode' on the remote host. This will fail if the","remote host only has Darcs 1 installed, doesn't have Darcs installed","at all, or only allows SFTP.","","If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).","The commands invoked can be customized with the environment variables","$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.","If the remote end allows only sftp, try setting DARCS_SCP=sftp."])environmentHelpSshPort::([String],[String])environmentHelpSshPort=(["SSH_PORT"],["If this environment variable is set, it will be used as the port","number for all SSH calls made by Darcs (when accessing remote","repositories over SSH). This is useful if your SSH server does not","run on the default port, and your SSH client does not support","ssh_config(5). OpenSSH users will probably prefer to put something","like `Host *.example.net Port 443' into their ~/.ssh/config file."])-- | Return True if this version of ssh has a ControlMaster feature-- The ControlMaster functionality allows for ssh multiplexinghasSSHControlMaster::BoolhasSSHControlMaster=unsafePerformIOhasSSHControlMasterIO-- Because of the unsafePerformIO above, this can be called at any-- point. It cannot rely on any state, not even the current directory.hasSSHControlMasterIO::IOBoolhasSSHControlMasterIO=do(ssh,_)<-getSSHOnlySSH-- If ssh has the ControlMaster feature, it will recognise the-- the -O flag, but exit with status 255 because of the nonsense-- command. If it does not have the feature, it will simply dump-- a help message on the screen and exit with 1.sx<-execssh["-O","an_invalid_command"](Null,Null,Null)casesxofExitFailure255->returnTrue_->returnFalse-- | Launch an SSH control master in the background, if available.-- We don't have to wait for it or anything.-- Note also that this will cleanup after itself when darcs exitslaunchSSHControlMaster::String->IO()launchSSHControlMasterrawAddr=whenhasSSHControlMaster$doletaddr=takeWhile(/=':')rawAddr(ssh,ssh_args)<-getSSHOnlySSHcmPath<-controlMasterPathaddrremoveFileMayNotExistcmPath-- -f : put ssh in the background once it succeeds in logging you in-- -M : launch as the control master for addr-- -N : don't run any commands-- -S : use cmPath as the ControlPath. Equivalent to -oControlPath=execssh(ssh_args++[addr,"-S",cmPath,"-N","-f","-M"])(Null,Null,AsIs)atexit$exitSSHControlMasteraddrreturn()-- | Tell the SSH control master for a given path to exit.exitSSHControlMaster::String->IO()exitSSHControlMasteraddr=do(ssh,ssh_args)<-getSSHOnlySSHcmPath<-controlMasterPathaddrexecssh(ssh_args++[addr,"-S",cmPath,"-O","exit"])(Null,Null,Null)return()-- | Create the directory ssh control master path for a given addresscontrolMasterPath::String-- ^ remote path (foo\@bar.com:file is ok; the file part with be stripped)->IOFilePathcontrolMasterPathrawAddr=doletaddr=takeWhile(/=':')rawAddrtmp<-(fmap(///".darcs")$getEnv"HOME")`catchall`tempdir_loc#ifdef WIN32r<-randomIOletsuffix=(showHexLen6(r.&.0xFFFFFF::Int))#elsesuffix<-show`fmap`getProcessID#endiflettmpDarcsSsh=tmp///"darcs-ssh"createDirectoryIfMissingTruetmpDarcsSshreturn$tmpDarcsSsh///addr++suffix(///)::FilePath->FilePath->FilePathd///f=d++"/"++f