m3browser/src/TCPServer.m3


 Copyright (C) 1995, Digital Equipment Corporation             
 All rights reserved.                                          
 See the file COPYRIGHT for a full description.                
                                                               
 Last modified on Tue Mar  7 14:41:39 PST 1995 by kalsow       
                                                               
 Enhanced by Peter Klein (pk@i3.informatik.rwth-aachen.de) to  
 reject connections from outside this domain.  - Mar 7, 1995   

MODULE TCPServer;

IMPORT Text, Thread, Time, TCP, IP, ConnFD, Rd, Wr, Atom, AtomList;
IMPORT TCPPeer;
IMPORT HTTP, App;

REVEAL
  T = Thread.Closure BRANDED OBJECT
    workers   : REF ARRAY OF Thread.T := NIL;
    port      : TCP.Connector         := NIL;
    handler   : RequestHandler        := NIL;
    refresher : Refresher             := NIL;
    timeout   : Time.T                := 0.0d0;
    err_log   : ErrorLogger           := NIL;
    address   : IP.Address;
    maskBits  : [0 .. 32];
  OVERRIDES
    apply := Server;
  END;

TYPE
  TT = Thread.Closure OBJECT
    self: T := NIL;
  OVERRIDES
    apply := Refresh;
  END;
---------------------------------------------------- external interface ---

PROCEDURE Fork (socket    : CARDINAL;
                n_threads : CARDINAL;
                handler   : RequestHandler;
                refresher : Refresher;
                refresh_interval: Time.T;
                err_log   : ErrorLogger;
                address   : IP.Address := IP.NullAddress;
                maskBits  : [0 .. 32] := 0): T =

  VAR t := NEW (T);
  BEGIN
    IF (err_log = NIL) THEN err_log := DumpErr; END;
    t.workers   := NEW (REF ARRAY OF Thread.T, n_threads+1);
    t.handler   := handler;
    t.refresher := refresher;
    t.timeout   := refresh_interval;
    t.err_log   := err_log;
    t.address   := address;
    t.maskBits  := maskBits;

    (* open a TCP connection *)
    TRY
      t.port := TCP.NewConnector (IP.Endpoint {IP.GetHostAddr (), socket});
    EXCEPT IP.Error(ec) =>
      err_log ("cannot open TCP connection" & OSErr (ec));
      RETURN NIL;
    END;

    (* fire up the refresh thread *)
    IF (refresher # NIL) AND (refresh_interval > 0.0d0)
      THEN t.workers[0] := Thread.Fork (NEW (TT, self := t));
      ELSE t.workers[0] := NIL;
    END;

    (* fire up the server threads *)
    FOR i := 1 TO n_threads DO  t.workers[i] := Thread.Fork (t);  END;

    RETURN t;
  END Fork;

PROCEDURE Join (t: T) =
  VAR z: Thread.T;
  BEGIN
    IF (t = NIL) THEN RETURN END;
    FOR i := 0 TO LAST (t.workers^) DO
      z := t.workers [i];
      IF (z # NIL) THEN
        EVAL Thread.Join (z);
        t.workers[i] := NIL;
      END;
    END;
    IF (t.port # NIL) THEN
      (** TCP.CloseConnector (t.port); *** NOT YET IMPLEMENTED 2/8/95 ***)
      t.port := NIL;
    END;
  END Join;

PROCEDURE Abort (t: T) =
  BEGIN
    Alert (t);
    Join (t);
  END Abort;
------------------------------------------------- request server thread ---

PROCEDURE Server (closure: Thread.Closure): REFANY =
  CONST Second = 1000.0d0;
  VAR
    self    : T := closure;
    channel : TCP.T;
    len, j, n : INTEGER;
    request : TEXT;
    buf     : ARRAY [0..2047] OF CHAR;
  BEGIN
    TRY
      LOOP
        TRY
          request := ""; (* give the collector a chance while we wait... *)
          channel := TCP.Accept (self.port);
          TRY

            IF DomainOK (channel,self.address,self.maskBits) THEN
              (* read a new-line terminated request *)
              REPEAT
                len := channel.get (buf, 30.0d0 * Second);
                j := 0;  WHILE (j < len) AND (buf[j] # '\n') DO INC (j) END;
                request := request & Text.FromChars (SUBARRAY (buf, 0, j));
              UNTIL (j < len OR len = 0);

              (* recover escaped content *)
              TRY
                request := HTTP.UnescapeURLEntry(request, App.defaultLog);
              EXCEPT
                App.Error(e) =>
                request :=
                    "HTTP/1.0 400 Bad request: " & e & "\r\n";
                self.err_log("bad request from " & TCPPeer.GetName(channel));
              END;
              (* process it *)
              request := self.handler (self, request);
            ELSE
              request :=
                "HTTP/1.0 403 Service not available from outside, sorry\r\n";
              self.err_log("illegal request from " & TCPPeer.GetName(channel));
            END;

            (* send the reply *)
            len := Text.Length (request);
            j := 0;
            WHILE (j < len) DO
              n := MIN (NUMBER (buf), len-j);
              FOR k := 0 TO n-1 DO  buf[k] := Text.GetChar (request, k+j); END;
              channel.put (SUBARRAY (buf, 0, n));
              INC (j, NUMBER (buf));
            END;

          FINALLY
            TCP.Close (channel);
          END;
        EXCEPT
        | ConnFD.TimedOut =>
            self.err_log ("TCPServer: ConnFD.TimedOut => client is non-responsive");
        | IP.Error(ec) =>
            IF FatalError (self, ec, "IP.Error") THEN RETURN NIL; END;
        | Rd.Failure(ec) =>
            IF FatalError (self, ec, "Rd.Failure") THEN RETURN NIL; END;
        | Wr.Failure(ec) =>
            IF FatalError (self, ec, "Wr.Failure") THEN RETURN NIL; END;
        END;
      END;
    EXCEPT Thread.Alerted =>
      (* bail out... *)
      self.err_log ("TCPServer: server thread was alerted");
      Alert (self);
    END;
    RETURN NIL;
  END Server;

PROCEDURE DomainOK (channel: TCP.T; address: IP.Address; maskBits: [0 .. 32]):
    BOOLEAN RAISES {IP.Error} =
  BEGIN
    RETURN TCPPeer.Match (channel, address, maskBits);
  END DomainOK;

PROCEDURE FatalError (self: T;  ec: AtomList.T;  msg: TEXT): BOOLEAN =
  BEGIN
    self.err_log ("TCPServer: " & msg & OSErr (ec));
    IF (ec # NIL) THEN
      IF (ec.head = TCP.Refused)  THEN RETURN FALSE; END;
      IF (ec.head = TCP.Closed)   THEN RETURN FALSE; END;
      IF (ec.head = TCP.Timeout)  THEN RETURN FALSE; END;
      IF (ec.head = TCP.ConnLost) THEN RETURN FALSE; END;
    END;

    (* Don't know what's happening => bail out ... *)
    self.err_log ("TCPServer: aborting...");
    Alert (self);
    RETURN TRUE;
  END FatalError;
----------------------------------------------- periodic refresh thread ---

PROCEDURE Refresh (closure: Thread.Closure): REFANY =
  VAR tt: TT := closure;  self := tt.self;
  BEGIN
    TRY
      LOOP
        Thread.AlertPause (self.timeout);
        self.refresher (self);
      END;
    EXCEPT Thread.Alerted =>
      (* bail out... *)
      self.err_log ("TCPServer: refresh thread was alerted");
      Alert (self);
    END;
    RETURN NIL;
  END Refresh;
------------------------------------------------------------------ misc ---

PROCEDURE Alert (t: T) =
  VAR z: Thread.T;
  BEGIN
    IF (t = NIL) THEN RETURN END;
    FOR i := 0 TO LAST (t.workers^) DO
      z := t.workers[i];
      IF (z # NIL) THEN Thread.Alert (z); END;
    END;
  END Alert;

PROCEDURE OSErr (args: AtomList.T): TEXT =
  VAR msg : TEXT := NIL;
  BEGIN
    WHILE (args # NIL) DO
      IF (msg = NIL) THEN  msg := ": ";  ELSE  msg := msg & "  ***  ";  END;
      msg  := msg & Atom.ToText (args.head);
      args := args.tail;
    END;
    IF (msg = NIL) THEN msg := ": ** NO INFO **"; END;
    RETURN msg;
  END OSErr;

PROCEDURE DumpErr (<*UNUSED*> x: TEXT) =
  BEGIN
  END DumpErr;

BEGIN
END TCPServer.

interface TCPServer is in: