MODULE AccessRules;

IMPORT
  ErrMsg, File, FileRd, Fmt, FS, IP, Logger, OSError, OSErrorPosix,
  Pathname, Rd, RefList, SupMisc, Text, Thread, Time, Uerror,
  UnixMisc, Word;

REVEAL
  T = BRANDED OBJECT
    path: Pathname.T := "";
    logger: Logger.T := NIL;
    fileTime: Time.T := 0.0d0;
    refreshTime: Time.T := 0.0d0;
    rules: RefList.T := NIL;	(* List of Rule. *)
  END;

TYPE
  RuleType = { Permit, PermitWithAuth, Deny };

  Rule = OBJECT
    addr: IP.Address;
    matchBits: CARDINAL;
    countBits: CARDINAL;
    type: RuleType;
    limit: CARDINAL;
  END;

CONST
  Digits = SET OF CHAR{'0'..'9'};

VAR (* CONST *)
  EnoentAtom := OSErrorPosix.ErrnoAtom(Uerror.ENOENT);

VAR
  theT := NEW(T);

EXCEPTION Error(TEXT);

PROCEDURE Check(rules: T;
                addr: IP.Address;
		READONLY clients: ARRAY OF IP.Address): CheckResult =
  VAR
    cur: RefList.T;
    rule: Rule;
    count: CARDINAL;
  BEGIN
    cur := rules.rules;
    WHILE cur # NIL DO
      rule := cur.head;
      IF Match(addr, rule.addr, rule.matchBits) THEN
	count := 0;
	FOR i := FIRST(clients) TO LAST(clients) DO
	  IF clients[i] # IP.NullAddress
	  AND Match(addr, clients[i], rule.countBits) THEN
	    INC(count);
	  END;
	END;
	IF count > rule.limit THEN  (* Failed the rule. *)
	  IF rule.type = RuleType.Deny THEN
	    IF rule.limit = 0 THEN
	      RETURN CheckResult.Denied;
	    ELSE
	      RETURN CheckResult.TooMany;
	    END;
	  END;
	ELSE  (* Passed the rule. *)
	  IF rule.type = RuleType.Permit THEN
	    RETURN CheckResult.OK;
	  ELSIF rule.type = RuleType.PermitWithAuth THEN
	    RETURN CheckResult.AuthRequired;
	  END;
	END;
      END;
      cur := cur.tail;
    END;
    (* If we fall off the end, we accept.  This is used only when there
       is no readable access file.  If the access file exists and is
       readable, we automatically append a universal deny rule to the
       end. *)
    RETURN CheckResult.OK;
  END Check;

PROCEDURE Get(path: Pathname.T;
              maxAge: Time.T;
	      logger: Logger.T := NIL): T
  RAISES {Rd.Failure, Thread.Alerted} =
  CONST
    HostStop = SET OF CHAR{' ', '\t', '/', '\n'};
    WS = SET OF CHAR{' ', '\t'};
  VAR
    now := Time.Now();
    file: File.T;
    rd: Rd.T;
    fileTime: Time.T;
    line: TEXT;
    lineNum: CARDINAL;
    len: CARDINAL;
    scanPos: CARDINAL;
    chPos: CARDINAL;
    start: CARDINAL;
    ch: CHAR;
    type: RuleType;
    host: TEXT;
    matchBits: CARDINAL;
    countBits: CARDINAL;
    limit: CARDINAL;
    lastRule: RefList.T;
  PROCEDURE AddRule(addr: IP.Address;
		    matchBits: CARDINAL;
		    countBits: CARDINAL;
		    type: RuleType;
		    limit: CARDINAL) =
    VAR
      rule := NEW(Rule,
	addr := addr,
	matchBits := matchBits,
	countBits := countBits,
	type := type,
	limit := limit);
      elem := RefList.List1(rule);
    BEGIN
      IF lastRule = NIL THEN
	theT.rules := elem;
      ELSE
	lastRule.tail := elem;
      END;
      lastRule := elem;
    END AddRule;
  PROCEDURE NextCh() =
    BEGIN
      chPos := scanPos;
      IF scanPos < len THEN
	ch := Text.GetChar(line, chPos);
	INC(scanPos);
      ELSE
	ch := '\n';
      END;
    END NextCh;
  PROCEDURE SkipWS() =
    BEGIN
      WHILE ch IN WS DO
	NextCh();
      END;
    END SkipWS;
  BEGIN
    (* We go ahead and open the file even though we might not need to
       parse it.  That way we avoid races between a stat() and the
       subsequent open. *)
    TRY
      file := FS.OpenFileReadonly(path);
      rd := NEW(FileRd.T).init(file);
    EXCEPT OSError.E(list) =>
      IF list.head # EnoentAtom THEN
	Log(logger, Logger.Priority.Warning,
	  "Cannot open \"" & path & "\": " & ErrMsg.StrError(list));
      END;
      theT.path := "";
      theT.logger := logger;
      theT.fileTime := 0.0d0;
      theT.refreshTime := 0.0d0;
      theT.rules := NIL;
      RETURN theT;
    END;
    TRY
      TRY
	fileTime := file.status().modificationTime;
      EXCEPT OSError.E(list) =>  (* No way! *)
	Log(logger, Logger.Priority.Warning,
	  "fstat failed on \"" & path & "\": " & ErrMsg.StrError(list));
	fileTime := 0.0d0;
      END;

      (* No need to reparse the file (with potential DNS delays) if what
	 we have already is up to date. *)
      IF Text.Equal(path, theT.path)
      AND theT.fileTime = fileTime
      AND theT.refreshTime >= now - maxAge THEN
	RETURN theT;
      END;

      theT.path := path;
      theT.logger := logger;
      theT.fileTime := fileTime;
      theT.refreshTime := now;
      theT.rules := NIL;
      lastRule := NIL;

      lineNum := 0;
      LOOP
	TRY line := Rd.GetLine(rd) EXCEPT Rd.EndOfFile => EXIT END;
	INC(lineNum);
	WITH commentStart = Text.FindChar(line, '#') DO
	  IF commentStart >= 0 THEN
	    line := Text.Sub(line, 0, commentStart);
	  END;
	END;
	len := Text.Length(line);
	scanPos := 0;
	NextCh();
	SkipWS();
	IF ch # '\n' THEN  (* Line has something on it. *)
	  TRY
	    (* Scan the rule type. *)
	    CASE ch OF
	    | '+' => type := RuleType.Permit;  limit := LAST(CARDINAL);
	    | '*' => type := RuleType.PermitWithAuth;  limit := LAST(CARDINAL);
	    | '-' => type := RuleType.Deny;  limit := 0;
	    ELSE
	      RAISE Error("\"+\" or \"-\" expected");
	    END;
	    NextCh();
	    SkipWS();

	    (* Scan the host name or IP address. *)
	    start := chPos;
	    WHILE NOT ch IN HostStop DO NextCh() END;
	    IF chPos = start THEN
	      RAISE Error("Host name or IP address expected");
	    END;
	    host := Text.Sub(line, start, chPos - start);
	    SkipWS();

	    (* Scan the match bits, if any.  The default is 32. *)
	    matchBits := 32;
	    IF ch = '/' THEN  (* Match bits *)
	      NextCh();
	      SkipWS();
	      IF NOT ch IN Digits THEN
		RAISE Error("Invalid matchbits");
	      END;
	      matchBits := 0;
	      REPEAT
		matchBits := 10*matchBits + ORD(ch) - ORD('0');
		NextCh();
	      UNTIL NOT ch IN Digits;
	      IF matchBits > 32 THEN
		RAISE Error("Matchbits (" & Fmt.Int(matchBits)
		  & ") out of range");
	      END;
	      SkipWS();
	    END;

	    (* Scan the count bits, if any.  The default is the match bits. *)
	    countBits := matchBits;
	    IF ch = '/' THEN  (* Count bits *)
	      NextCh();
	      SkipWS();
	      IF NOT ch IN Digits THEN
		RAISE Error("Invalid countbits");
	      END;
	      countBits := 0;
	      REPEAT
		countBits := 10*countBits + ORD(ch) - ORD('0');
		NextCh();
	      UNTIL NOT ch IN Digits;
	      IF countBits > 32 THEN
		RAISE Error("Countbits (" & Fmt.Int(countBits)
		  & ") out of range");
	      END;
	      SkipWS();
	    END;

	    (* Scan the connection limit, if any.  The default was set
	       above, based on the rule type. *)
	    IF ch # '\n' THEN
	      IF NOT ch IN Digits THEN
		RAISE Error("Invalid connection limit");
	      END;
	      limit := 0;
	      REPEAT
		limit := 10*limit + ORD(ch) - ORD('0');
		NextCh();
	      UNTIL NOT ch IN Digits;
	      SkipWS();
	    END;

	    IF ch # '\n' THEN RAISE Error("End of line expected") END;

	    TRY
	      AddRule(SupMisc.ParseIPAddress(host, netOK := TRUE),
		matchBits, countBits, type, limit);
	    EXCEPT SupMisc.BadAddress =>  (* Try it as a host name. *)
	      WITH addrs = UnixMisc.GetHostAddrs(host) DO
		IF addrs = NIL OR NUMBER(addrs^) = 0 THEN
		  RAISE Error("Cannot resolve host name \"" & host & "\"");
		END;
		FOR i := FIRST(addrs^) TO LAST(addrs^) DO
		  AddRule(addrs[i], matchBits, countBits, type, limit);
		END;
	      END;
	    END;
	  EXCEPT Error(msg) =>
	    Log(logger, Logger.Priority.Warning,
	      path & ":" & Fmt.Int(lineNum) & ": " & msg);
	  END;
	END;
      END;

      (* Append a universal PermitWithAuth rule at the end. *)
      AddRule(IP.NullAddress, 0, 0, RuleType.PermitWithAuth, LAST(CARDINAL));
    FINALLY
      Rd.Close(rd);
    END;

    RETURN theT;
  END Get;

PROCEDURE Log(logger: Logger.T;
              priority: Logger.Priority;
	      msg: TEXT) =
  BEGIN
    IF logger # NIL THEN
      Logger.Put(logger, priority, msg);
    END;
  END Log;

PROCEDURE Match(addr1, addr2: IP.Address; maskBits: CARDINAL): BOOLEAN =
  CONST
    Masks = ARRAY [1..7] OF INTEGER{
      16_80, 16_c0, 16_e0, 16_f0, 16_f8, 16_fc, 16_fe
    };
  VAR
    i := 0;
  BEGIN
    WHILE maskBits >= 8 DO
      IF addr1.a[i] # addr2.a[i] THEN RETURN FALSE END;
      INC(i);
      DEC(maskBits, 8);
    END;
    IF maskBits > 0 THEN
      WITH m = Masks[maskBits] DO
	IF Word.And(addr1.a[i], m) # Word.And(addr2.a[i], m) THEN
	  RETURN FALSE;
	END;
      END;
    END;
    RETURN TRUE;
  END Match;

PROCEDURE FmtIP(addr: IP.Address): TEXT =

Used only for debugging.

  VAR
    t := Fmt.Int(addr.a[0]);
  BEGIN
    FOR i := 1 TO LAST(addr.a) DO
      t := t & "." & Fmt.Int(addr.a[i]);
    END;
    RETURN t;
  END FmtIP;

<*UNUSED*>
PROCEDURE FmtRule(rule: Rule): TEXT =

Used only for debugging.

  VAR
    t: TEXT;
  BEGIN
    CASE rule.type OF
    | RuleType.Permit         => t := "+";
    | RuleType.PermitWithAuth => t := "*";
    | RuleType.Deny           => t := "-";
    END;
    t := t & FmtIP(rule.addr);
    t := t & "/" & Fmt.Int(rule.matchBits);
    t := t & "/" & Fmt.Int(rule.countBits);
    t := t & " " & Fmt.Int(rule.limit);
    RETURN t;
  END FmtRule;

BEGIN
END AccessRules.