! Database manager for local access control.  Each user authority record
! contains the username, (encrypted) password, login directory, local
! filesystem authorisation record (which includes user ID) and a textual
! description of the user (usually a name).  There are two separate indices
! into the database, viz by username and by user ID (replicating the data
! held in the authorisation record, because of the problems of maintaining
! back-pointers into the key B-trees).  Note that this process has the
! database open exclusively while it is running (i.e. all the time), so that
! any modifications to the database must be by requests to it.  This process
! does not (at the moment) manage any of the other files which might be 
! involved in user accreditation and management.

%externalstring(47) copyright %alias "GDMR_(C)_LOCALACC" = %c
   "Copyright (C) 1987 George D.M. Ross"

%option "-nonstandard-nocheck-nodiag-noline-nostack"
!%option "-nonstandard"

%include "Moose:Mouse.Inc"

%include "GDMR_H:FSysAcc.Inc"
%include "GDMR_H:FSys.Inc"
%include "GDMR_H:Tree.Inc"
%include "GDMR_H:Dir.Inc"

%externalroutinespec fsys initialise
%externalintegerfnspec fsys get full ID(%integer partial, %integername full)

%systemroutinespec phex(%integer i)
%externalintegerfnspec free store

%externalpredicatespec FS lookup(%string(31) key, %integername value)
%externalroutinespec FS insert(%string(31) key, %integer value)

%constinteger database path last = 3
%ownstring(15)%array database path(1 : database path last) =
   "System", "Authority", "Local_Database"
%conststring(31) database listing path = "System:Authority:Local_Listing"

%ownrecord(semaphore fm) request semaphore = 0
%ownrecord(mailbox fm) request mailbox = 0

%conststring(31) local authority mailbox = "LOCAL_AUTHORITY_MAILBOX"

%recordformat authority message fm(%record(message fm) system part,
                                   %integer code, result,
                                   %string(*)%name username,
                                   %string(*)%name password, old password,
                                   %record(fsys access fm)%name fsys access,
                                   %string(*)%name default directory,
                                   %string(*)%name textual description)

%constinteger enquire user       = 1
%constinteger validate user      = 2
%constinteger create user        = 3
%constinteger modify password    = 4
%constinteger modify user        = 5
%constinteger delete user        = 6
%constinteger print by username  = 7;  ! We do the printing!!
%constinteger print by ID        = 8;  ! We do the printing!!


! Diagnostic

%routine zprintstring(%string(255) s)
   %integer i, ch
      %return %if s = ""
      %for i = 1, 1, length(s) %cycle
         ch = charno(s, i)
         %if ' ' <= ch <= '~' %start
            print symbol(ch)
         %else
            print symbol('<')
            write(ch, 0)
            print symbol('>')
         %finish
      %repeat
%end


! Database manipulation stuff...

%constinteger root directory ID = 16_01000002

%owninteger database    ID = 0
%owninteger database token = 0

%constinteger key not found error = -501


! Password encryption, *based* on ECMA CRC as used in old-style filestores
! (supplied by Gordon Brebner).

%integerfn encrypt(%string(255) user, password)
   %integer rem, p

   %routine include(%byte b)
      %integer i, flag
         %for i = 0, 1, 7 %cycle
            flag = rem
            rem = rem<<1 ! b&1
            rem = rem !! 2_00000100110000010001110110110111 %if flag < 0
            b = b>>1
         %repeat
   %end

      !! printstring("Encrypt: """);  zprintstring(user)
      !! printstring(""" """);  zprintstring(password)
      !! print symbol('"');  newline
      rem = 16_FFFFFFFF
      to upper(user);  to upper(password)
      include(charno(user, p)) %for p = 1, 1, length(user)
      %if password # "" %start
         include(charno(password, p)) %for p = 1, 1, length(password)
      %finish
      !! printstring("Encrypted to ");  phex(rem);  newline
      %result = rem
%end


! User record manipulation routines...
! User record fields appear in the database in the following order:
!     Pointers to authorisation record, login directory, description
!     Password (first, because it's fixed in size (4 bytes))
!     Username
!     Authorisation record
!     Login directory
!     Textual description

%recordformat database fm(%byte authorisation offset, login offset,
                          %byte description offset, spare,
                          %integer encrypted password,
                          %shortarray x(1 : 250))

%recordformat user fm(%integer size, %record(database fm) U)

{} %routine display user record(%record(user fm)%name U)
{}    %record(fsys access fm)%name a
{}       printstring("User record at ");  phex(addr(U))
{}       printstring(", size ");  write(U_size, 0);  newline
{}       printstring("User: ");  zprintstring(string(addr(U_U_x(1))))
{}       a == record(addr(U_U_x(U_U_authorisation offset)))
{}       printstring(", ID ");  write(a_user ID, 0);  newline
{}       printstring("Login: ")
{}       zprintstring(string(addr(U_U_x(U_U_login offset))))
{}       printstring(", description: ")
{}       zprintstring(string(addr(U_U_x(U_U_description offset))));  newline
{} %end

%integerfn get user by name(%string(*)%name user, %integername site,
                            %record(user fm)%name U)
   %integer status
      !! printstring("Get user by name: ");  printstring(user);  newline
      status = B tree find entry(database token, user, site)
      %result = status %if status # 0 %or U == nil
      !! printstring("Found at ");  phex(site)
      !! printstring(", now get data");  newline
      %result = B tree data value(database token, site, U_size, U_U)
%end

%integerfn get user by ID(%integer user ID, %integername site,
                          %record(user fm)%name U)
   %string(5) ID key
   %integer status
      !! printstring("Get user by ID: ");  phex(user ID);  newline
      shortinteger(addr(ID key)) = 16_0500
      integer(addr(ID key) + 2)  = user ID
      status = B tree find entry(database token, ID key, site)
      %result = status %if status # 0 %or U == nil
      %result = B tree data value(database token, site, U_size, U_U)
%end

%integerfn update user(%record(user fm)%name U, %integer site)
   ! site < 0: new site required & create new keys
   !      = 0: new site required & update keys
   !      > 0: in-situ update (no key modification required)
   %record(fsys access fm)%name a
   %string(5) ID key
   %string(*)%name user key
   %integer status, new site
      %if site > 0 %start
         ! In-situ modification (assume no size change)
         %result = B tree data replace(database token, site, U_U)
      %finish
      ! Otherwise we'll need to update the keys too
      a == record(addr(U_U_x(U_U_authorisation offset)))
      shortinteger(addr(ID key)) = 16_0500
      integer(addr(ID key) + 2)  = a_user ID
      user key == string(addr(U_U_x(1)))
      status = B tree data insert(database token, U_size, U_U, new site)
      %result = status %if status # 0
      %if site = 0 %start
         ! Replace existing record
         status = B tree modify entry(database token, user key, new site)
         %result = status %if status # 0
         %result = B tree modify entry(database token, ID key, new site)
      %else
         ! Inserting from scratch, so create keys too...
         status = B tree add entry(database token, user key, new site)
         %result = status %if status # 0
         %result = B tree add entry(database token, ID key, new site)
      %finish
%end      

%routine new user record(%record(user fm)%name U,
                         %string(255) username, login directory,
                         %record(fsys access fm)%name a,
                         %string(255) textual description)
   U = 0
   string(addr(U_U_x(1))) = username
   U_size = length(username) // 2 + 1
   U_U_authorisation offset = u_size + 1
   record(addr(U_U_x(U_U_authorisation offset))) = a
   U_size = U_size + fsys access size + 4 * a_groups
   U_U_login offset = U_size + 1
   string(addr(U_U_x(U_U_login offset))) = login directory
   U_size = U_size + length(login directory) // 2 + 1
   U_U_description offset = U_size + 1
   string(addr(U_U_x(U_U_description offset))) = textual description
   U_size = U_size + length(textual description) // 2 + 1
   ! Now convert size to bytes, including password & pointers
   U_size = 2 * U_size + 8
%end


! Initial database opening routine.  If the database doesn't exist, we create
! it (the final directory must, however, exist).
! The database is normally open, and is only closed to commit/abandon a
! transaction (insertion, removal or modification of an entry).

%routine lookup database
   %integer directory ID, status, i, j
   %string(255) text
      fsys initialise
      status = fsys get full ID(root directory ID, database ID)
      %if status # 0 %start
         printstring("Failed to find root directory's ID: ")
         write(status, 0);  newline
         %stop
      %finish
      database ID = database ID ! directory flag
      %for i = 1, 1, database path last %cycle
         directory ID = database ID
         status = directory lookup one(nil, 0, directory ID, database path(i), 
                                       0, database ID, text)
         %if status # 0 %start
            %if i = database path last %and status = key not found error %start
               ! No database, so we'll create a new one
               printstring("Creating new authority database ")
               %for j = 1, 1, database path last %cycle
                  printstring(database path(j))
                  print symbol(':') %if j # database path last
               %repeat
               newline
               status = B tree create(nil, 0, database path(database path last),
                                      directory ID >> partition shift,
                                      directory ID, database ID)
               %if status # 0 %start
                  printstring("Failed to create new authority database: ")
                  write(status, 0);  newline
                  %stop
               %finish
               status = directory insert ID(nil, 0, directory ID,
                                            database path(database path last),
                                            database ID)
               %if status # 0 %start
                  printstring("Failed to insert authority database's entry: ")
                  write(status, 0);  newline
               %finish
               %exit
            %else
               printstring("Lookup status ");  write(status, 0)
               printstring(" for ");  printstring(database path(i));  newline
               %stop
            %finish
         %finish
      %repeat
%end

%routine close database(%integer abandon)
   %integer status
      status = B tree close(database token, abandon)
      %if status # 0 %start
         printstring("Close authority database: ");  write(abandon, 0)
         space;  write(status, 0);  newline
      %finish
%end

%routine open database
   %record(user fm) U
   %record(fsys access fm) a
   %integer status, i
      lookup database %if database ID = 0
      status = B tree open by ID(nil, 0, database ID, read access ! modify access,
                                 database token, i)
      %if status # 0 %start
         printstring("Failed to open authority database: ")
         write(status, 0);  newline
         %stop
      %finish
%end


! Request action routines proper

%routine do enquire user(%record(authority message fm)%name m)
   %record(user fm) U
   %integer status, x
      !! printstring("Do enquire user ");  printstring(m_username)
      !! newline
      status = get user by name(m_username, x, U)
      m_result = status %and %return %if status # 0
      !! printstring("User ");  printstring(m_username)
      !! printstring(", site ");  phex(x);  newline
      !! display user record(U)
      m_fsys access = record(addr(U_U_x(U_U_authorisation offset)))
      m_default directory = string(addr(U_U_x(U_U_login offset)))
      m_textual description = string(addr(U_U_x(U_U_description offset)))
      m_result = 0
%end

%routine do validate user(%record(authority message fm)%name m)
   %record(user fm) U
   %integer status, x, size
      !! printstring("Do validate user: ");  printstring(m_username)
      !! printstring(", pass: ");  printstring(m_password);  newline
      status = get user by name(m_username, x, U)
      m_result = status %and %return %if status # 0
      !! display user record(U)
      m_result = -1 %and %return %c
         %unless U_U_encrypted password = encrypt(m_username, m_password)
      m_fsys access = record(addr(U_U_x(U_U_authorisation offset)))
      m_default directory = string(addr(U_U_x(U_U_login offset)))
      m_result = 0
%end

%routine do create user(%record(authority message fm)%name m)
   %record(user fm) U
      !! printstring("Do create user: ");  printstring(m_username)
      !! newline
      new user record(U, m_username, m_default directory, m_fsys access,
                      m_textual description)
      U_U_encrypted password = encrypt(m_username, m_password)
      m_result = update user(U, -1)
      close database(m_result)
      open database
%end

%routine do delete user(%record(authority message fm)%name m)
   %record(user fm) U
   %record(fsys access fm)%name a
   %string(5) ID key
   %integer status, site, size
      !! printstring("Do delete user: ");  printstring(m_username)
      !! newline
      status = get user by name(m_username, site, U)
      m_result = status %and %return %if status # 0
      !! display user record(U)
      a == record(addr(U_U_x(U_U_authorisation offset)))
      m_default directory = string(addr(U_U_x(U_U_login offset)))
      shortinteger(addr(ID key)) = 16_0500
      integer(addr(ID key) + 2)  = a_user ID
      !! printstring("Deleting data record at ");  phex(site);  newline
      m_result = B tree data delete(database token, site)
      %if m_result = 0 %start
         !! printstring("Deleting key ");  printstring(m_username);  newline
         m_result = B tree delete entry(database token, m_username)
         %if m_result = 0 %start
            !! printstring("Deleting key ");  zprintstring(ID key);  newline
            m_result = B tree delete entry(database token, ID key)
         %finish
      %finish
      !! printstring("Delete: result ");  write(m_result, 0);  newline
      close database(m_result)
      open database
%end

%routine do modify password(%record(authority message fm)%name m)
   %record(user fm) U
   %integer site, status
      !! printstring("Do modify password: ");  printstring(m_username)
      !! newline
      status = get user by name(m_username, site, U)
      m_result = status %and %return %if status # 0
      U_U_encrypted password = encrypt(m_username, m_password)
      m_result = update user(U, site)
      close database(m_result)
      open database
%end

%routine do modify user(%record(authority message fm)%name m)
   %record(user fm) U, new U
   %record(fsys access fm)%name a
   %integer status, site, size
      !! printstring("Do modify user: ");  printstring(m_username)
      !! newline
      status = get user by name(m_username, site, U)
      m_result = status %and %return %if status # 0
      !! display user record(U)
      a == record(addr(U_U_x(U_U_authorisation offset)))
      m_result = -1 %and %return %if a_user ID # m_fsys access_user ID
      new user record(new U, m_username, m_default directory,
                      m_fsys access, m_textual description)
      new U_U_encrypted password = U_U_encrypted password
      !! display user record(new U)
      %if new U_size = U_size %start
         ! Can update in situ
         m_result = update user(new U, site)
      %else
         ! Change in size, must delete old and create new
         m_result = B tree data delete(database token, site)
         m_result = update user(new U, 0) %if m_result = 0
      %finish
      close database(m_result)
      open database
%end

%routine do print database(%record(authority message fm)%name m)
   %record(user fm) U
   %record(fsys access fm)%name access
   %record(key list fm)%name k, next
   %string(*)%name s
   %integer status, i
      %on 3 %start
         select output(3)
         printstring("Failed to open database listing file ")
         printstring(database listing path);  newline
         %return
      %finish
      k == B tree key list(database token, status)
      %if status # 0 %start
         printstring("Failed to obtain database key list: ");  write(status, 0)
         newline
         %return
      %finish
      open output(1, "x$Passwords")
      open output(2, "x$UserData")
      open output(3, "x$UserIDs")
      %while k ## nil %cycle
         %if charno(k_key, 1) # 0% %start
            status = B tree data value(database token, k_value, U_size, U_U)
            %if status = 0 %start
               s == string(addr(U_U_x(1)))
               select output(1);  ! Passwords
               printstring(s);  spaces(15 - length(s))
               printstring("16_");  phex(U_U_encrypted password & 16_7FFFFFFF)
               newline
               select output(2);  ! UserData
               printstring(s);  spaces(15 - length(s))
               s == string(addr(U_U_x(U_U_login offset)))
               printstring(s);  spaces(15 - length(s))
               s == string(addr(U_U_x(U_U_description offset)))
               print symbol('"');  printstring(s);  print symbol('"')
               newline
               select output(3);  ! UserIDs
               s == string(addr(U_U_x(1)))
               printstring(s);  spaces(15 - length(s))
               access == record(addr(U_U_x(U_U_authorisation offset)))
               write(access_user ID, 6);  space
               write(access_privileges, 4)
               write(access_supervisor ID, 4)
               space %and write(access_group(i), 1) %for i = 1, 1, access_groups
               newline
            %else
               select output(3)
               zprintstring(k_key)
               printstring(": Failed to obtain data record from ")
               phex(k_value);  printstring(", reason ")
               write(status, 0);  newline
            %finish
         %finish
         next == k_next;  dispose(k)
         k == next
      %repeat
      select output(1);  close output
      select output(2);  close output
      select output(3);  close output
      select output(3)
%end

%conststring(31) local authority name = "FS_LOCAL_AUTHORITY_RECORD"
%ownrecord(fsys access fm) local authority record = 0

%begin
   %record(authority message fm)%name request
   %ownrecord(semaphore fm) disaster = 0
   %record(poa fm)%name P
   %integer i
      %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
         ! Last-chance disaster-trap
         P == POA
         printstring("LocalAcc: unexpected event ");  write(P_event, 0)
         space;  write(P_event sub, 0);  space;  phex(P_event extra)
         space;  printstring(P_event message)
         printstring(" at or about PC ");  phex(P_event PC)
         newline
         %for i = 0, 1, 15 %cycle
            phex(P_event r(i));  space
            newline %if i & 7 = 7
         %repeat
         semaphore wait(disaster)
      %finish
      open input(3, ":N");  select input(3)
      open output(3, ":T");  select output(3)
      setup semaphore(disaster)
      mark %if POA_heap_level = 1
      printstring("Authority server starting: ");  write(free store, 0)
      printstring(" bytes free");  newline
      setup semaphore(request semaphore)
      setup mailbox(request mailbox, request semaphore)
      FS insert(local authority mailbox, addr(request mailbox))
      local authority record = 0
      local authority record_user ID = 1
      FS insert(local authority name, addr(local authority record))
      open database
      %cycle
         request == receive message(request mailbox)
         %if request_code = enquire user %start
            do enquire user(request)
         %else %if request_code = validate user
            do validate user(request)
         %else %if request_code = create user
            do create user(request)
         %else %if request_code = modify password
            do modify password(request)
         %else %if request_code = modify user
            do modify user(request)
         %else %if request_code = delete user
            do delete user(request)
         %else %if request_code = print by username %c
               %or request_code = print by ID
            do print database(request)
            request_result = 0
         %else
            request_result = -2
         %finish
         send message(request, request_system part_reply, nil)
      %repeat
%end %of %program