MODULEFSServer EXPORTSFSServer ,FSServerRep ; IMPORT AccessRules, AtomList, AuthMD5, ChannelMux, ClassDB, ClientClass, CVProto, ErrMsg, ExecRec, FileAttr, FileRd, Fmt, FS, Glob, GlobTree, IOWatchDog, IP, Logger, OSError, OSErrorPosix, Passwd, Pathname, Process, ProcTitle, RCSComp, RCSKeyword, Rd, Reaper, SigHandler, StreamRd, StreamWr, SupFileRec, SupFileRecSeq, SupMisc, TCPMisc, Text, Thread, Time, TokScan, TreeComp, Uerror, Unix, Usignal, Utypes, Version, WatchDog, Wr; IMPORT ConnRW; IMPORT Cerrno; IMPORT TCP; REVEAL T = Rep BRANDED OBJECT OVERRIDES init := Init; log := MasterLog; run := Run; END; CONST AccessFile = "cvsupd.access"; ClassFile = "cvsupd.class"; HaltFile = "cvsupd.HALT"; IdleTimeout = 15.0d0 * 60.0d0; MaxAccessFileAge = 3.0d0 * 60.0d0 * 60.0d0; MaxClassFileAge = 3.0d0 * 60.0d0 * 60.0d0; PasswdFile = "cvsupd.passwd"; S1GUrl = "http://www.cvsup.org/s1g/"; VAR (* CONST *) EagainAtom := OSErrorPosix.ErrnoAtom(Uerror.EAGAIN); VAR TheT: T := NIL; (* The one and only server object. *) Pid: Process.ID;
InitializePid
as late as possible, i.e., in theRun
procedure rather than inInit
. The pid can change betweenInit
andRun
, if the caller forks to become a daemon.
EXCEPTION ForkFailed(AtomList.T); PROCEDURE***************************************************************************Init (self: T; config: Configuration): T RAISES {Error} = BEGIN IF TheT # NIL THEN ErrMsg.Fatal("Cannot create multiple FSServer.Ts"); END; TheT := self; self.config := config; self.numSlots := MAX(config.maxChildren, 1); self.childPids := NEW(REF ARRAY OF Process.ID, self.numSlots); self.childAddrs := NEW(REF ARRAY OF IP.Address, self.numSlots); FOR i := 0 TO self.numSlots-1 DO self.childPids[i] := Process.NullID; self.childAddrs[i] := IP.NullAddress; END; IF config.localEndpoint.port = IP.NullPort THEN config.localEndpoint.port := SupMisc.Port; END; IF config.serverBase = NIL THEN config.serverBase := SupMisc.DefaultServerBase; END; IF config.serverCollDirs = NIL THEN config.serverCollDirs := SupMisc.DefaultServerCollDir; END; IF config.hiDataPort = IP.NullPort THEN config.hiDataPort := config.loDataPort; END; IF config.compLevel = -1 THEN config.compLevel := SupMisc.DefaultCompression; END; IF NOT SupMisc.IsDirectory(config.serverBase) THEN RAISE Error("Base directory \"" & config.serverBase & "\" does not exist"); END; TRY self.connector := TCP.NewConnector(config.localEndpoint); EXCEPT IP.Error(list) => RAISE Error("Listen failed: " & ErrMsg.StrError(list)); END; RETURN self; END Init; PROCEDURERun (self: T) RAISES {Error, Thread.Alerted} = VAR tcp0: TCP.T; id: CARDINAL := 0; childCl: SubProcess; accessPath := SupMisc.ResolvePath(self.config.serverBase, AccessFile); classDBPath := SupMisc.ResolvePath(self.config.serverBase, ClassFile); classDB: ClientClass.DB; accessRules: AccessRules.T; clientEndpoint: IP.Endpoint; errno: INTEGER; BEGIN self.startTime := Time.Now(); Pid := Process.GetMyID(); (* Install a signal handler to reap child processes that have finished. *) SigHandler.Register(Usignal.SIGCHLD, NEW(ChildHandler, server := self, apply := Reap)); self.log("CVSup server started"); self.log("Software version: " & Version.Name); self.log("Protocol version: " & Fmt.Int(CVProto.Current.major) & "." & Fmt.Int(CVProto.Current.minor)); self.log("Ready to service requests"); LOOP LOOP TRY tcp0 := TCPMisc.AcceptFrom(self.connector, clientEndpoint); EXIT; EXCEPT IP.Error(list) => IF ErrMsg.GetErrno(list, errno) THEN IF (errno = Uerror.ENFILE) OR (errno = Uerror.ECONNABORTED) OR (errno = Uerror.ECONNRESET) OR (errno = Uerror.ENOBUFS) THEN (* Warn and discard the aborted connection. *) self.log("Accept failed: " & ErrMsg.StrError(list), Logger.Priority.Warning); ELSE RAISE Error("Accept failed: " & ErrMsg.StrError(list)); END; ELSE RAISE Error("Accept failed: " & ErrMsg.StrError(list)); END; END; END; TRY TRY (* FIXME - If there are DNS problems, this can hold us up for a long time. *) accessRules := AccessRules.Get(accessPath, MaxAccessFileAge, self.config.logger); EXCEPT Rd.Failure(list) => RAISE Error("Read failure on \"" & accessPath & "\": " & ErrMsg.StrError(list)); END; TRY classDB := ClassDB.Get(classDBPath, MaxClassFileAge, self.config.logger); EXCEPT Rd.Failure(list) => RAISE Error("Read failure on \"" & classDBPath & "\": " & ErrMsg.StrError(list)); END; TRY IF self.config.maxChildren < 0 THEN (* We are running in foreground. We serve one client without forking, then quit. *) INC(self.numChildren); self.childPids[0] := Process.GetMyID(); self.childAddrs[0] := clientEndpoint.addr; childCl := NEW(SubProcess).init(self, self.numChildren, id, tcp0, clientEndpoint.addr, accessRules, classDB); EVAL childCl.apply(); EXIT; ELSE (* Normal daemon mode. *) VAR childPid: Utypes.pid_t; isChild := FALSE; slot := -1; BEGIN SigHandler.Block(); TRY (* Find a vacant slot for this child. *) FOR i := 0 TO self.numSlots-1 DO IF self.childPids[i] = Process.NullID THEN slot := i; EXIT; END; END; childPid := Fork(); INC(self.numChildren); IF childPid = 0 THEN isChild := TRUE; Pid := Process.GetMyID(); childPid := Pid; END; IF slot >= 0 THEN self.childPids[slot] := childPid; self.childAddrs[slot] := clientEndpoint.addr; END; FINALLY IF isChild THEN SigHandler.ShutDown(); ELSE SigHandler.Unblock(); END; END; IF isChild THEN TCP.CloseConnector(self.connector); childCl := NEW(SubProcess).init(self, self.numChildren, id, tcp0, clientEndpoint.addr, accessRules, classDB); EVAL childCl.apply(); Process.Exit(0); END; INC(id); END; END; EXCEPT | ForkFailed(l) => self.log("Could not fork: " & ErrMsg.StrError(l)); END; FINALLY TCP.Close(tcp0); END; END; END Run; PROCEDUREMasterLog (self: T; msg: TEXT; priority := Logger.Priority.Notice) = BEGIN IF self.config.logger # NIL THEN Logger.Put(self.config.logger, priority, msg); END; END MasterLog;
TYPE SubProcess = OBJECT parent: T; numChildren: CARDINAL; id: CARDINAL; clientAddr: IP.Address; accessRules: AccessRules.T; tcp0, tcp1, tcp2, tcp3: TCP.T := NIL; mux: ChannelMux.T := NIL; rdA, rdB, oldRdA: StreamRd.T := NIL; wrA, wrB, oldWrA: StreamWr.T := NIL; collections: SupFileRecSeq.T := NIL; reaper: Reaper.T := NIL; idleKiller: IdleKiller := NIL; proto: CVProto.T := NIL; claimedUser := "?"; (* User name from USER command. *) addrHost := "?"; (* Host name from reverse DNS, or IP addr. *) clientVersion := "."; clientClass: ClientClass.T := NIL; statsMsg := ""; doLogging := FALSE; authRequired := FALSE; passwdDB: Passwd.DB := NIL; passwd: Passwd.T := NIL; (* Password entry from auth, or NIL *) classDB: ClientClass.DB := NIL; METHODS init(parent: T; numChildren: CARDINAL; id: CARDINAL; tcp0: TCP.T; clientAddr: IP.Address; accessRules: AccessRules.T; classDB: ClientClass.DB): SubProcess := SubProcessInit; apply(): REFANY := ServeOne; log(msg: TEXT; flag := '='; priority := Logger.Priority.Notice) := SubProcessLog; END; PROCEDURE*** checkoutDate and checkoutTag aren't filled in, unfortunately.ServeOne (self: SubProcess): REFANY = VAR treeComp: TreeComp.T; treeCompThread: Thread.T; rcsComp: RCSComp.T; rcsCompThread: Thread.T; thread: Thread.T; retVal: REFANY; threadMsg: TEXT; BEGIN TRY TRY TurnOffNoDelay(self.tcp0); self.rdA := ConnRW.NewRd(self.tcp0); self.wrA := ConnRW.NewWr(self.tcp0); self.idleKiller := NEW(IdleKiller).init( sub := self, timeout := IdleTimeout); IOWatchDog.AddRd(self.idleKiller, self.rdA); IOWatchDog.AddWr(self.idleKiller, self.wrA); CheckShutdown(self); TRY self.passwdDB := Passwd.Open(SupMisc.ResolvePath( self.parent.config.serverBase, PasswdFile)); EXCEPT | OSError.E => (* Ignore *) | Passwd.Error(msg) => self.parent.log(msg, Logger.Priority.Warning); END; TRY CheckTooBusy(self); ShakeHands(self); Authorize(self); SetClientClass(self); (* CheckClassAccessLimits(self); FIXME: not yet *) FINALLY IF self.passwdDB # NIL THEN TRY Passwd.Close(self.passwdDB); EXCEPT ELSE END; self.passwdDB := NIL; END; END; ExchangeAttributeInfo(self); ExchangeCollectionInfo(self); EstablishDataConnection(self); FindScanFiles(self); self.reaper := NEW(Reaper.T).init(); treeComp := NEW(TreeComp.T).init( proto := self.proto, rd := self.rdA, wr := self.wrA, collections := self.collections, clientClass := self.clientClass, compLevel := self.parent.config.compLevel, reaper := self.reaper, logger := self.parent.config.logger); rcsComp := NEW(RCSComp.T).init( proto := self.proto, rd := self.rdB, wr := self.wrB, collections := self.collections, clientClass := self.clientClass, compLevel := self.parent.config.compLevel, reaper := self.reaper, logger := self.parent.config.logger); treeCompThread := Reaper.Fork(self.reaper, treeComp); rcsCompThread := Reaper.Fork(self.reaper, rcsComp); (* Wait until all the subthreads have finished, or until an error is returned from one of them. *) retVal := NIL; WHILE Reaper.JoinNext(self.reaper, thread, retVal) AND retVal = NIL DO (* Nothing *) END; GetStats(self); IF retVal # NIL THEN (* There was an error. *) threadMsg := retVal; IF thread = treeCompThread THEN Die(self, "TreeComp failed: " & threadMsg); ELSE <* ASSERT thread = rcsCompThread *> Die(self, "RCSComp failed: " & threadMsg); END; ELSE IF NOT Rd.EOF(self.rdA) THEN RAISE Error( "TreeComp protocol error: Expected EOF, didn't get it"); END; IF NOT Rd.EOF(self.rdB) THEN RAISE Error("RCSComp protocol error: Expected EOF, didn't get it"); END; Wr.Close(self.wrA); self.wrA := NIL; Wr.Close(self.wrB); self.wrB := NIL; IF self.oldRdA # NIL THEN IF NOT Rd.EOF(self.oldRdA) THEN RAISE Error( "ChannelMux protocol error: Expected EOF, didn't get it"); END; END; self.log(self.statsMsg & "Finished successfully", '-'); END; FINALLY ShutdownConnections(self); END; EXCEPT | Error(msg) => IF msg # NIL AND NOT Text.Empty(msg) THEN self.log(self.statsMsg & msg, '-'); END; | Rd.EndOfFile => self.log(self.statsMsg & "Premature EOF from client", '-'); | Rd.Failure(list) => self.log(self.statsMsg & "Network read failure: " & ErrMsg.StrError(list), '-'); | Thread.Alerted => self.log(self.statsMsg & "Interrupted"); | Wr.Failure(list) => self.log(self.statsMsg & "Network write failure: " & ErrMsg.StrError(list), '-'); END; RETURN NIL; END ServeOne; PROCEDURESubProcessInit (self: SubProcess; parent: T; numChildren: CARDINAL; id: CARDINAL; tcp0: TCP.T; clientAddr: IP.Address; accessRules: AccessRules.T; classDB: ClientClass.DB): SubProcess = BEGIN self.parent := parent; self.numChildren := numChildren; self.id := id; self.tcp0 := tcp0; self.clientAddr := clientAddr; self.accessRules := accessRules; self.classDB := classDB; RETURN self; END SubProcessInit; PROCEDURESubProcessLog (self: SubProcess; msg: TEXT; flag := '='; priority := Logger.Priority.Notice) = BEGIN IF self.doLogging AND self.parent.config.logger # NIL THEN Logger.Put(self.parent.config.logger, priority, Text.FromChar(flag) & Fmt.Int(self.id) & " " & msg); END; END SubProcessLog; PROCEDUREAllLingerOff (self: SubProcess) = BEGIN IF self.tcp0 # NIL THEN TRY TurnOffLinger(self.tcp0) EXCEPT Error => (* Ignore *) END; END; IF self.tcp1 # NIL THEN TRY TurnOffLinger(self.tcp1) EXCEPT Error => (* Ignore *) END; END; IF self.tcp2 # NIL THEN TRY TurnOffLinger(self.tcp2) EXCEPT Error => (* Ignore *) END; END; IF self.tcp3 # NIL THEN TRY TurnOffLinger(self.tcp3) EXCEPT Error => (* Ignore *) END; END; END AllLingerOff; PROCEDUREDie (self: SubProcess; msg: TEXT) = BEGIN (* Alert the subthreads in an effort to keep them from holding the readers and writers locked. Otherwise, the "GetStats" call could block. *) IF self.reaper # NIL THEN Reaper.AlertAll(self.reaper); END; AllLingerOff(self); GetStats(self); self.log(self.statsMsg & msg, '-'); Process.Exit(1); END Die; PROCEDUREGetStats (self: SubProcess) = VAR bytesIn, bytesOut: LONGREAL; sfr: SupFileRec.T; msg: TEXT; BEGIN IF Text.Empty(self.statsMsg) THEN (* Not already done. *) (* Stats by collection. *) IF self.collections # NIL THEN FOR i := 0 TO self.collections.size()-1 DO sfr := self.collections.get(i); LOCK sfr DO bytesIn := sfr.bytesIn; bytesOut := sfr.bytesOut; END; IF bytesIn # 0.0d0 OR bytesOut # 0.0d0 THEN msg := "[" & Fmt.LongReal(bytesIn / 1024.0d0, Fmt.Style.Fix, 0) & "Kin+" & Fmt.LongReal(bytesOut / 1024.0d0, Fmt.Style.Fix, 0) & "Kout]"; msg := msg & " " & sfr.collection & "/" & sfr.release;
IF SupFileRec.Option.CheckoutMode IN sfr.options THEN
IF NOT Text.Equal(sfr.checkoutTag, .
)
OR Text.Equal(sfr.checkoutDate, .
) THEN
msg := msg & tag=
& sfr.checkoutTag;
END;
IF NOT Text.Equal(sfr.checkoutDate, .
) THEN
msg := msg & date=
& sfr.checkoutDate;
END;
END;
***
self.log(msg, priority := Logger.Priority.Info); END; END; END; (* Totals. *) bytesIn := 0.0d0; bytesOut := 0.0d0; IF self.rdA # NIL THEN bytesIn := bytesIn + StreamRd.ByteCount(self.rdA); END; IF self.rdB # NIL THEN bytesIn := bytesIn + StreamRd.ByteCount(self.rdB); END; IF self.wrA # NIL THEN bytesOut := bytesOut + StreamWr.ByteCount(self.wrA); END; IF self.wrB # NIL THEN bytesOut := bytesOut + StreamWr.ByteCount(self.wrB); END; self.statsMsg := "[" & Fmt.LongReal(bytesIn / 1024.0d0, Fmt.Style.Fix, 0) & "Kin+" & Fmt.LongReal(bytesOut / 1024.0d0, Fmt.Style.Fix, 0) & "Kout] "; END; END GetStats; PROCEDUREShutdownConnections (self: SubProcess) RAISES {Thread.Alerted} =
Closes all the network connections, being careful to get it all done even if exceptions occur along the way.
BEGIN IF self.mux # NIL THEN ChannelMux.Close(self.mux) END; AllLingerOff(self); TRY IF self.oldWrA # NIL THEN TRY Wr.Close(self.oldWrA) EXCEPT Wr.Failure => (* Ignore *) END; END; FINALLY TRY IF self.wrA # NIL THEN TRY Wr.Close(self.wrA) EXCEPT Wr.Failure => (* Ignore *) END; END; FINALLY TRY IF self.wrB # NIL THEN TRY Wr.Close(self.wrB) EXCEPT Wr.Failure => (* Ignore *) END; END; FINALLY TRY IF self.oldRdA # NIL THEN TRY Rd.Close(self.oldRdA) EXCEPT Rd.Failure => (* Ignore *) END; END; FINALLY TRY IF self.rdA # NIL THEN TRY Rd.Close(self.rdA) EXCEPT Rd.Failure => (* Ignore *) END; END; FINALLY TRY IF self.rdB # NIL THEN TRY Rd.Close(self.rdB) EXCEPT Rd.Failure => (* Ignore *) END; END; FINALLY IF self.tcp0 # NIL THEN TCP.Close(self.tcp0) END; IF self.tcp1 # NIL THEN TCP.Close(self.tcp1) END; IF self.tcp2 # NIL THEN TCP.Close(self.tcp2) END; IF self.tcp3 # NIL THEN TCP.Close(self.tcp3) END; END; END; END; END; END; END; END ShutdownConnections;***************************************************************************
PROCEDUREAuthorize (self: SubProcess) RAISES {Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted, Wr.Failure} =
The exceptions Rd.EndOfFile, Rd.Failure, and Wr.Failure are raised only for the network connection.
VAR ts: TokScan.T; claimedHost: TEXT; loginMsg: TEXT; verMsg: TEXT; BEGIN TRY ts := self.proto.getCmd(self.rdA); ts.getFolded("USER"); self.claimedUser := ts.getToken("user ID"); (* Early clients didn't send the host name, so we have to be prepared for that. *) IF NOT ts.next(claimedHost) THEN claimedHost := NIL END; self.addrHost := GetHostName(self.clientAddr); IF self.proto.v.hasMD5Auth THEN DoMD5Auth(self); ELSE self.proto.putCmd(self.wrA, "OK"); Wr.Flush(self.wrA); END; (* If we reach this point, the user is going to get service. *) loginMsg := self.claimedUser & "@" & self.addrHost; IF self.passwd # NIL THEN (* We have an authenticated client. *) loginMsg := loginMsg & " <" & self.passwd.client & ">"; ELSIF claimedHost # NIL AND NOT TokScan.EqualFolded(claimedHost, self.addrHost) THEN loginMsg := loginMsg & " (" & claimedHost & ")"; END; verMsg := Fmt.Int(self.proto.major) & "." & Fmt.Int(self.proto.minor); IF self.proto.v.exchangesVersions THEN verMsg := self.clientVersion & "/" & verMsg; END; loginMsg := loginMsg & " [" & verMsg & "]"; self.doLogging := TRUE; self.log(loginMsg, '+'); IF TreeComp.traceLevel = 0 AND RCSComp.traceLevel = 0 THEN (* my m3gdb always crashes in setproctitle, so I don't do it if the -d or -t option are given (debug/trace) *) ProcTitle.Set(loginMsg); END; EXCEPT TokScan.Error(msg) => RAISE Error("Protocol error authorizing user: " & msg); END; END Authorize; PROCEDURE***************************************************************************DoMD5Auth (self: SubProcess) RAISES {Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted, TokScan.Error, Wr.Failure} = VAR ts: TokScan.T; realm := "."; serverChallenge := "."; serverResponse := "."; sharedSecret := "*"; client: TEXT; clientChallenge: TEXT; clientResponse: TEXT; errmsg: TEXT; BEGIN (* Since "self.doLogging" is still "FALSE" at this point, if we raise an exception it won't get logged. So we log the important ones ourselves. We log them as if they came from the master server, since an error at this point means the client session will not be established. *) TRY IF self.passwdDB # NIL THEN realm := Passwd.GetRealm(self.passwdDB); IF self.authRequired THEN serverChallenge := AuthMD5.GenChallenge(self.clientAddr, Passwd.GetPrivateKey(self.passwdDB)); END; END; self.proto.putCmd(self.wrA, "AUTHMD5", realm, serverChallenge); Wr.Flush(self.wrA); ts := self.proto.getCmd(self.rdA); ts.getFolded("AUTHMD5"); client := ts.getToken("client ID"); clientResponse := ts.getToken("client auth response"); clientChallenge := ts.getToken("client auth challenge"); ts.getEnd("end of AUTHMD5 command"); IF NOT Text.Equal(client, ".") AND self.passwdDB # NIL THEN self.passwd := Passwd.Lookup(self.passwdDB, client, self.parent.config.logger); IF self.passwd # NIL THEN sharedSecret := self.passwd.sharedSecret; END; END; IF self.authRequired THEN IF Text.Equal(sharedSecret, "*") OR NOT AuthMD5.CheckResponse(clientResponse, serverChallenge, sharedSecret) THEN self.proto.putCmd(self.wrA, "!", "Authentication failed"); Wr.Flush(self.wrA); errmsg := "Authentication failed: " & self.claimedUser & "@" & self.addrHost & " <" & client & ">"; self.parent.log(errmsg, Logger.Priority.Notice); RAISE Error(errmsg); END; END; IF NOT Text.Equal(clientChallenge, ".") AND NOT Text.Equal(sharedSecret, "*") THEN serverResponse := AuthMD5.GenResponse(clientChallenge, sharedSecret); END; self.proto.putCmd(self.wrA, "OK", serverResponse); Wr.Flush(self.wrA); EXCEPT Passwd.Error(msg) => self.parent.log(msg, Logger.Priority.Warning); RAISE Error(msg); END; END DoMD5Auth; PROCEDURECheckShutdown (self: SubProcess) RAISES {Error, Thread.Alerted, Wr.Failure} = VAR haltFile := SupMisc.ResolvePath(self.parent.config.serverBase, HaltFile); BEGIN TRY IF FS.Status(haltFile).modificationTime >= self.parent.startTime THEN SupMisc.PutCmd(self.wrA, "!", "Server is going down for maintenance"); Wr.Flush(self.wrA); RAISE Error("Connection rejected: shutting down"); END; EXCEPT OSError.E => (* Not shutting down. *) END; END CheckShutdown; PROCEDURECheckTooBusy (self: SubProcess) RAISES {Error, Thread.Alerted, Wr.Failure} = VAR checkResult: AccessRules.CheckResult; BEGIN IF self.parent.config.maxChildren >= 0 AND self.numChildren > self.parent.config.maxChildren THEN checkResult := AccessRules.CheckResult.TooMany; ELSE checkResult := AccessRules.Check(self.accessRules, self.clientAddr, self.parent.childAddrs^); END; CASE checkResult OF | AccessRules.CheckResult.OK => (* Do nothing. *) | AccessRules.CheckResult.AuthRequired => IF self.passwdDB = NIL THEN SupMisc.PutCmd(self.wrA, "!", "Access denied"); Wr.Flush(self.wrA); RAISE Error("Connection rejected: access denied"); END; self.authRequired := TRUE; | AccessRules.CheckResult.TooMany => SupMisc.PutCmd(self.wrA, "!", "Access limit exceeded; try again later"); Wr.Flush(self.wrA); RAISE Error("Connection rejected: access limit exceeded"); | AccessRules.CheckResult.Denied => SupMisc.PutCmd(self.wrA, "!", "Access denied"); Wr.Flush(self.wrA); RAISE Error("Connection rejected: access denied"); END; END CheckTooBusy; PROCEDURESetClientClass (self: SubProcess) = BEGIN self.clientClass := NIL; IF self.passwd # NIL AND NOT Text.Empty(self.passwd.class) THEN self.clientClass := self.classDB.getClass(self.passwd.class); (* XXX Log it if the class is not found *) END; IF self.clientClass = NIL THEN self.clientClass := self.classDB.getClass("default"); <* ASSERT self.clientClass # NIL *> END; END SetClientClass; PROCEDUREShakeHands (self: SubProcess) RAISES {Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted, Wr.Failure} = VAR ts: TokScan.T; clientMajor, clientMinor: CVProto.VersionNumber; BEGIN TRY SupMisc.PutCmd(self.wrA, "OK", Fmt.Int(CVProto.Current.major), Fmt.Int(CVProto.Current.minor), Version.Name, "CVSup server ready"); Wr.Flush(self.wrA); ts := TokScan.New(SupMisc.GetCmdLine(self.rdA)); ts.getFolded("PROTO"); clientMajor := ts.getInt("client protocol major version"); clientMinor := ts.getInt("client protocol minor version"); IF NOT ts.next(self.clientVersion) THEN self.clientVersion := "." END; TRY self.proto := CVProto.Resolve(clientMajor, clientMinor); (* Reject old clients that have the S1G bug. It causes them to detail every file, creating a heavy load on the server. *) IF CVProto.HasS1GBug(self.proto, self.clientVersion) THEN RAISE CVProto.NotSupported; END; EXCEPT CVProto.NotSupported => SupMisc.PutCmd(self.wrA, "!", "See " & S1GUrl & " for upgrading information"); Wr.Flush(self.wrA); RAISE Error("Client has S1G bug"); END; IF self.authRequired AND NOT self.proto.v.hasMD5Auth THEN SupMisc.PutCmd(self.wrA, "!", "Client does not support required authentication; upgrade to a " & "newer version"); Wr.Flush(self.wrA); RAISE Error("Client does not support required authentication"); END; SupMisc.PutCmd(self.wrA, "PROTO", Fmt.Int(self.proto.major), Fmt.Int(self.proto.minor)); Wr.Flush(self.wrA); EXCEPT | TokScan.Error(msg) => RAISE Error("Protocol error shaking hands: " & msg); END; END ShakeHands;
PROCEDURE***************************************************************************EstablishDataConnection (self: SubProcess) RAISES {Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted, Wr.Failure} = VAR ts: TokScan.T; cmd: TEXT; dataPeer: IP.Endpoint; here: IP.Endpoint; conn: TCP.Connector; id: ChannelMux.ChannelID; chan0, chan1: ChannelMux.Channel; BEGIN TRY here := GetSockName(self.tcp0); ts := self.proto.getCmd(self.rdA); cmd := ts.getToken("command"); IF TokScan.EqualFolded(cmd, "PORT") THEN (* Active mode *) dataPeer := ts.getEndpoint(); ts.getEnd(); (* We connect back from a specific port, namely, one less than the well-known port that listens for connections from clients. That makes it easier for firewalls to be set up to work with this package. *) DEC(here.port); self.tcp1 := ConnectFrom(to := dataPeer, from := here); TurnOffNoDelay(self.tcp1); self.rdB := ConnRW.NewRd(self.tcp1); IOWatchDog.AddRd(self.idleKiller, self.rdB); self.wrB := ConnRW.NewWr(self.tcp1); IOWatchDog.AddWr(self.idleKiller, self.wrB); ELSIF TokScan.EqualFolded(cmd, "SOCKS1") THEN (* Socks mode *) dataPeer := ts.getEndpoint(); ts.getEnd(); (* We establish three separate connections back to the client. Each will be used unidirectionally. That causes the SOCKS server to fork a new process for each connection, working around the fact that it uses nonblocking I/O calls. We initiate each connection from the same port, one less than our original listening port. *) DEC(here.port); self.tcp1 := ConnectFrom(to := dataPeer, from := here); ts := self.proto.getCmd(self.rdA); ts.getFolded("SOCKS2"); dataPeer := ts.getEndpoint(); ts.getEnd(); self.tcp2 := ConnectFrom(to := dataPeer, from := here); ts := self.proto.getCmd(self.rdA); ts.getFolded("SOCKS3"); dataPeer := ts.getEndpoint(); ts.getEnd(); self.tcp3 := ConnectFrom(to := dataPeer, from := here); (* We would like to do a "Wr.Close(self.wrA)" at this point, since we aren't going to use that direction any more. But that causes SOCKS to drop the entire connection. *) self.oldWrA := self.wrA; TurnOffNoDelay(self.tcp1); self.wrA := ConnRW.NewWr(self.tcp1); IOWatchDog.AddWr(self.idleKiller, self.wrA); TurnOffNoDelay(self.tcp2); self.rdB := ConnRW.NewRd(self.tcp2); IOWatchDog.AddRd(self.idleKiller, self.rdB); TurnOffNoDelay(self.tcp3); self.wrB := ConnRW.NewWr(self.tcp3); IOWatchDog.AddWr(self.idleKiller, self.wrB); ELSIF TokScan.EqualFolded(cmd, "PASV") THEN (* Passive mode *) conn := NewConnector(here.addr, self.parent.config.loDataPort, self.parent.config.hiDataPort); TRY self.tcp1 := Accept(self, conn, "PORT"); FINALLY TCP.CloseConnector(conn); END; TurnOffNoDelay(self.tcp1); self.rdB := ConnRW.NewRd(self.tcp1); IOWatchDog.AddRd(self.idleKiller, self.rdB); self.wrB := ConnRW.NewWr(self.tcp1); IOWatchDog.AddWr(self.idleKiller, self.wrB); ELSIF TokScan.EqualFolded(cmd, "MUX") THEN (* Multiplexed mode. *) TRY self.mux := ChannelMux.Open(self.rdA, self.wrA, chan0, active := FALSE); EXCEPT IP.Error(l) => RAISE Error("ChannelMux.Open failed: " & ErrMsg.StrError(l)); END; self.oldRdA := self.rdA; self.oldWrA := self.wrA; self.rdA := ConnRW.NewRd(chan0); IOWatchDog.AddRd(self.idleKiller, self.rdA); self.wrA := ConnRW.NewWr(chan0); IOWatchDog.AddWr(self.idleKiller, self.wrA); ts := self.proto.getCmd(self.rdA); ts.getFolded("CHAN"); id := ts.getInt("data channel ID"); ts.getEnd(); TRY chan1 := ChannelMux.Connect(self.mux, id); EXCEPT IP.Error(l) => RAISE Error("ChannelMux.Connect failed: " & ErrMsg.StrError(l)); END; self.rdB := ConnRW.NewRd(chan1); IOWatchDog.AddRd(self.idleKiller, self.rdB); self.wrB := ConnRW.NewWr(chan1); IOWatchDog.AddWr(self.idleKiller, self.wrB); ELSE RAISE TokScan.Error("Invalid command \"" & cmd & "\""); END; EXCEPT | TokScan.Error(msg) => RAISE Error("Protocol error establishing data connection: " & msg); END; END EstablishDataConnection;
PROCEDUREExchangeAttributeInfo (self: SubProcess) RAISES {Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted, Wr.Failure} =
The exceptions Rd.EndOfFile, Rd.Failure, and Wr.Failure are raised only for the network connection.
VAR ts: TokScan.T; count: INTEGER; tok: TEXT; BEGIN IF self.proto.v.hasFileAttrs THEN TRY self.proto.v.attrSupport := FileAttr.Supported; ts := self.proto.getCmd(self.rdA); ts.getFolded("ATTR"); count := ts.getInt("number of file types"); ts.getEnd("end of \"ATTR\" command"); FOR i := 0 TO count-1 DO ts := self.proto.getCmd(self.rdA); tok := ts.getToken("attrTypes"); ts.getEnd("end of attrTypes"); IF i < NUMBER(self.proto.v.attrSupport) THEN WITH as = self.proto.v.attrSupport[VAL(i, FileAttr.FileType)] DO as := as * FileAttr.DecodeAttrTypes(tok); END; END; END; ts := self.proto.getCmd(self.rdA); ts.getLiteral("."); ts.getEnd("end of \".\""); FOR i := count TO NUMBER(self.proto.v.attrSupport)-1 DO self.proto.v.attrSupport[VAL(i, FileAttr.FileType)] := FileAttr.AttrTypes{}; END; count := MIN(count, NUMBER(self.proto.v.attrSupport)); self.proto.putCmd(self.wrA, "ATTR", Fmt.Int(count)); FOR i := 0 TO count-1 DO WITH as = self.proto.v.attrSupport[VAL(i, FileAttr.FileType)] DO Wr.PutText(self.wrA, FileAttr.EncodeAttrTypes(as) & "\n"); END; END; self.proto.putCmd(self.wrA, "."); Wr.Flush(self.wrA); EXCEPT TokScan.Error(msg) => RAISE Error("Protocol error negotiating attribute support: " & msg); END; ELSE self.proto.v.attrSupport := FileAttr.Historical; END; END ExchangeAttributeInfo;***************************************************************************
TYPE CollDirsPredClosure = SupMisc.TextPredicateClosure OBJECT cl: ClientClass.T; METHODS OVERRIDES matches := CollDirAllowed; END; PROCEDURECollDirAllowed (self: CollDirsPredClosure; t: TEXT): BOOLEAN = BEGIN RETURN self.cl.inAllowedCollectionDirs(t); END CollDirAllowed; PROCEDUREExchangeCollectionInfo (self: SubProcess) RAISES {Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted, Wr.Failure} =
The exceptions Rd.EndOfFile, Rd.Failure, and Wr.Failure are raised only for the network connection.
VAR ts: TokScan.T; cmd: TEXT; sfr: SupFileRec.T; textPredCl := NEW(CollDirsPredClosure, cl := self.clientClass); BEGIN self.collections := NEW(SupFileRecSeq.T).init(); TRY (* Read all the supfile information from the client. *) LOOP ts := self.proto.getCmd(self.rdA); cmd := ts.getToken(); IF Text.Equal(cmd, ".") THEN EXIT END; IF NOT TokScan.EqualFolded(cmd, "COLL") THEN RAISE TokScan.Error("\"COLL\" expected"); END; sfr := NEW(SupFileRec.T).init(); sfr.collection := ts.getToken("collection"); sfr.release := ts.getToken("release"); IF self.proto.v.clientSendsUmask THEN sfr.umask := ts.getInt("umask", radix := 8); ELSE sfr.umask := 0; END; sfr.options := SupFileRec.DecodeOptions(ts.getToken("options")); LOOP ts := self.proto.getCmd(self.rdA); cmd := ts.getToken("command"); IF Text.Equal(cmd, ".") THEN EXIT END; IF TokScan.EqualFolded(cmd, "REF") THEN sfr.refusals.addhi(ts.getToken("refusal pattern")); ELSIF TokScan.EqualFolded(cmd, "ACC") THEN sfr.accepts.addhi(ts.getToken("acceptance pattern")); ELSE RAISE TokScan.Error( "Invalid command while exchanging collection info"); END; END; sfr.serverBase := self.parent.config.serverBase; sfr.serverCollDirs := SupMisc.FilterPathList(self.parent.config.serverCollDirs, textPredCl); IF TreeComp.traceLevel > 0 THEN self.log("collectionDirs: " & self.parent.config.serverCollDirs); self.log("filteredCollectionDirs: " & sfr.serverCollDirs); END; (* Set up a mask of file attribes that we don't want to sync to the client. *) IF NOT SupFileRec.Option.SetOwner IN sfr.options THEN sfr.attrIgnore := sfr.attrIgnore + FileAttr.AttrTypes{ FileAttr.AttrType.Owner, FileAttr.AttrType.Group }; END; IF NOT SupFileRec.Option.SetMode IN sfr.options THEN sfr.attrIgnore := sfr.attrIgnore + FileAttr.AttrTypes{ FileAttr.AttrType.Mode }; END; IF NOT SupFileRec.Option.SetFlags IN sfr.options THEN sfr.attrIgnore := sfr.attrIgnore + FileAttr.AttrTypes{ FileAttr.AttrType.Flags }; END; (* clear some options for restricted access to CVS repositories *) IF self.clientClass.collectionIsPartiallyHidden(sfr.collection) THEN self.log("clearing RCS options for partially hidden collection " & sfr.collection); sfr.options := sfr.options - SupFileRec.Options{SupFileRec.Option.CheckRCS, SupFileRec.Option.NoRCS, SupFileRec.Option.StrictCheckRCS}; END; IF self.parent.config.detailAllRCSFiles THEN sfr.options := sfr.options + SupFileRec.Options{SupFileRec.Option.DetailAllRCSFiles}; self.log("detailing all RCS files of collection " & sfr.collection); END; self.collections.addhi(sfr); END; (* Send back the filtering details, and construct our own filter. *) FOR i := 0 TO self.collections.size()-1 DO SendCollectionInfo(self, self.collections.get(i)); END; self.proto.putCmd(self.wrA, "."); Wr.Flush(self.wrA); EXCEPT TokScan.Error(msg) => RAISE Error("Protocol error exchanging collection info: " & msg); END; END ExchangeCollectionInfo; PROCEDURE***************************************************************************SendCollectionInfo (self: SubProcess; sfr: SupFileRec.T) RAISES {Thread.Alerted, Wr.Failure} = VAR releasesPath: Pathname.T; collCommandSent := FALSE; PROCEDURE PutCollCommand() RAISES {Thread.Alerted, Wr.Failure} = (* Yes, it is silly to use a nested procedure for this. But it seems to be necessary in order to work around a compiler bug when optimization is turned on. When I tried to use a simple flag, outside a nested procedure, the compiler apparently did some invalid constant lifting, and all use of the flag in the emitted code disappeared. So please leave this the way it is. I was using the SRC M3 compiler version 3.6, with the gcc-2.7.2 code generator when this problem occurred. John Polstra <jdp@polstra.com> 7 January 1997 *) BEGIN IF NOT collCommandSent THEN self.proto.putCmd(self.wrA, "COLL", sfr.collection, sfr.release, SupFileRec.EncodeOptions(sfr.options)); collCommandSent := TRUE; END; END PutCollCommand; BEGIN TRY TRY (* Validate the collection name. This is a security measure. The collection name is used to form a pathname to the configuration files, and we don't want any funny business involving ".." and such things. *) IF NOT Pathname.Valid(sfr.collection) OR Text.Empty(sfr.collection) OR Text.FindChar(sfr.collection, '/') >= 0 OR Text.FindChar(sfr.collection, '\\') >= 0 OR Text.Equal(sfr.collection, Pathname.Current) OR Text.Equal(sfr.collection, Pathname.Parent) THEN RAISE Error("Invalid collection \"" & sfr.collection & "\""); END; (* Parse the "releases" file. *) releasesPath := SupMisc.FindFile(sfr.serverBase, sfr.serverCollDirs, SupMisc.CatPath(sfr.collection, "releases")); IF releasesPath = NIL OR NOT (* we pretend not to know about collections that are hidden to specific clients here *) self.clientClass.inAllowedCollections(sfr.collection) THEN RAISE Error("Unknown collection \"" & sfr.collection & "\""); END; (* Skip the collection if it is partially hidden and the client has requested checkout mode. We don't support checkout mode for partially-hidden collections yet. *) IF SupFileRec.Option.CheckoutMode IN sfr.options AND self.clientClass.collectionIsPartiallyHidden(sfr.collection) THEN RAISE Error("Checkout mode not supported for partially-hidden" & " collection \"" & sfr.collection & "\""); END; (* Process the "releases" file. *) ParseReleasesFile(self, sfr, releasesPath); PutCollCommand(); self.proto.putCmd(self.wrA, "PRFX", sfr.keywordPrefix); (* Process the "CVSROOT/options" file, if any. *) SendOptionsInfo(self, sfr); (* Process the "list" file. *) SendListInfo(self, sfr); EXCEPT Error(msg) => (* Tell the client about the error. *) sfr.options := sfr.options + SupFileRec.Options{SupFileRec.Option.Skip}; PutCollCommand(); self.proto.putCmd(self.wrA, "!", msg); self.log(msg); END; FINALLY self.proto.putCmd(self.wrA, "."); END; END SendCollectionInfo; PROCEDUREParseReleasesFile (<*UNUSED*> self: SubProcess; sfr: SupFileRec.T; path: Pathname.T) RAISES {Error, Thread.Alerted} = VAR rd: Rd.T; foundRelease: BOOLEAN; rel, line, field, name, value: TEXT; ts, ts2: TokScan.T; BEGIN TRY TRY rd := FileRd.Open(path); EXCEPT OSError.E => (* FIXME - Check to make sure it's ENOENT. *) RAISE Error("Unknown collection \"" & sfr.collection & "\""); END; TRY foundRelease := FALSE; sfr.serverPrefix := NIL; sfr.serverListFile := NIL; LOOP TRY line := Rd.GetLine(rd) EXCEPT Rd.EndOfFile => EXIT END; ts := TokScan.New(line); rel := ts.getToken("release name"); IF Text.Equal(rel, sfr.release) THEN foundRelease := TRUE; WHILE ts.next(field) DO IF Text.FindChar(field, '=') >= 0 THEN ts2 := TokScan.New(field, SET OF CHAR{'='}); name := ts2.getToken("field name"); value := ts2.getToken("field value"); IF TokScan.EqualFolded(name, "list") THEN sfr.serverListFile := SupMisc.CatPath(SupMisc.PathPrefix(path), value); ELSIF TokScan.EqualFolded(name, "prefix") THEN sfr.serverPrefix := SupMisc.ResolvePath(sfr.serverBase, value); ELSIF TokScan.EqualFolded(name, "keywordprefix") THEN sfr.keywordPrefix := SupMisc.ResolvePath(sfr.serverBase, value); ELSIF TokScan.EqualFolded(name, "super") THEN sfr.superCollection := value; END; ELSE IF TokScan.EqualFolded(field, "norsync") THEN sfr.options := sfr.options + SupFileRec.Options{SupFileRec.Option.NoRsync}; ELSIF TokScan.EqualFolded(field, "nocheckrcs") THEN sfr.options := sfr.options - SupFileRec.Options{SupFileRec.Option.CheckRCS}; ELSIF TokScan.EqualFolded(field, "norcs") THEN sfr.options := sfr.options + SupFileRec.Options{SupFileRec.Option.NoRCS}; END; END; END; EXIT; END; END; FINALLY TRY Rd.Close(rd); EXCEPT Rd.Failure(list) => RAISE Error("Cannot close \"" & path & "\": " & ErrMsg.StrError(list)); END; END; IF NOT foundRelease THEN RAISE Error("Unknown release \"" & sfr.release & "\" for \"" & sfr.collection & "\""); END; IF sfr.serverListFile = NIL THEN RAISE TokScan.Error("Missing \"list\" specification for \"" & sfr.collection & "." & sfr.release & "\""); END; IF sfr.serverPrefix = NIL THEN sfr.serverPrefix := sfr.serverBase; END; (* If the prefix directory does not exist, just report that the collection/release is not available. *) TRY IF FS.Status(sfr.serverPrefix).type # FS.DirectoryFileType THEN OSErrorPosix.Raise0(Uerror.ENOTDIR); END; EXCEPT OSError.E(l) => IF l.head = EagainAtom THEN RAISE Error("Collection \"" & sfr.collection & "\" release \"" & sfr.release & "\" is temporarily unavailable"); ELSE RAISE Error("Collection \"" & sfr.collection & "\" release \"" & sfr.release & "\" is not available here"); END; END; IF sfr.keywordPrefix = NIL THEN sfr.keywordPrefix := sfr.serverPrefix; END; EXCEPT | Rd.Failure(list) => RAISE Error("Read error from \"" & path & "\": " & ErrMsg.StrError(list)); | TokScan.Error(msg) => RAISE Error("Parse error in \"" & path & "\": " & msg); END; END ParseReleasesFile; PROCEDURESendOptionsInfo (self: SubProcess; sfr: SupFileRec.T) RAISES {Error, Thread.Alerted, Wr.Failure} = VAR path := SupMisc.CatPath(sfr.serverPrefix, SupMisc.CVSOptions); rd: Rd.T; line: TEXT; lineNum := 0; ts: TokScan.T; cmd: TEXT; keyName: TEXT; aliasName: TEXT; args: TEXT; includeOnly: BOOLEAN; BEGIN TRY rd := FileRd.Open(path); EXCEPT OSError.E => (* No options file. *) RETURN; END; TRY TRY LOOP TRY line := Rd.GetLine(rd) EXCEPT Rd.EndOfFile => EXIT END; INC(lineNum); WITH pos = Text.FindChar(line, '#') DO IF pos >= 0 THEN line := Text.Sub(line, 0, pos) END; END; line := TokScan.Trim(line); IF NOT Text.Empty(line) THEN TRY ts := TokScan.New(line, SET OF CHAR{'='}); cmd := TokScan.Trim(ts.getToken("command")); IF TokScan.EqualFolded(cmd, "tag") THEN aliasName := TokScan.Trim(ts.getToken("alias name")); IF ts.next(keyName) THEN WITH pos = Text.FindChar(keyName, ',') DO (* Kludge. *) IF pos >= 0 THEN keyName := Text.Sub(keyName, 0, pos) END; END; keyName := TokScan.Trim(keyName); ELSE keyName := "Id"; END; IF self.proto.v.hasKeywordControl THEN TRY sfr.expander.alias(aliasName, keyName); self.proto.putCmd(self.wrA, "KEYALIAS", aliasName, keyName); EXCEPT RCSKeyword.Unknown => RAISE TokScan.Error("Unknown RCS keyword \"" & keyName & "\""); END; END; ELSIF TokScan.EqualFolded(cmd, "tagexpand") THEN args := TokScan.Trim(ts.getRest()); IF Text.Empty(args) THEN RAISE TokScan.Error("missing \"tagexpand\" arguments"); END; CASE Text.GetChar(args, 0) OF | 'e' => includeOnly := FALSE; | 'i' => includeOnly := TRUE; ELSE RAISE TokScan.Error( "\"tagexpand\" argument must begin with \"e\" or \"i\""); END; IF self.proto.v.hasKeywordControl THEN IF includeOnly THEN (* First, disable all keywords. *) sfr.expander.enableAll(enabled := FALSE); self.proto.putCmd(self.wrA, "KEYOFF", "."); ELSE (* First, enable all keywords. *) sfr.expander.enableAll(enabled := TRUE); self.proto.putCmd(self.wrA, "KEYON", "."); END; END; args := Text.Sub(args, 1); ts := TokScan.New(args, SET OF CHAR{','}); WHILE ts.next(keyName) DO keyName := TokScan.Trim(keyName); IF self.proto.v.hasKeywordControl THEN TRY IF includeOnly THEN (* Enable specific keyword. *) sfr.expander.enable(keyName, enabled := TRUE); self.proto.putCmd(self.wrA, "KEYON", keyName); ELSE (* Disable specific keyword. *) sfr.expander.enable(keyName, enabled := FALSE); self.proto.putCmd(self.wrA, "KEYOFF", keyName); END; EXCEPT RCSKeyword.Unknown => RAISE TokScan.Error("Unknown RCS keyword \"" & keyName & "\""); END; END; END; ELSE (* For now, we just ignore unrecognized commands. *) END; EXCEPT TokScan.Error(msg) => self.log(path & ":" & Fmt.Int(lineNum) & ": " & msg); END; END; END; FINALLY Rd.Close(rd); END; EXCEPT | Rd.Failure(l) => RAISE Error("Read error from \"" & path & "\": " & ErrMsg.StrError(l)); END; END SendOptionsInfo; PROCEDURESendListInfo (self: SubProcess; sfr: SupFileRec.T) RAISES {Error, Thread.Alerted, Wr.Failure} = VAR (* CONST *) NoWS := GlobTree.Not(GlobTree.Match("*[ \t\r\n]*")); VAR rd: Rd.T; line: TEXT; ts: TokScan.T; cmd: TEXT; pat: TEXT; dirUpgrade := GlobTree.False; fileUpgrade := GlobTree.False; dirAlways := GlobTree.False; fileAlways := GlobTree.False; dirAccept := GlobTree.True; fileAccept := GlobTree.True; dirRefuse := GlobTree.False; fileRefuse := GlobTree.False; omit := GlobTree.False; symlink := GlobTree.False; BEGIN TRY TRY rd := FileRd.Open(sfr.serverListFile); EXCEPT OSError.E(list) => RAISE Error("Cannot open \"" & sfr.serverListFile & "\": " & ErrMsg.StrError(list)); END; TRY LOOP TRY line := Rd.GetLine(rd) EXCEPT Rd.EndOfFile => EXIT END; ts := TokScan.New(line); IF ts.next(cmd) AND Text.GetChar(cmd, 0) # '#' THEN IF TokScan.EqualFolded(cmd, "upgrade") THEN pat := ts.getToken("pattern"); REPEAT dirUpgrade := GlobTree.Or(dirUpgrade, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname, Glob.MatchOption.LeadingDir, Glob.MatchOption.PrefixDirs })); fileUpgrade := GlobTree.Or(fileUpgrade, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname, Glob.MatchOption.LeadingDir })); IF self.proto.v.serverSendsFilter THEN self.proto.putCmd(self.wrA, "UPGR", pat); END; UNTIL NOT ts.next(pat); ELSIF TokScan.EqualFolded(cmd, "always") THEN pat := ts.getToken("pattern"); REPEAT dirAlways := GlobTree.Or(dirAlways, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname, Glob.MatchOption.LeadingDir, Glob.MatchOption.PrefixDirs })); fileAlways := GlobTree.Or(fileAlways, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname, Glob.MatchOption.LeadingDir })); IF self.proto.v.serverSendsFilter THEN self.proto.putCmd(self.wrA, "ALWS", pat); END; UNTIL NOT ts.next(pat); ELSIF TokScan.EqualFolded(cmd, "omitany") THEN pat := ts.getToken("pattern"); REPEAT omit := GlobTree.Or(omit, GlobTree.Match(pat)); IF self.proto.v.serverSendsFilter THEN self.proto.putCmd(self.wrA, "OANY", pat); END; UNTIL NOT ts.next(pat); ELSIF TokScan.EqualFolded(cmd, "symlink") THEN pat := ts.getToken("pattern"); REPEAT symlink := GlobTree.Or(symlink, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname })); UNTIL NOT ts.next(pat); ELSIF TokScan.EqualFolded(cmd, "rsymlink") THEN pat := ts.getToken("pattern"); REPEAT symlink := GlobTree.Or(symlink, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname, Glob.MatchOption.LeadingDir })); UNTIL NOT ts.next(pat); ELSIF TokScan.EqualFolded(cmd, "norsync") THEN pat := ts.getToken("pattern"); REPEAT sfr.noRsync := GlobTree.Or(sfr.noRsync, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname })); IF self.proto.v.hasRsyncFilter THEN self.proto.putCmd(self.wrA, "NORS", pat); END; UNTIL NOT ts.next(pat); ELSIF TokScan.EqualFolded(cmd, "rnorsync") THEN pat := ts.getToken("pattern"); REPEAT sfr.noRsync := GlobTree.Or(sfr.noRsync, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname, Glob.MatchOption.LeadingDir })); IF self.proto.v.hasRsyncFilter THEN self.proto.putCmd(self.wrA, "RNORS", pat); END; UNTIL NOT ts.next(pat); ELSIF TokScan.EqualFolded(cmd, "execute") THEN sfr.executes.addhi(ParseExec(ts.getRest())); END; END; END; IF FileAttr.AttrType.FileType IN self.proto.v.attrSupport[FileAttr.FileType.SymLink] THEN sfr.symlink := symlink; (* Symbolic links are supported. *) ELSE (* Follow all symbolic links. *) sfr.symlink := GlobTree.False; END; (* Build filters from the client's "accepts" and "refuses". This is a little bit tricky, because in checkout mode the client specifies the names of the checked-out files, not the RCS files that we deal with here on the server. *) IF sfr.accepts.size() > 0 THEN dirAccept := GlobTree.False; fileAccept := GlobTree.False; FOR i := 0 TO sfr.accepts.size()-1 DO pat := sfr.accepts.get(i); dirAccept := GlobTree.Or(dirAccept, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname, Glob.MatchOption.LeadingDir, Glob.MatchOption.PrefixDirs })); (* Regardless of whether we are in checkout mode, we want to accept the file if the unaltered pattern matches a leading directory of it. *) fileAccept := GlobTree.Or(fileAccept, GlobTree.Match(pat, Glob.MatchOptions{ Glob.MatchOption.Pathname, Glob.MatchOption.LeadingDir })); (* If we are in checkout mode, then we also want to accept the file if "<pattern>,v" matches it. *) IF SupFileRec.Option.CheckoutMode IN sfr.options THEN WITH len = Text.Length(pat) DO IF len = 0 OR Text.GetChar(pat, len-1) # '*' THEN (* Adding ",v" to the end would make a difference. *) fileAccept := GlobTree.Or(fileAccept, GlobTree.Match(pat & SupMisc.RCSSuffix, Glob.MatchOptions{ Glob.MatchOption.Pathname })); END; END; END; END; END; IF SupFileRec.Option.CheckoutMode IN sfr.options THEN (* We don't want the "CVSROOT" directory. *) dirRefuse := GlobTree.Or(dirRefuse, GlobTree.Match(SupMisc.CVSAdmin)); END; FOR i := 0 TO sfr.refusals.size()-1 DO pat := sfr.refusals.get(i); dirRefuse := GlobTree.Or(dirRefuse, GlobTree.Match(pat)); IF SupFileRec.Option.CheckoutMode IN sfr.options THEN (* We must modify the client-specified pattern so that it refers to the RCS file, rather than the checked-out file. *) WITH len = Text.Length(pat) DO IF len = 0 OR Text.GetChar(pat, len-1) # '*' THEN pat := pat & SupMisc.RCSSuffix; END; END; END; fileRefuse := GlobTree.Or(fileRefuse, GlobTree.Match(pat)); END; (* Now combine the filter pieces. *) (* Start with the files from "upgrade" lines on the server. *) sfr.dirFilter := dirUpgrade; sfr.fileFilter := fileUpgrade; (* Take out the files from "omitany" lines on the server. *) sfr.dirFilter := GlobTree.And(sfr.dirFilter, GlobTree.Not(omit)); sfr.fileFilter := GlobTree.And(sfr.fileFilter, GlobTree.Not(omit)); (* Add back the files from "always lines on the server. *) sfr.dirFilter := GlobTree.Or(sfr.dirFilter, dirAlways); sfr.fileFilter := GlobTree.Or(sfr.fileFilter, fileAlways); (* Restrict the files to those specified in client "accepts". *) sfr.dirFilter := GlobTree.And(sfr.dirFilter, dirAccept); sfr.fileFilter := GlobTree.And(sfr.fileFilter, fileAccept); (* Take out the files from client "refuse" files. *) sfr.dirFilter := GlobTree.And(sfr.dirFilter, GlobTree.Not(dirRefuse)); sfr.fileFilter := GlobTree.And(sfr.fileFilter, GlobTree.Not(fileRefuse)); (* If the client can't handle white space in file names, make sure we don't send him any. *) IF NOT self.proto.v.handlesWhiteSpace THEN sfr.dirFilter := GlobTree.And(sfr.dirFilter, NoWS); sfr.fileFilter := GlobTree.And(sfr.fileFilter, NoWS); END; FINALLY TRY Rd.Close(rd); EXCEPT Rd.Failure(list) => RAISE Error("Cannot close \"" & sfr.serverListFile & "\": " & ErrMsg.StrError(list)); END; END; EXCEPT | Rd.Failure(list) => RAISE Error("Read error from \"" & sfr.serverListFile & "\": " & ErrMsg.StrError(list)); | TokScan.Error(msg) => RAISE Error("Parse error in \"" & sfr.serverListFile & "\": " & msg); END; END SendListInfo; PROCEDUREParseExec (line: TEXT): ExecRec.T RAISES {TokScan.Error} = VAR cmdLim: INTEGER; patLim: INTEGER; patterns: TEXT; pattern: TEXT; command: TEXT; ts: TokScan.T; gt := GlobTree.False; BEGIN cmdLim := Text.FindChar(line, '('); IF cmdLim = -1 THEN RAISE TokScan.Error("\"(\" expected") END; command := TokScan.Trim(Text.Sub(line, 0, cmdLim)); IF Text.Empty(command) THEN RAISE TokScan.Error("Missing command for \"execute\""); END; patLim := Text.FindChar(line, ')', cmdLim+1); IF patLim = -1 THEN RAISE TokScan.Error("\")\" expected") END; patterns := Text.Sub(line, cmdLim+1, patLim-(cmdLim+1)); IF NOT Text.Empty(TokScan.Trim(Text.Sub(line, patLim+1))) THEN RAISE TokScan.Error("Unexpected garbage after \")\""); END; ts := TokScan.New(patterns); WHILE ts.next(pattern) DO gt := GlobTree.Or(gt, GlobTree.Match(pattern, Glob.MatchOptions{ Glob.MatchOption.Pathname })); END; RETURN NEW(ExecRec.T, pattern := gt, command := command); END ParseExec;
PROCEDURE***************************************************************************FindScanFiles (self: SubProcess) RAISES {Thread.Alerted} = CONST MaxNestedCollectionDepth = 100; VAR scanBase: Pathname.T; sfr, scanSFR: SupFileRec.T; newestTime: Time.T; scanPath, newestPath: Pathname.T; releasesPath: Pathname.T; super: TEXT; BEGIN IF self.parent.config.serverScanDir = NIL THEN (* Not using scan files. *) RETURN; END; scanBase := SupMisc.ResolvePath(self.parent.config.serverBase, self.parent.config.serverScanDir); FOR i := 0 TO self.collections.size()-1 DO sfr := self.collections.get(i); IF NOT SupFileRec.Option.Skip IN sfr.options THEN newestTime := -1.0d0; newestPath := NIL; (* Clone enough of the original SupFileRec to do what we need to do, but leave the checkout mode option turned off in the new copy. *) scanSFR := NEW(SupFileRec.T).init(); scanSFR.collection := sfr.collection; scanSFR.release := sfr.release; scanSFR.serverBase := sfr.serverBase; scanSFR.serverCollDirs := sfr.serverCollDirs; scanSFR.options := SupFileRec.Options{SupFileRec.Option.UseRelSuffix}; scanSFR.superCollection := sfr.superCollection; (* Find the newest scan file that covers this collection, searching from the current collection up through successive superset collections. We limit the number of levels we will search, to protect ourselves against loops in the superset specifications. *) FOR i := 1 TO MaxNestedCollectionDepth DO scanPath := SupMisc.CatPath(scanBase, SupMisc.CatPath(scanSFR.collection, SupMisc.StatusFileName(scanSFR))); TRY WITH t = FS.Status(scanPath).modificationTime DO IF t > newestTime THEN newestTime := t; newestPath := scanPath; END; END; EXCEPT OSError.E => (* Ignore. *) END; super := scanSFR.superCollection; IF super = NIL THEN EXIT END; (* Go up to the next super-collection and repeat. *) scanSFR := NEW(SupFileRec.T).init(); scanSFR.collection := super; scanSFR.release := sfr.release; scanSFR.serverBase := sfr.serverBase; scanSFR.serverCollDirs := sfr.serverCollDirs; scanSFR.options := SupFileRec.Options{SupFileRec.Option.UseRelSuffix}; releasesPath := SupMisc.FindFile(self.parent.config.serverBase, self.parent.config.serverCollDirs, SupMisc.CatPath(scanSFR.collection, "releases")); IF releasesPath = NIL THEN (* Super-collection doesn't exist. *) EXIT; END; TRY ParseReleasesFile(self, scanSFR, releasesPath); EXCEPT Error => (* Cannot parse super-collection. *) EXIT; END; END; sfr.serverScanFile := newestPath; END; END; END FindScanFiles;
PROCEDUREAccept (self: SubProcess; conn: TCP.Connector; cmd: TEXT): TCP.T RAISES {Error, Thread.Alerted, Wr.Failure} =
Sends the connector's endpoint with the command cmd
, and accepts
one connection from the peer.
VAR wd: WatchDog.T; epToks: ARRAY [0..4] OF TEXT; BEGIN TokScan.EncodeEndpoint(TCP.GetEndPoint(conn), epToks); self.proto.putCmd(self.wrA, cmd, epToks[0], epToks[1], epToks[2], epToks[3], epToks[4]); Wr.Flush(self.wrA); TRY wd := WatchDog.New(SupMisc.ListenTimeout); TRY RETURN TCP.Accept(conn); FINALLY WatchDog.Cancel(wd); END; EXCEPT | IP.Error(list) => RAISE Error("Accept failed: " & ErrMsg.StrError(list)); | Thread.Alerted => IF WatchDog.Expired(wd) THEN RAISE Error("Timed out waiting for connection from client"); ELSE RAISE Thread.Alerted; END; END; END Accept; PROCEDURE***************************************************************************ConnectFrom (to, from: IP.Endpoint): TCP.T RAISES {Error, Thread.Alerted} = BEGIN TRY RETURN TCPMisc.ConnectFrom(to := to, from := from); EXCEPT IP.Error(list) => RAISE Error("Connect failed: " & ErrMsg.StrError(list)); END; END ConnectFrom; PROCEDUREFork (): Utypes.pid_t RAISES {ForkFailed} = VAR childPid := Unix.fork(); BEGIN IF childPid = -1 THEN RAISE ForkFailed(AtomList.List1(OSErrorPosix.ErrnoAtom( Cerrno.GetErrno()))); END; RETURN childPid; END Fork; PROCEDUREGetHostName (addr: IP.Address): TEXT = VAR hostName: TEXT; BEGIN TRY hostName := IP.GetCanonicalByAddr(addr); EXCEPT IP.Error => hostName := NIL; END; IF hostName = NIL THEN hostName := Fmt.Int(addr.a[0]) & "." & Fmt.Int(addr.a[1]) & "." & Fmt.Int(addr.a[2]) & "." & Fmt.Int(addr.a[3]); END; RETURN hostName; END GetHostName; PROCEDUREGetSockName (tcp: TCP.T): IP.Endpoint RAISES {Error} = BEGIN TRY RETURN TCPMisc.GetSockName(tcp); EXCEPT IP.Error(list) => RAISE Error("GetSockName failed: " & ErrMsg.StrError(list)); END; END GetSockName; PROCEDURENewConnector (addr: IP.Address; loPort, hiPort: IP.Port): TCP.Connector RAISES {Error} = BEGIN TRY RETURN SupMisc.NewConnector(addr, loPort, hiPort); EXCEPT IP.Error(list) => RAISE Error("Listen failed: " & ErrMsg.StrError(list)); END; END NewConnector; PROCEDURETurnOffLinger (tcp: TCP.T) RAISES {Error} = BEGIN TRY TCPMisc.LingerOnClose(tcp, FALSE); EXCEPT IP.Error(list) => RAISE Error("Cannot turn off SO_LINGER: " & ErrMsg.StrError(list)); END; END TurnOffLinger; PROCEDURETurnOffNoDelay (tcp: TCP.T) RAISES {Error} = BEGIN TRY TCPMisc.CoalesceWrites(tcp, TRUE); EXCEPT IP.Error(list) => RAISE Error("Cannot turn off TCP_NODELAY: " & ErrMsg.StrError(list)); END; END TurnOffNoDelay;
TYPE IdleKiller = IOWatchDog.T OBJECT sub: SubProcess; METHODS init(sub: SubProcess; timeout: Time.T; pollInterval: Time.T := 60.0d0): IdleKiller := IdleKillerInit; OVERRIDES alert := IdleAlert; END; PROCEDUREIdleKillerInit (ik: IdleKiller; sub: SubProcess; timeout: Time.T; pollInterval: Time.T := 60.0d0): IdleKiller = BEGIN ik.sub := sub; EVAL IOWatchDog.T.init(ik, timeout, pollInterval); RETURN ik; END IdleKillerInit; PROCEDUREIdleAlert (ik: IdleKiller) = BEGIN ik.sub.log("[0Kin+0Kout] Inactivity timeout", '-'); EVAL Usignal.kill(Process.GetMyID(), Usignal.SIGALRM); END IdleAlert; BEGIN END FSServer.