{  +---------------------------------------------------------------------------+
   |									       |
   |  [WHO]ACCESS.PAS			   Implement Account Visibility Rules  |
   |  Scott Bailey, Xerox Corporation		     Created October 25, 1990  |
   |									       |
   |  Modification History						       |
   |  V1.0-004 11/17/90 RSB	Break out privilege check from minimize_priv   |
   |  V1.0-003 11/10/90 RSB	Check attributes on identifiers		       |
   |  V1.0-002 11/10/90 RSB	Generalize safe file open routine	       |
   |  V1.0-001 11/08/90 RSB	Don't use privs for nondefault databases       |
   |  V1.0-000 10/25/90 RSB	Original version			       |
   |									       |
   +---------------------------------------------------------------------------+

This module implements visibility rules for authorization records.  Complete
description can be found below with VISIBLE, which is the high-level routine
called by other modules for this purpose.
}
[ident('V1.0-004'),environment('access'),
inherit('sys$library:starlet',
	'sys$library:pascal$str_routines',
	'sys$library:pascal$lib_routines',
	'search',
	'uafdef',
	'whodefs')]
module access;

  type
    string_entry = record
      link : ^string_entry;			{ Link to next entry }
      name : varying [58] of char;		{ Contents of this entry }
    end; {record string_entry}
    string_pointer = ^string_entry;

  [hidden]
  var
    extra_privs : array [1..2] of unsigned value zero;{ Extra image privileges }

  var						{ Let other modules check this }
    be_careful : boolean;			{ Anything in above mask? }

{
Generate a list of identifiers held by the specified UIC which match the
specified pattern and attributes.  The information is returned as a linked list
of names. Return status is:

SS$_NORMAL	Scan completed successfully
SS$_BADPARAM	List pointer was not null at entry
others		Other returns from rights database search routines
}
  [asynchronous,unbound]
  function match_held(
    uic : uic_type;
    pattern : packed array [l1..u1:integer] of char;
    attributes : unsigned;
    var found : string_pointer
    ) : integer;

    var
      test,					{ Comparison status }
      status : integer;				{ Intermediate return status }
      idval,					{ Value of current identifier }
      attr,					{ Attributes of current id }
      context : unsigned;			{ Current search context }
      buff : varying [64] of char;		{ ASCII name of identifier }
      temp : ^string_entry;			{ New entry }

  begin {function match_held}
    if found <> nil then
      match_held := ss$_badparam		{ Scream if it has stuff }
    else begin
      context := 0;
{
Scan the list of identifiers held.  For each returned, convert it to ASCII and
compare it to our match string.  A successful wildcard match means we should
store the result in the return array.  Note that for a match to be made, any
bits specified in the passed attributes mask must also be set for the identifier
attributes returned.
}
      repeat
        status := $find_held(uic,idval,attr,context); { Get next identifier }
	if odd(status) and_then (uand(attr,attributes) = attributes) then begin
	  test := $idtoasc(idval,buff.length,buff.body); { Convert to string }
	  if odd(test) then
	    test := str$match_wild(buff,pattern); { Does it match? }
	  if test = str$_match then begin	{ Yes, let's keep it }
	    new(temp);
	    temp^.name := buff;			{ Store the identifier }
	    temp^.link := found;		{ Link into head of list }
	    found := temp;
	  end; {then}
	end; {then}
      until status <> ss$_normal;		{ Loop 'till error or done }
{
No such identifier means we exhausted the list; anything else is an error
which abnormally aborted the search.
}
      if status = ss$_nosuchid then
	match_held := ss$_normal
      else
	match_held := status;
    end; {else}
  end; {function match_held}

{
Returns a list of resources associated with the specified user.  Prefix, suffix,
attributes and UIC are passed -- identifiers held by that UIC with the specified
attributes are tested against the string "prefix*suffix" and the parts matching
the asterisk are entered into a comma-delimited string, i.e. "res1,...,resn"

Return status can be:

SS$_NORMAL	Successful completion
LIB$_OUTSTRTRU	Output string was truncated
}
  [asynchronous,unbound]
  function get_resources(
    owner : uic_type;
    attributes : unsigned;
    prefix : packed array [l1..u1:integer] of char;
    suffix : packed array [l2..u2:integer] of char;
    var names : [volatile] varying [u3] of char
    ) : integer;

    var
      stat : integer;				{ Return status }
      rights_held,				{ Lookup results }
      curr : string_pointer;			{ List scan index }

  begin {function get_resources}
{
Match strings are get identifier names into a linked list
}
    rights_held := nil;				{ Make sure this is cleared }
    check(match_held(owner,prefix+'*'+suffix,attributes,rights_held));
{
Pass through the returned identifiers and strip out everything which didn't
get matched by the asterisk.  Put them into our return list and trash the
linked list as we go.
}
    names.length := 0;				{ Clear output buffer }
    stat := ss$_normal;
    curr := rights_held;
    while curr <> nil do begin			{ For each identifier }
      with curr^ do
	if (length(names) + length(name) - length(prefix) - length(suffix) + 1)
	> length(names.body) then
	  stat := lib$_outstrtru		{ No room to add this one }
	else
	  names := names + substr(name,length(prefix)+1,
	    length(name)-length(prefix)-length(suffix)) + ',';
      rights_held := curr;			{ Remember this record }
      curr := curr^.link;			{ Point to next one }
      dispose(rights_held);			{ Get rid of "used" one }
    end; {while}
{
If anything got put into the list, drop the trailing comma.  Then set return
status and we're finished.
}
    if length(names) > 0 then
      names.length := names.length - 1;
    get_resources := stat;
  end; {function get_resources}

{
Determine visibility based on xSNOOP/CAN_LOGIN_ON_x matches.  The supplied
parameter is the UIC to check against.  "TRUE" is returned if the caller is
entitled to view the specified UIC.
}
  function snoop_access(uic : uic_type) : boolean;

    const
      mgr_suffix = 'SNOOP';
      usr_prefix = 'CAN_LOGIN_ON_';		{ Define user ID name }

    var
      init : [static] boolean value true;	{ Initialize/first call flag }
      node_list : [static] varying [256] of char; { Nodes we manage }
      idx,					{ Scan index }
      stat : integer;				{ Return status from calls }
      our_uic : [volatile] uic_type;		{ Our UIC for initial scan }
      our_username : [volatile] varying [32] of char; { Our username }
      args : array [1..2] of item_list_entry;	{ Service item list }
      user_list : varying [256] of char;	{ User identifier list }
      access_allowed : boolean;			{ Is access allowed? }
      test : varying [64] of char;		{ Current check string }

      mgr_prefix, usr_suffix, usr_id : varying [32] of char;

  begin {function snoop_access}
{
Define a few "constant" null strings which don't work as constants...
}
    mgr_prefix.length := 0;
    usr_suffix.length := 0;
    usr_id := usr_prefix + '*' + usr_suffix;	{ What're we looking for? }
{
On first call, build the list of nodes managed. First step is to figure out who
we are.  Interrogate process to get username, then interrogate UAF to determine
UIC.  This should always succeed because if we aren't privileged enough to look
at our original UIC then we shouldn't have enough privileges to change our
process UIC to be different so that the test would fail. (Is that clear? :-)
}
    if init then begin
      init := false;				{ Initialize only once }
      args := zero;
      with args[1] do begin
        itmcod := jpi$_username;		{ Ask for username }
        bufadr := iaddress(our_username.body);
        buflen := length(our_username.body);
	retadr := iaddress(our_username.length);
      end; {with}
      check($getjpiw(,,,args));			{ Get our username }
      with args[1] do begin
        itmcod := uai$_uic;			{ Ask for login UIC }
        bufadr := iaddress(our_uic);
        buflen := 4;
      end; {with}
      our_uic := zero;				{ Clean out trash }
      check($getuai(,,our_username,args));	{ Get our "real" UIC }
{
Now build a pretty list of appropriate entities.  Then stuff commas on the
ends to fix comparison boundary conditions.
}
      check(get_resources(our_uic,0,mgr_prefix,mgr_suffix,node_list));
      if length(node_list) > 0 then begin	{ If anything turned up }
	if length(node_list) + 2 > length(node_list.body) then
	  check(lib$_outstrtru)
	else
	  node_list := ',' + node_list + ',';
      end; {then}
    end; {then}
{
If we end up with a null management list (it will be for most users)
then short-circuit everything.  Otherwise, it's time for real work.
Build a similar pretty list for the target user.
}
    access_allowed := false;			{ Assume no access }
    if length(node_list) > 0 then begin		{ If we manage anything... }
      check(get_resources(uic,0,usr_prefix,usr_suffix,user_list));
{
Now run through this list.  For each element, check to see if it (bounded
by commas) is a substring of the management list.  If so, access to this
UIC is allowed; a negative result after the list is exhausted means that
access is denied.
}
      idx := 0;
      stat := ss$_normal;
      repeat
	stat := rsb$element(test,idx,',',user_list); { Get next element }
	if stat = ss$_normal then begin
	  test := ',' + test + ',';		{ Stick on bounds }
	  if index(node_list,test) > 0 then	{ Check for this one }
	    access_allowed := true;		{ Matched, we're in }
	end; {then}
	idx := idx + 1;				{ On to next element }
      until access_allowed or (stat <> ss$_normal);
{
Handle abnormal returns from the search process
}
      if stat <> str$_noelem then
	check(stat);
    end; {then}
{
Pass back status and return
}
    snoop_access := access_allowed;
  end; {function snoop_access}

{
Determine visibility based on x_MANAGER/class matches.  The supplied parameter
is the class to check against.  "TRUE" is returned if the caller holds the class
management identifier with at least the specified attributes.
}
  function class_access(
    class : packed array [l1..u1:integer] of char;
    attributes : unsigned
    ) : boolean;

    const
      mgr_suffix = '_MANAGER';

    var
      init : [static] boolean value true;	{ Initialize/first call flag }
      class_list : [static] varying [256] of char; { Classes we manage }
      cut : integer;				{ Cutoff of passed class }
      our_uic : [volatile] uic_type;		{ Our UIC for initial scan }
      our_username : [volatile] varying [32] of char; { Our username }
      args : array [1..2] of item_list_entry;	{ Service item list }

      mgr_prefix : varying [32] of char;

  begin {function class_access}
    mgr_prefix.length := 0;
{
On first call, build the list of classes managed. First step is to figure out
who we are.  Interrogate process to get username, then interrogate UAF to
determine UIC.  This should always succeed because if we aren't privileged
enough to look at our original UIC then we shouldn't have enough privileges to
change our process UIC to be different so that the test would fail. (Is that
clear? :-)
}
    if init then begin
      init := false;				{ Initialize only once }
      args := zero;
      with args[1] do begin
        itmcod := jpi$_username;		{ Ask for username }
        bufadr := iaddress(our_username.body);
        buflen := length(our_username.body);
	retadr := iaddress(our_username.length);
      end; {with}
      check($getjpiw(,,,args));			{ Get our username }
      with args[1] do begin
        itmcod := uai$_uic;			{ Ask for login UIC }
        bufadr := iaddress(our_uic);
        buflen := 4;
      end; {with}
      our_uic := zero;				{ Clean out trash }
      check($getuai(,,our_username,args));	{ Get our "real" UIC }
{
Now build a pretty list of appropriate entities.  Then stuff commas on the
ends to fix comparison boundary conditions.
}
      check(get_resources(our_uic,attributes,mgr_prefix,mgr_suffix,class_list));
      if length(class_list) + 2 > length(class_list.body) then
	check(lib$_outstrtru)
      else
	class_list := ',' + class_list + ',';
    end; {then}
{
Simple.  Identify the end of the [blank-padded] class supplied, then see
if it shows up in the list of managed classes.
}
    cut := length(class);
    while (cut > 0) and_then (class[l1+cut-1] = ' ') do
      cut := cut - 1;
    class_access := (index(class_list,','+substr(class,1,cut)+',') > 0);
  end; {function class_access}

{
Determine caller's privileges.  This is privilege mask without considering
image privileges, except that SYSPRV will be set if our UIC group is less
than or equal to the SYSGEN parameter MAXSYSGROUP.  The caller's UIC is
also returned for usage in UIC-based access checks.
}
  procedure get_caller_privileges(
    var privs : prv$type;
    var uic : uic_type);

    var
      args : array [1..3] of item_list_entry;	{ For system service calls }
      maxsysgroup : [volatile] integer;		{ Value of MAXSYSGROUP }
      our_uic : [volatile] uic_type;		{ Our current UIC }
      old_privs : [volatile] prv$type;		{ Privileges w/o image }

  begin {procedure get_caller_privileges}
{
Determine what our privileges before image invocation were.  Also get the
group number, in case we need it later.
}
    args := zero;
    with args[1] do begin
      itmcod := jpi$_uic;			{ Get current UIC }
      bufadr := iaddress(our_uic);
      buflen := 4;
    end; {with}
    with args[2] do begin
      itmcod := jpi$_procpriv;			{ Original privileges }
      bufadr := iaddress(old_privs);
      buflen := size(old_privs);
    end; {with}
    check($getjpiw(,,,args));			{ Grab that information }
{
If SYSPRV isn't explictly held, see if we deserve it based on UIC group.
}
    if not old_privs.prv$v_sysprv then begin
      args := zero;
      with args[1] do begin
	itmcod := syi$_maxsysgroup;		{ We need this value }
	bufadr := iaddress(maxsysgroup);
	buflen := size(maxsysgroup);
      end; {with}
      check($getsyiw(,,,args));			{ Return that value }
      if our_uic.group <= maxsysgroup then	{ Yes we qualify }
	old_privs.prv$v_sysprv := true;		{ so set it explicitly }
    end; {then}
{
Pass back the privileges and UIC and we're done.
}
    privs := old_privs;
    uic := our_uic;
  end; {procedure get_caller_privileges}

{
Determine visibility based on normal UIC rules.  The supplied parameter is the
UIC to check against.  "TRUE" is returned if:

The supplied UIC matches the caller's current (not default) UIC; or
Caller has GRPPRV and UIC matches caller's current group number; or
Caller has SYSPRV or BYPASS or READALL.  (Note that group number less than
or equal to the SYSGEN parameter MAXSYSGROUP implies SYSPRV.)
}
  function uic_access(
    uic : uic_type
    ) : boolean;

    var
      init : [static] boolean value true;	{ Initialize/first call flag }
      our_uic : [static] uic_type;		{ Our current UIC }
      our_privs : [static] prv$type;		{ Non-image privilege mask }

  begin {function uic_access}
{
On first call, get information about ourselves so we can make tests later.
}
    if init then begin
      init := false;				{ Do this only once }
      get_caller_privileges(our_privs,our_uic);	{ Get raw information }
    end; {then}
{
Make the test according to standard VMS usage.
}
    uic_access :=
    ((our_privs.prv$v_sysprv or our_privs.prv$v_bypass or our_privs.prv$v_readall)
    or (our_privs.prv$v_grpprv and (our_uic.group = uic.group))
    or ((our_uic.group = uic.group) and (our_uic.member = uic.member)));
  end; {function uic_access}      

{
Define visibility rules.  These rules (from WHO header comments) are:

Normal VMS UIC access checking is used to determine the visibility of all
records in the authorization database.  That is, a record is visible if:

 o The user has SYSPRV, BYPASS, READALL or a system UIC group number;
 o The user has GRPPRV and current group number matches the record's group;
 o The user's current UIC matches the record's UIC.

THIS TEST IS IMPLEMENTED BY UIC_ACCESS.

Additionally, a record is visible if th user's default UIC holds an identifier
of the form "x_MANAGER" and "x" is the contents of the record's class field
(which is defined in the record's local data area.)

THIS TEST IS IMPLEMENTED BY CLASS_ACCESS.

Additionally, a record is visible if ALL of the following are true:

 o The record's UIC group number is at least 100 (octal); and
 o The record's UIC holds an identifier of the form "CAN_LOGIN_ON_x"; and
 o The user's default UIC holds a corresponding "xSNOOP" identifier.

THIS TEST IS PARTIALLY IMPLEMENTED BY SNOOP_ACCESS.

Additionally, if the logical name WHO_SHOWALL is defined in the system name
table at executive mode, then any record is visible to any user as long as a
wildcard search method is not used.

However, if the above logical name translates to "WILDCARDS" then there are no
visibility restrictions of any kind for any user.

THESE TESTS ARE IMPLEMENTED BY THIS ROUTINE.

Accordingly, the following information is required:

o The record's UIC;
o The record's class;
o The search method used.

This routine returns a value of "TRUE" if the record is ruled visible.
}
  function visible(
    uic : uic_type;				{ Record's UIC }
    class : ascii_32; {padded_string(xrx$s_class);} { Record's class }
    method : search_type			{ How did we find it? }
    ) : boolean;

    const
      logical_name = 'WHO_SHOWALL';		{ Flag name }
      wild_value = 'WILDCARDS';			{ This enables everything }
      hide_snoop_group = 64;			{ 100 octal, snoop bound }

    var
      init : [static] boolean value true;	{ First time called? }
      show_all,					{ Is showall defined? }
      show_wild : [static] boolean;		{ Are show wilds ok? }
      safe_searches : [static,readonly] set of search_type
	value [exact_user,full_uic];		{ Non-wild search types }
      args : array [1..2] of item_list_entry;	{ $TRNLNM call list }
      status : integer;				{ Translate status }
      buff : [volatile] varying [64] of char;	{ Value of flag logical }

  begin {function visible}
{
On first call, initialize the values of our nonprivileged override flags.
These will determine how stringently we need to apply our checks.
}
    if init then begin
      init := false;				{ Only initialize once }
      args := zero;
      with args[1] do begin
	itmcod := lnm$_string;			{ Get translation }
	bufadr := iaddress(buff.body);
	buflen := length(buff.body);
	retadr := iaddress(buff.length);
      end; {with}
      status := $trnlnm(lnm$m_case_blind,'LNM$SYSTEM_TABLE',
      logical_name,psl$c_exec,args);		{ Try to translate it }
      case status of
	ss$_normal: begin			{ Translation exists }
	  show_all := true;			{ All records visible }
	  show_wild := (buff = wild_value);	{ Possibly with wild searches }
	end; {select}
	ss$_nolognam: begin			{ Logical name isn't there }
	  show_all := false;			{ No special access allowed }
	  show_wild := false;
	end; {select}
	otherwise				{ Unexpected errors }
	  check(status);
      end; {case}
    end; {then}
{
Perform the access checks.  We'll explicitly perform them in the order
which should minimize overhead, i.e. most expensive tests are performed last.
}
    visible :=
      (show_wild) or_else
      (show_all and (method in safe_searches)) or_else
      (uic_access(uic)) or_else
      (class_access(class,0)) or_else
      ((uic.group >= hide_snoop_group) and_then snoop_access(uic));
  end; {function visible}

{
Determine what privileges are held by this image and not also held by the
caller.  This routine returns a boolean value indicating if any such privileges
exist, as well as a mask which indicates exactly which privileges are affected.
}
  [global]
  function test_privileges(var mismatched : quadword) : boolean;

    var
      args : array [1..3] of item_list_entry;	{ $GETJPIW argument list }
      image, process : [volatile] quadword;	{ Privilege masks }

  begin {function test_privileges}
{
Retrieve image privileges and process privileges
}
    args := zero;
    with args[1] do begin
      itmcod := jpi$_procpriv;
      bufadr := iaddress(process);
      buflen := size(process);
    end; {with}
    with args[2] do begin
      itmcod := jpi$_imagpriv;
      bufadr := iaddress(image);
      buflen := size(image);
    end; {with}
    check($getjpiw(,,,args));			{ Grab that information }
{
See what the image has that we don't.  Set flag if any are found.
}
    mismatched[1] := uand(image[1],unot(process[1]));
    mismatched[2] := uand(image[2],unot(process[2]));
    test_privileges := ((mismatched[1] <> 0) or (mismatched[2] <> 0));
  end; {function test_privileges}

{
Disable all privileges held by image which are not already held by caller.
Additionally, set a flag if this mask is not empty (used for SYSUAF open)
}
  procedure minimize_privileges;

  begin {procedure minimize_privileges}
    be_careful := test_privileges(extra_privs);	{ Find out what to worry about }
    if be_careful then				{ If image has extra privs }
      check($setprv(,extra_privs));		{ then turn them off }
  end; {procedure minimize_privileges}

{
This next procedure should be used as a useropen procedure for accessing files
which the user does not normally have access to.  If the provided filespec is
empty (i.e. the default file specification will be used) this routine will
assist in the open by temporarily elevating privileges removed earlier by the
minimize_privileges routine.  In this event, the open will be forced to use
executive-mode translations.

If a filespec is provided, no assistance is provided -- the user must have
access to the target file on their own merits.
}
  function safe_file_open(
    var fab : fab$type;				{ SYSUAF FAB }
    var rab : rab$type;				{ SYSUAF RAB }
    var f : text				{ file variable (bogus type) }
    ) : integer;				{ Return status }

    var
      stat : integer;				{ Intermediate status }
      privson : boolean;			{ Privileges enabled? }

  begin {function safe_file_open}
{
If program was installed with privileges the user doesn't have,
and if the user did not provide a non-default file specification,
then temporarily re-enable program privileges and force exec lookups.
}
    if be_careful				{ User needs extra privs }
    and_then (fab.fab$b_fns = 0)		{ and no weird file specified }
    and_then ($setprv(1,extra_privs) = ss$_normal) then begin { turn on privs }
      privson := true;				{ Remember they're on }
      fab.fab$v_lnm_mode := psl$c_exec;		{ Force exec lookups }
    end else
      privson := false;				{ No assistance provided }
{
Perform the file open and record stream connect
}
    stat := $open(fab);
    if odd(stat) then
      stat := $connect(rab);
{
If we enabled privileges, turn 'em off again.  Don't let this one fail...
}
    if privson then
      check($setprv(,extra_privs));
    safe_file_open := stat;			{ Pass back final status }
  end; {function safe_file_open}
end. {module access}