Oberon/V2/Net

MODULE Net; (*NW 3.7.88 / 25.8.91*)
	IMPORT SCC, Files, Viewers, Texts, TextFrames, MenuViewers, Oberon;

	CONST PakSize = 512;
		T0 = 300; T1 = 1000; (*timeouts*)
			
		ACK = 10H; NAK = 25H; NPR = 26H; (*acknowledgements*)
		NRQ = 34H; NRS = 35H; (*name request, response*)
		SND = 41H; REC = 42H; MSG = 44H;

	VAR W: Texts.Writer;
		Server: Oberon.Task;
		head0, head1: SCC.Header;
		partner, dmy: ARRAY 8 OF CHAR;
		protected: BOOLEAN; (*write-protection*)

	PROCEDURE SetPartner(VAR name: ARRAY OF CHAR);
	BEGIN head0.dadr := head1.sadr; COPY(name, partner)
	END SetPartner;

	PROCEDURE Send(t: SHORTINT; L: INTEGER; VAR data: ARRAY OF CHAR);
	BEGIN head0.typ := t; head0.len := L; SCC.SendPacket(head0, data)
	END Send;

	PROCEDURE ReceiveHead(timeout: LONGINT);
		VAR time: LONGINT;
	BEGIN time := Oberon.Time() + timeout;
		LOOP SCC.ReceiveHead(head1);
			IF head1.valid THEN
				IF head1.sadr = head0.dadr THEN EXIT ELSE SCC.Skip(head1.len) END
			ELSIF Oberon.Time() >= time THEN head1.typ := -1; EXIT
			END
		END
	END ReceiveHead;

	PROCEDURE FindPartner(VAR name: ARRAY OF CHAR; VAR res: INTEGER);
		VAR time: LONGINT; k: INTEGER;
	BEGIN SCC.Skip(SCC.Available()); res := 0;
		IF name # partner THEN k := 0;
			WHILE name[k] > 0X DO INC(k) END ;
			head0.dadr := -1; Send(NRQ, k+1, name); time := Oberon.Time() + T1;
			LOOP SCC.ReceiveHead(head1);
				IF head1.valid THEN
					IF head1.typ = NRS THEN SetPartner(name); EXIT
					ELSE SCC.Skip(head1.len)
					END
				ELSIF Oberon.Time() >= time THEN res := 1; partner[0] := 0X; EXIT
				END
			END
		END
	END FindPartner;

	PROCEDURE AppendS(VAR s, d: ARRAY OF CHAR; VAR k: INTEGER);
		VAR i: INTEGER; ch: CHAR;
	BEGIN i := 0;
		REPEAT ch := s[i]; d[k] := ch; INC(i); INC(k) UNTIL ch = 0X
	END AppendS;

	PROCEDURE AppendW(s: LONGINT; VAR d: ARRAY OF CHAR;
		n: INTEGER; VAR k: INTEGER);
		VAR i: INTEGER;
	BEGIN i := 0;
		REPEAT d[k] := CHR(s); s := s DIV 100H; INC(i); INC(k) UNTIL i = n
	END AppendW;

	PROCEDURE PickS(VAR s: ARRAY OF CHAR);
		VAR i: INTEGER; ch: CHAR;
	BEGIN i := 0;
		REPEAT SCC.Receive(ch); s[i] := ch; INC(i) UNTIL ch = 0X
	END PickS;

	PROCEDURE PickQ(VAR w: LONGINT);
		VAR c0, c1, c2: CHAR; s: SHORTINT;
	BEGIN SCC.Receive(c0); SCC.Receive(c1); SCC.Receive(c2); SCC.Receive(s);
		w := s; w := ((w * 100H + LONG(c2)) * 100H + LONG(c1)) * 100H + LONG(c0)
	END PickQ;

	PROCEDURE SendData(F: Files.File);
		VAR k: INTEGER;
			seqno: SHORTINT; x: CHAR;
			len: LONGINT;
			R: Files.Rider;
			buf: ARRAY PakSize OF CHAR;
	BEGIN Files.Set(R, F, 0); len := 0; seqno := 0;
		LOOP k := 0;
			LOOP Files.Read(R, x);
				IF R.eof THEN EXIT END ;
				buf[k] := x; INC(k);
				IF k = PakSize THEN EXIT END
			END ;
			REPEAT Send(seqno, k, buf); ReceiveHead(T1)
			UNTIL head1.typ # seqno + ACK;
			seqno := (seqno + 1) MOD 8; len := len + k;
			IF head1.typ # seqno + ACK THEN
				Texts.WriteString(W, " failed"); EXIT
			END ;
			IF k < PakSize THEN EXIT END
		END ;
		Texts.WriteInt(W, len, 7)
	END SendData;

	PROCEDURE ReceiveData(F: Files.File; VAR done: BOOLEAN);
		VAR k, retry: INTEGER;
			seqno: SHORTINT; x: CHAR;
			len: LONGINT;
			R: Files.Rider;
	BEGIN Files.Set(R, F, 0); seqno := 0; len := 0; retry := 2;
		LOOP
			IF head1.typ = seqno THEN
				seqno := (seqno + 1) MOD 8; len := len + head1.len; retry := 2;
				Send(seqno + ACK, 0, dmy); k := 0;
				WHILE k < head1.len DO
					SCC.Receive(x); Files.Write(R, x); INC(k)
				END ;
				IF k < PakSize THEN done := TRUE; EXIT END
			ELSE DEC(retry);
				IF retry = 0 THEN
					Texts.WriteString(W, " failed"); done := FALSE; EXIT
				END ;
				Send(seqno + ACK, 0, dmy)
			END ;
			ReceiveHead(T0)
		END ;
		Texts.WriteInt(W, len, 7)
	END ReceiveData;

	PROCEDURE reply(msg: INTEGER);
	BEGIN
		CASE msg OF
			0:
			| 1: Texts.WriteString(W, " no link")
			| 2: Texts.WriteString(W, " no permission")
			| 3: Texts.WriteString(W, " not done")
			| 4: Texts.WriteString(W, " not found")
			| 5: Texts.WriteString(W, " no response")
		END ;
		Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
	END reply;

	PROCEDURE* Serve;
		VAR i: INTEGER;
			done: BOOLEAN; ch: CHAR;
			F: Files.File;
			pw: LONGINT;
			Id: ARRAY 10 OF CHAR;
			FileName: ARRAY 32 OF CHAR;
	BEGIN SCC.ReceiveHead(head1);
		IF head1.valid THEN
			IF head1.typ = SND THEN
				PickS(Id); PickQ(pw); PickS(FileName);
				Texts.WriteString(W, Id); Texts.Write(W, " "); Texts.WriteString(W, FileName);
				F := Files.Old(FileName);
				IF F # NIL THEN
					Texts.WriteString(W, " sending"); SetPartner(Id);
					Texts.Append(Oberon.Log, W.buf); SendData(F)
				ELSE Send(NAK, 0, dmy); Texts.Write(W, "~")
				END ;
				reply(0)
			ELSIF head1.typ = REC THEN
				PickS(Id); PickQ(pw); PickS(FileName);
				IF ~protected THEN
					Texts.WriteString(W, Id); Texts.Write(W, " "); Texts.WriteString(W, FileName);
					F := Files.New(FileName);
					IF F # NIL THEN
						Texts.WriteString(W, " receiving"); SetPartner(Id);
						Texts.Append(Oberon.Log, W.buf);
						Send(ACK, 0, dmy); ReceiveHead(T0); ReceiveData(F, done);
						IF done THEN Files.Register(F) END
					ELSE Send(NAK, 0, dmy); Texts.Write(W, "~")
					END ;
					reply(0)
				ELSE Send(NPR, 0, dmy)
				END
			ELSIF head1.typ = MSG THEN i := 0;
				WHILE i < head1.len DO SCC.Receive(ch); Texts.Write(W, ch); INC(i) END ;
				Send(ACK, 0, dmy); reply(0)
			ELSIF head1.typ = NRQ THEN i := 0;
				LOOP SCC.Receive(ch); Id[i] := ch; INC(i);
					IF ch = 0X THEN EXIT END ;
					IF i = 7 THEN Id[7] := 0X; EXIT END
				END ;
				WHILE i < head1.len DO SCC.Receive(ch); INC(i) END ;
				IF Id = Oberon.User THEN SetPartner(Id); Send(NRS, 0, dmy) END
			ELSE SCC.Skip(head1.len)
			END
		END
	END Serve;

	PROCEDURE GetPar1(VAR S: Texts.Scanner);
	BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S)
	END GetPar1;

	PROCEDURE GetPar(VAR S: Texts.Scanner; VAR end: LONGINT);
		VAR T: Texts.Text; beg, tm: LONGINT;
	BEGIN Texts.Scan(S);
		IF (S.class = Texts.Char) & (S.c = "^") THEN
			Oberon.GetSelection(T, beg, end, tm);
			IF tm >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
		ELSE end := Oberon.Par.text.len
		END
	END GetPar;

	PROCEDURE SendFiles*;
		VAR k: INTEGER;
			end: LONGINT;
			S: Texts.Scanner;
			F: Files.File;
			name: ARRAY 32 OF CHAR;
			buf: ARRAY 64 OF CHAR;
	BEGIN GetPar1(S);
		IF S.class = Texts.Name THEN
			FindPartner(S.s, k);
			IF k = 0 THEN
				GetPar(S, end);
				LOOP
					IF S.class # Texts.Name THEN EXIT END ;
					Texts.WriteString(W, S.s); k := 0; AppendS(S.s, name, k);
					IF S.nextCh = ":" THEN (*prefix*)
						Texts.Scan(S); Texts.Scan(S);
						IF S.class = Texts.Name THEN
							name[k-1] := "."; AppendS(S.s, name, k);
							Texts.Write(W, ":"); Texts.WriteString(W, S.s)
						END
					END ;
					F := Files.Old(S.s);
					IF F # NIL THEN k := 0;
						AppendS(Oberon.User, buf, k); AppendW(Oberon.Password, buf, 4, k);
						AppendS(name, buf, k); Send(REC, k, buf); ReceiveHead(T0);
						IF head1.typ = ACK THEN
							Texts.WriteString(W, " sending"); Texts.Append(Oberon.Log, W.buf);
							SendData(F); reply(0)
						ELSIF head1.typ = NPR THEN reply(2); EXIT
						ELSIF head1.typ = NAK THEN reply(3); EXIT
						ELSE reply(5); EXIT
						END
					ELSE reply(4)
					END ;
					IF Texts.Pos(S) >= end THEN EXIT END ;
					Texts.Scan(S)
				END
			ELSE reply(1)
			END
		END
	END SendFiles;

	PROCEDURE ReceiveFiles*;
		VAR k: INTEGER; done: BOOLEAN;
			end: LONGINT;
			S: Texts.Scanner;
			F: Files.File;
			name: ARRAY 32 OF CHAR;
			buf: ARRAY 64 OF CHAR;
	BEGIN GetPar1(S);
		IF S.class = Texts.Name THEN
			FindPartner(S.s, k);
			IF k = 0 THEN
				GetPar(S, end);
				LOOP
					IF S.class # Texts.Name THEN EXIT END ;
					Texts.WriteString(W, S.s); k := 0; AppendS(S.s, name, k);
					IF S.nextCh = ":" THEN (*prefix*)
						Texts.Scan(S); Texts.Scan(S);
						IF S.class = Texts.Name THEN
							name[k-1] := "."; AppendS(S.s, name, k);
							Texts.Write(W, ":"); Texts.WriteString(W, S.s)
						END
					END ;
					k := 0; AppendS(Oberon.User, buf, k); AppendW(Oberon.Password, buf, 4, k);
					AppendS(name, buf, k); Send(SND, k, buf);
					Texts.WriteString(W, " receiving"); Texts.Append(Oberon.Log, W.buf);
					ReceiveHead(T1);
					IF head1.typ = 0 THEN
						F := Files.New(S.s);
						IF F # NIL THEN
							ReceiveData(F, done);
							IF done THEN Files.Register(F); reply(0) ELSE EXIT END
						ELSE reply(3); Send(NAK, 0, dmy)
						END
					ELSIF head1.typ = NAK THEN reply(4)
					ELSIF head1.typ = NPR THEN reply(2); EXIT
					ELSE reply(5); EXIT
					END ;
					IF Texts.Pos(S) >= end THEN EXIT END ;
					Texts.Scan(S)
				END
			ELSE reply(1)
			END
		END
	END ReceiveFiles;

	PROCEDURE SendMsg*;
		VAR i: INTEGER; ch: CHAR;
			S: Texts.Scanner;
			msg: ARRAY 64 OF CHAR;
	BEGIN GetPar1(S);
		IF S.class = Texts.Name THEN
			FindPartner(S.s, i);
			IF i = 0 THEN
				Texts.Read(S, ch);
				WHILE (ch >= " ") & (i < 64) DO
					msg[i] := ch; INC(i); Texts.Read(S, ch)
				END ;
				Send(MSG, i, msg); ReceiveHead(T0);
				IF head1.typ # ACK THEN reply(3) END
			ELSE reply(1)
			END
		END
	END SendMsg;

	PROCEDURE StartServer*;
	BEGIN protected := TRUE; SCC.Start(TRUE);
		Oberon.Remove(Server); Oberon.Install(Server);
		Texts.WriteString(W, " Server started");
		Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
	END StartServer;

	PROCEDURE Unprotect*;
	BEGIN protected := FALSE
	END Unprotect;

	PROCEDURE WProtect*;
	BEGIN protected := TRUE
	END WProtect;

	PROCEDURE Reset*;
	BEGIN SCC.Start(TRUE)
	END Reset;

	PROCEDURE StopServer*;
	BEGIN Oberon.Remove(Server); Texts.WriteString(W, " Server stopped");
		Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
	END StopServer;
	
BEGIN Texts.OpenWriter(W); NEW(Server); Server.handle := Serve
END Net.