home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 3 / goldfish_volume_3.bin / files / dev / obero / oberon / projectoberonsrc / mailserver.mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1994-10-18  |  12.8 KB  |  362 lines
  1. Syntax10.Scn.Fnt
  2. MODULE MailServer;  (*NW 17.4.89 / 10.2.94*)
  3.     IMPORT SYSTEM, Core, Files, Texts, Oberon;
  4.     VAR W: Texts.Writer;
  5.         handler: Oberon.Task;
  6.         myadr: ARRAY 16 OF CHAR;
  7.     PROCEDURE Dispatch(F: Files.File; rno, sno, hdlen: INTEGER; bdypos: LONGINT;
  8.             VAR orig, head: ARRAY OF CHAR);
  9.     (*insert external message (from msg) in recipient rno's mail file*)
  10.         VAR i, j, k, h: INTEGER;
  11.             ch: CHAR; ok: BOOLEAN;
  12.             pos, L, bdylen, tm, dt: LONGINT;
  13.             fname: Core.Name;
  14.             MF: Files.File; (*destination*)
  15.             R, Q: Files.Rider;
  16.             mrtab: Core.MResTab;
  17.             mdir: Core.MailDir;
  18.     BEGIN Core.GetFileName(rno, fname); MF := Files.Old(fname);
  19.         IF MF # NIL THEN
  20.             Files.Set(Q, MF, 0); Files.ReadBytes(Q, mrtab, 32);
  21.             Files.ReadBytes(Q, mdir, SIZE(Core.MailDir))
  22.         ELSE (*create new mailbox file*)
  23.             MF := Files.New(fname); Files.Set(Q, MF, 0);  Files.Register(MF);
  24.             mdir[0].next := 0; mrtab[0] := {4 .. 31}; i := 1;
  25.             REPEAT mrtab[i] := {0 .. 31}; INC(i) UNTIL i = 7;
  26.             mrtab[7] := {0 .. 29}; i := 0;
  27.             REPEAT mdir[i].len := 0; INC(i) UNTIL i = 31
  28.         END ;
  29.         Files.Set(R, F, bdypos);
  30.         IF bdypos > 0 THEN  (*find length of body*)
  31.             Files.ReadInt(R, k); Files.ReadLInt(R, bdylen)
  32.         ELSE bdylen := Files.Length(F)
  33.         END ;
  34.         ok := FALSE; i := 0;
  35.         REPEAT INC(i) UNTIL (i = 31) OR (mdir[i].len = 0);
  36.         IF i < 31 THEN  (*free slot found, now find free blocks in file*)
  37.             j := -1;
  38.             REPEAT INC(j);
  39.                 IF j MOD 32 IN mrtab[j DIV 32] THEN
  40.                     h := j; k := SHORT((bdylen + hdlen + 255) DIV 256) + j;
  41.                     LOOP INC(h);
  42.                         IF h = k THEN ok := TRUE; EXIT END ;
  43.                         IF (h = 256) OR ~(h MOD 32 IN mrtab[h DIV 32]) THEN j := h; EXIT END
  44.                     END
  45.                 END
  46.             UNTIL ok OR (j >= 255)
  47.         END ;
  48.         IF ok THEN (*insert msg in blocks j .. k-1*)
  49.             pos := LONG(j) * 256; mdir[i].pos := j;
  50.             REPEAT EXCL(mrtab[j DIV 32], j MOD 32); INC(j) UNTIL j = k;
  51.             mdir[i].len := bdylen + hdlen;
  52.             Oberon.GetClock(tm, dt);
  53.             mdir[i].time := SHORT(tm DIV 2); mdir[i].date := SHORT(dt);
  54.             j := 0;
  55.             WHILE (j < 19) & (orig[j] > " ") DO mdir[i].originator[j] := orig[j]; INC(j) END ;
  56.             mdir[i].originator[j] := 0X;
  57.             mdir[i].next := mdir[0].next; mdir[0].next := i;
  58.             Files.Set(Q, MF, 0); Files.WriteBytes(Q, mrtab, 32);
  59.             Files.WriteBytes(Q, mdir, SIZE(Core.MailDir)); Files.Set(Q, MF, pos);
  60.             j := 0;
  61.             WHILE j < hdlen DO Files.Write(Q, SYSTEM.ROT(head[j], 5)); INC(j) END ;
  62.             L := bdylen;
  63.             WHILE L > 0 DO Files.Read(R, ch); Files.Write(Q, SYSTEM.ROT(ch, 5)); DEC(L) END ;
  64.             L := (-Files.Pos(Q)) MOD 256;
  65.             WHILE L > 0 DO Files.Write(Q, 0); DEC(L) END ;
  66.             Files.Close(MF)
  67.         ELSIF (rno # sno) & (sno > 0) & (rno > 0) THEN (*return to sender*)
  68.             Dispatch(F, sno, sno, hdlen, bdypos, orig, head)
  69.         ELSIF (rno # 0) & (sno # 0) THEN (*send to postmaster*)
  70.             Dispatch(F, 0, sno, hdlen, bdypos, orig, head)
  71.         END
  72.     END Dispatch;
  73.     PROCEDURE Encode(F0: Files.File; textpos: LONGINT;
  74.             VAR orig: Core.LongName; VAR recip, subj: ARRAY OF CHAR);
  75.     (*CX-400 encode message F0 and insert it in export queue*)
  76.         VAR ch: CHAR;
  77.             i, j: INTEGER;
  78.             tm, dt, p0, p1: LONGINT;
  79.             R, Q: Files.Rider; F1: Files.File;
  80.         PROCEDURE WC(n: LONGINT);
  81.         BEGIN Files.Write(Q, CHR(n))
  82.         END WC;
  83.         PROCEDURE WI(n: INTEGER);
  84.         BEGIN Files.WriteBytes(Q, n, 2)
  85.         END WI;
  86.         PROCEDURE WL(n: LONGINT);
  87.         BEGIN Files.WriteBytes(Q, n, 4)
  88.         END WL;
  89.     BEGIN F1 := Files.New(""); Files.Set(Q, F1, 0);
  90.         WI(4000H); WL(0);    (*MSG*)
  91.         WI(5000H); WL(0);    (*ENV*)
  92.         WI(1010H); WI(6);   (*MSGID*)
  93.         Oberon.GetClock(tm, dt); p0 := tm*dt; i := 0;
  94.         REPEAT WC(p0 MOD 10H + 41H); p0 := p0 DIV 10H; INC(i) UNTIL i = 6;
  95.         i := 0;
  96.         WHILE orig[i] > 0X DO INC(i) END ;
  97.         WI(1020H); WI(i+27);   (*ORIG*)
  98.         WI(2011H); WI(2020H); WI(2030H); WI(2041H); WI(3030H); WI(i+15);
  99.         j := 0;
  100.         WHILE j < i DO Files.Write(Q, orig[j]); INC(j) END ;
  101.         j := 0;
  102.         REPEAT Files.Write(Q, myadr[j]); INC(j) UNTIL j = 15;
  103.         i := 0;
  104.         LOOP (*recipients*) j := i;
  105.             WHILE recip[j] > 1X DO INC(j) END ;
  106.             IF i = j THEN EXIT END ;
  107.             WI(1031H); WI(j-i+12);   (*RECIP*)
  108.             WI(ORD(recip[j])+2010H); WI(2020H); WI(2030H); WI(2041H); WI(3030H); WI(j-i);
  109.             WHILE i < j DO Files.Write(Q, recip[i]); INC(i) END ;
  110.             INC(i)
  111.         END ;
  112.         i := 0; j := 0;
  113.         WHILE subj[j] > 0X DO INC(j) END ;
  114.         WI(1060H); WI(j);   (*SUBJ*)
  115.         WHILE i < j DO Files.Write(Q, subj[i]); INC(i) END ;
  116.         WI(1090H); WI(6);   (*SUBM*)
  117.         WC(dt DIV 200H); WC(dt DIV 20H MOD 10H); WC(dt MOD 20H);
  118.         WC(tm DIV 1000H); WC(tm DIV 40H MOD 40H); WC(tm MOD 40H);
  119.         p0 := Files.Pos(Q);
  120.         WI(6020H); WL(Files.Length(F0) - textpos);   (*TEXT*)
  121.         Files.Set(R, F0, textpos); Files.Read(R, ch);
  122.         WHILE ~R.eof DO
  123.             IF ch >= 7FX THEN
  124.                 IF ch = "
  125. " THEN ch := "a"
  126.                 ELSIF ch = "
  127. " THEN ch := "o"
  128.                 ELSIF ch = "
  129. " THEN ch := "u"
  130.                 ELSIF ch = "
  131. " THEN ch := "A"
  132.                 ELSIF ch = "
  133. " THEN ch := "O"
  134.                 ELSIF ch = "
  135. " THEN ch := "U"
  136.                 ELSE ch := "?"
  137.                 END
  138.             END ;
  139.             Files.Write(Q, ch); Files.Read(R, ch)
  140.         END ;
  141.         p1 := Files.Pos(Q); Files.Set(Q, F1, 2);
  142.         WL(p1-6); WI(5000H); WL(p0-12);   (*fixup*)
  143.         Files.Close(F1);
  144.         Core.InsertTask(Core.LineQueue, F1, Oberon.User, -1);
  145.         Texts.Append(Oberon.Log, W.buf)
  146.     END Encode;
  147.     PROCEDURE Decode(F: Files.File; pos: LONGINT);
  148.     (*CX-400 decode message from mail rider MR and dispatch*)
  149.         CONST bufsize = 96; msgsize = 2048;
  150.         VAR i, x, len, mx, rx, rno: INTEGER;
  151.             list, broadcast: BOOLEAN; ch, mo, yr: CHAR;
  152.             length: LONGINT;
  153.             R: Files.Rider;
  154.             rtab: ARRAY 32 OF INTEGER;  (*table of recipients*)
  155.             buf, orig: ARRAY bufsize OF CHAR;
  156.             msg: ARRAY msgsize OF CHAR;  (*message header*)
  157.         PROCEDURE put(ch: CHAR);
  158.         BEGIN
  159.             IF mx < msgsize THEN msg[mx] := ch; INC(mx) END
  160.         END put;
  161.         PROCEDURE PutString(s: ARRAY OF CHAR);
  162.             VAR i: INTEGER; ch: CHAR;
  163.         BEGIN i := 0;
  164.             REPEAT ch := s[i]; INC(i); put(ch)
  165.             UNTIL ch <= " "
  166.         END PutString;
  167.         PROCEDURE PutInt(n: INTEGER);
  168.         BEGIN put(CHR(n DIV 10 + 30H)); put(CHR(n MOD 10 + 30H))
  169.         END PutInt;
  170.         PROCEDURE ReadORName(len: INTEGER; VAR buf: ARRAY OF CHAR; title: ARRAY OF CHAR);
  171.             VAR x, i, L: INTEGER; ch: CHAR;
  172.         BEGIN Files.ReadInt(R, x); list := x = 2011H;
  173.             Files.ReadInt(R, x); Files.ReadInt(R, x);
  174.             Files.ReadInt(R, x); Files.ReadInt(R, L);
  175.             Files.ReadInt(R, L); i := 0;
  176.             IF x = 2041H THEN
  177.                 PutString(title);
  178.                 WHILE i < L DO
  179.                     Files.Read(R, ch);
  180.                     IF i < bufsize THEN buf[i] := ch END ;
  181.                     INC(i); put(ch)
  182.                 END ;
  183.                 put(0DX)
  184.             ELSE
  185.                 WHILE i < L DO
  186.                     Files.Read(R, ch);
  187.                     IF i < bufsize THEN buf[i] := ch END ;
  188.                     INC(i)
  189.                 END ;
  190.             END ;
  191.             IF i >= bufsize THEN i := bufsize-1 END ;
  192.             buf[i] := 0X; DEC(len, L+12);
  193.             WHILE len > 0 DO Files.Read(R, ch); DEC(len) END
  194.         END ReadORName;
  195.     BEGIN Files.Set(R, F, pos); Files.ReadInt(R, x);
  196.         Files.ReadLInt(R, length); INC(pos, length+6);
  197.         IF x = 5000H THEN   (*ENV*)
  198.             mx := 0; rx := 0; broadcast := FALSE;
  199.             IF length > 40000 THEN length := 40000 END ;
  200.             LOOP
  201.                 IF Files.Pos(R) >= pos THEN EXIT END ;
  202.                 Files.ReadInt(R, x); Files.ReadInt(R, len);
  203.                 IF x = 1020H THEN  (*ORIG*)
  204.                     ReadORName(len, orig, "From: ")
  205.                 ELSIF x DIV 10H = 103H THEN  (*RECIP*)
  206.                     ReadORName(len, buf, "To: ");
  207.                     IF buf = "all@cs.inf.ethz.ch" THEN broadcast := TRUE
  208.                     ELSIF list THEN
  209.                         rno := Core.UserNum(buf);
  210.                         IF rno >= 0 THEN rtab[rx] := rno; INC(rx) END
  211.                     END
  212.                 ELSIF x DIV 10H = 106H THEN  (*SUBJ, TITLE*)
  213.                     PutString("Re: "); i := 0;
  214.                     WHILE i < len DO Files.Read(R, ch); put(ch); INC(i) END ;
  215.                     put(0DX)
  216.                 ELSIF x = 1090H THEN  (*SUBMI*)
  217.                     PutString("Submission: ");
  218.                     Files.Read(R, yr); Files.Read(R, mo); Files.Read(R, ch);
  219.                     PutInt(ORD(ch)); put("."); PutInt(ORD(mo)); put(".");
  220.                     PutInt(ORD(yr)); put(" ");
  221.                     Files.Read(R, ch); PutInt(ORD(ch)); put(":");
  222.                     Files.Read(R, ch); PutInt(ORD(ch)); put(":");
  223.                     Files.Read(R, ch); PutInt(ORD(ch)); put(0DX)
  224.                 ELSE Files.Set(R, F, Files.Pos(R) + len)  (*skip*)
  225.                 END
  226.             END ;
  227.             IF broadcast THEN (*broadcast*)
  228.                 i := 1; rno := Core.NofUsers();
  229.                 WHILE i < rno DO Dispatch(F, i, 0, mx, pos, orig, msg); INC(i) END
  230.             ELSIF rx = 0 THEN (*no valid recipient*) Dispatch(F, 0, -1, mx, pos, orig, msg)
  231.             ELSE i := 0;
  232.                 REPEAT x := rtab[i]; INC(i); Dispatch(F, x, -1, mx, pos, orig, msg) UNTIL i = rx
  233.             END
  234.         END
  235.     END Decode;
  236.     PROCEDURE Serve;
  237.         CONST L0 = 64; L1 = 1024;
  238.         VAR i, j, ex, sx, sno, rno, hdlen: INTEGER;
  239.             ch: CHAR; anyext: BOOLEAN;
  240.             pos, length, dt, tm: LONGINT;
  241.             F: Files.File; R: Files.Rider;
  242.             Id: Core.ShortName;
  243.             orig: Core.LongName;
  244.             head, recip, subj: ARRAY L0 OF CHAR;
  245.             extrecip: ARRAY L1 OF CHAR;
  246.         PROCEDURE Pair(ch: CHAR; x: LONGINT);
  247.         BEGIN head[j] := ch; INC(j);
  248.             head[j] := CHR(x DIV 10 + 30H); INC(j); head[j] := CHR(x MOD 10 + 30H); INC(j)
  249.         END Pair;
  250.     BEGIN
  251.         IF Core.MailQueue.n > 0 THEN
  252.             Core.GetTask(Core.MailQueue, F, Id, sno);
  253.             IF sno >= 0 THEN (*internal originator*)
  254.                 Core.GetUserName(sno, orig); Oberon.GetClock(tm, dt);
  255.                 COPY("From: ", head); i := 0; j := 6;
  256.                 WHILE orig[i] > 0X DO head[j] := orig[i]; INC(i); INC(j) END ;
  257.                 head[j] := 0DX; INC(j); head[j] := "A"; INC(j); head[j] := "t"; INC(j); head[j] := ":"; INC(j);
  258.                 Pair(" ", dt MOD 20H); Pair(".", dt DIV 20H MOD 10H); Pair(".", dt DIV 200H MOD 80H);
  259.                 Pair(" ", tm DIV 1000H MOD 20H); Pair(":", tm DIV 40H MOD 40H); Pair(":", tm MOD 40H);
  260.                 head[j] := 0DX; hdlen := j+1;
  261.                 Files.Set(R, F, 0); anyext := FALSE; ex := 0; sx := 0;
  262.                 LOOP (*next line*) pos := Files.Pos(R);
  263.                     REPEAT Files.Read(R, ch) UNTIL (ch > " ") OR R.eof;
  264.                     IF R.eof THEN EXIT END ;
  265.                     i := 0;
  266.                     REPEAT
  267.                         IF i < L0-1 THEN recip[i] := ch; INC(i) END ;
  268.                         Files.Read(R, ch)
  269.                     UNTIL ch <= ":";
  270.                     recip[i] := 0X;
  271.                     IF (recip # "To") & (recip # "cc") THEN EXIT END ;
  272.                     IF ch = ":" THEN Files.Read(R, ch) END ;
  273.                     LOOP (*next recipient*)
  274.                         WHILE ch = " " DO Files.Read(R, ch) END ;
  275.                         WHILE ch = "(" DO
  276.                             REPEAT Files.Read(R, ch) UNTIL (ch = ")") OR (ch < " ");
  277.                             IF ch = ")" THEN Files.Read(R, ch) END ;
  278.                             WHILE ch = " " DO Files.Read(R, ch) END
  279.                         END ;
  280.                         IF ch < " " THEN EXIT END ;
  281.                         i := 0;
  282.                         WHILE (ch > " ") & (ch # "@") DO
  283.                             IF i < L0-1 THEN recip[i] := ch; INC(i) END ;
  284.                             IF ex < L1-1 THEN extrecip[ex] := ch; INC(ex) END ;
  285.                             Files.Read(R, ch)
  286.                         END ;
  287.                         IF ch = "@" THEN (*external recipient*)
  288.                             REPEAT
  289.                                 IF ex < L1-1 THEN extrecip[ex] := ch; INC(ex) END ;
  290.                                 Files.Read(R, ch)
  291.                             UNTIL (ch <= " ") OR (ch = ",");
  292.                             extrecip[ex] := 1X; INC(ex); anyext := TRUE
  293.                         ELSE (*internal recipient*)
  294.                             recip[i] := 0X; extrecip[ex] := 0X; INC(ex);
  295.                             IF recip = "all" THEN rno := Core.NofUsers();
  296.                                 WHILE rno > 1 DO  (*exclude postmaster*)
  297.                                     DEC(rno); Dispatch(F, rno, 0, hdlen, 0, orig, head)
  298.                                 END
  299.                             ELSE rno := Core.UserNum(recip);
  300.                                 IF rno < 0 THEN rno := sno END ;
  301.                                 Dispatch(F, rno, sno, hdlen, 0, orig, head)
  302.                             END
  303.                         END ;
  304.                         IF ch = "," THEN Files.Read(R, ch) END
  305.                     END
  306.                 END ;
  307.                 IF anyext THEN
  308.                     IF recip = "Re" THEN
  309.                         Files.Read(R, ch);
  310.                         WHILE (ch >= " ") & (sx < L0-1) DO subj[sx] := ch; INC(sx); Files.Read(R, ch) END ;
  311.                         pos := Files.Pos(R)
  312.                     END ;
  313.                     subj[sx] := 0X; extrecip[ex] := 0X; Encode(F, pos, orig, extrecip, subj)
  314.                 END
  315.             ELSE (*external originator*)
  316.                 pos := 0;
  317.                 LOOP Files.Set(R, F, pos); Files.ReadInt(R, i);
  318.                     IF R.eof THEN EXIT END ;
  319.                     IF i = 4000H THEN  (*MSG*)
  320.                         Files.ReadLInt(R, length); INC(pos, 6); Decode(F, pos); INC(pos, length)
  321.                     ELSE Texts.WriteString(W, "message not fully decoded");
  322.                         Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); EXIT
  323.                     END
  324.                 END
  325.             END ;
  326.             Core.RemoveTask(Core.MailQueue)
  327.         END
  328.     END Serve;
  329.     (*------------------------ Commands --------------------------*)
  330.     PROCEDURE Start*;
  331.     BEGIN Oberon.Remove(handler); Oberon.Install(handler);
  332.         Texts.WriteString(W, "Mailer started  (NW 17.12.92)");
  333.         Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
  334.     END Start;
  335.     PROCEDURE State*;
  336.     BEGIN Texts.WriteString(W, "Mail queue:"); Texts.WriteInt(W, Core.MailQueue.n, 3);
  337.         Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
  338.     END State;
  339.     PROCEDURE Stop*;
  340.     BEGIN Oberon.Remove(handler); Texts.WriteString(W, "Mailer stopped");
  341.         Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
  342.     END Stop;
  343.     PROCEDURE RemoveMsg*;
  344.         VAR ch: CHAR;
  345.             F, G: Files.File; R, Q: Files.Rider;
  346.             id: Core.ShortName; uno: INTEGER;
  347.             S: Texts.Scanner;
  348.     BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
  349.         IF Core.MailQueue.n > 0 THEN
  350.             Core.GetTask(Core.MailQueue, F, id, uno); Files.Set(R, F, 0); Files.Read(R, ch);
  351.             G := Files.New(S.s); Files.Set(Q, G, 0);
  352.             WHILE ~R.eof DO Files.Write(Q, ch); Files.Read(R, ch) END ;
  353.             Files.Register(G); Core.RemoveTask(Core.MailQueue);
  354.             Texts.WriteString(W, S.s); Texts.WriteString(W, " saved")
  355.         ELSE Texts.WriteString(W, " MQ empty")
  356.         END ;
  357.         Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
  358.     END RemoveMsg;
  359. BEGIN Texts.OpenWriter(W);
  360.     myadr := "@cs.inf.ethz.ch"; NEW(handler); handler.handle := Serve
  361. END MailServer.
  362.