! Authority server for new-style filestores/file access, GDMR, July 1988

%option "-NoCheck-NoTrace-NoDiag-NoLine"

! The processes in this module are responsible for maintaining the password
! database, for issuing user tokens, and for identifying the users associated
! with given tokens.

%ownstring(31) database name = "$Authority"
%constinteger user token limit = 32
%constinteger processes = 3
%constinteger priority = 5
%constinteger size = 15360

%include "Moose:Mouse.Inc"
%include "GDMR_H:FSysAcc.Inc"
%include "GDMR_H:Dir.Inc"
%include "GDMR_H:Tree.Inc"
%include "GDMR_H:DateTime.Inc"

%include "GDMR_H:Auth.Inc"

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

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

%constinteger mask = 16_7FFFFFFF
%constinteger priv = 16_80000000

%routine pdate
   %string(31) d, t
      unpack date(get datestamp, d, t)
      printstring(d);  space;  printstring(t);  spaces(2)
%end

%predicate contains colons(%string(*)%name s)
   %integer i
      %false %if s = ""
      %for i = 1, 1, length(s) %cycle
         %true %if charno(s, i) = ':'
      %repeat
      %false
%end


! Token format, hidden from the outside (**TEMPORARY** version)

%recordformat user token fm(%integer tag, flags,
                            %string(31) user, domain,
                            %integer local value,
                            %integer EUCSD UID, EUCSD GID,
                            %integer LFCS UID, LFCS GID)
! Nasty hack, which is OK on 68000 and 68010: because only the bottom
! 24 bits are used in addresses we can use the top 8 bits to encode
! a sequence number.....

%ownrecord(user token fm)%array user tokens(1 : user token limit) = 0(*)
%ownrecord(semaphore fm) user token semaphore = 0

%record(user token fm)%map allocate token(%string(31) user, domain)
   %owninteger token sequence = 0
   %record(user token fm)%name t
   %integer i, ch, colon
      %result == nil %if user = "" %or domain = ""
      colon = 0
      %for i = length(user), -1, 1 %cycle
         colon = i %and %exit %if charno(user, i) = ':'
      %repeat
      %result == nil %if colon = length(user)
      semaphore wait(user token semaphore)
      %for i = 1, 1, user token limit %cycle
         t == user tokens(i)
         %if t_tag = 0 %start
            token sequence <- token sequence + 16_01000000
            t_tag = addr(t) ! token sequence
            t_flags = 0
            t_user = sub string(user, colon + 1, length(user))
            t_domain = domain
            signal semaphore(user token semaphore)
            !! printstring("Allocated token ");  phex(t_tag)
            !! printstring(" for ");  printstring(t_user)
            !! printstring(" at ");  printstring(domain);  newline
            %result == t
         %finish
      %repeat
      signal semaphore(user token semaphore)
      %result == nil
%end


! Password encryption, based on ECMA CRC from Gordon.

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

   %routine include(%byte b)
      %integer i, flag
         b = b - 'a' + 'A' %if 'a' <= b <= 'z'
         %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
      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 & mask
%end


! Case-independent username comparison

%predicate same(%string(*)%name s, t)
   %integer i, a, b
      %false %unless length(s) = length(t)
      %for i = 1, 1, length(s) %cycle
         a = charno(s, i);  a = a - 'a' + 'A' %if 'a' <= a <= 'z'
         b = charno(t, i);  b = b - 'a' + 'A' %if 'a' <= b <= 'z'
         %false %unless a = b
      %repeat
      %true
%end


! Token -> username conversion.

%owninteger default token = 0
%ownintegername default == nil

%predicate set default
   %integer x
      %if FS lookup("AUTHORITY_DEFAULT_TOKEN", x) %start
         default == integer(x)
         !! printstring("Default token at ");  phex(x);  newline
         %true
      %else
         %false
      %finish
%end

%externalpredicate authority identify user(%integer token, %string(*)%name user)
   %record(user token fm)%name t
      %on 0 %start;  %false;  %finish
      %false %unless token & 1 = 0;  ! Must be aligned
      %if token = 0 %start
         %if default == nil %start
            %false %unless set default
         %finish
         token = default
      %finish
      t == record(token & 16_00FFFFFF)
      %false %if t_tag # token
      !! printstring("Identify user: token ");  phex(token)
      !! printstring(", user ");  printstring(t_user)
      !! printstring(" at ");  printstring(t_domain)
      !! printstring(", local value ");  phex(t_local value);  newline
      user = t_user
      %true
%end

%externalpredicate authority local identify user(%integer token,
                                                 %integername value)
   %record(user token fm)%name t
      %on 0 %start;  %false;  %finish
      %false %unless token & 1 = 0;  ! Must be aligned
      %if token = 0 %start
         %if default == nil %start
            %false %unless set default
         %finish
         token = default
      %finish
      t == record(token & 16_00FFFFFF)
      %if t ## nil %start
         !! printstring("Local identify user: token ");  phex(token)
         !! printstring(", tag ");  phex(t_tag)
         !! printstring(", user ");  printstring(t_user)
         !! printstring(" at ");  printstring(t_domain)
         !! printstring(", local value ");  phex(t_local value);  newline
         %false %if t_tag # token
         value = t_local value
         %true
      %finish
      !! printstring("Local identify: null token");  newline
      %false
%end

%externalpredicate authority local set user(%integer token, value)
   %record(user token fm)%name t
      %on 0 %start;  %false;  %finish
      %false %unless token & 1 = 0;  ! Must be aligned
      %if token = 0 %start
         %if default == nil %start
            %false %unless set default
         %finish
         token = default
      %finish
      t == record(token & 16_00FFFFFF)
      %if t ## nil %start
         !! printstring("Local set user: token ");  phex(token)
         !! printstring(", tag ");  phex(t_tag)
         !! printstring(", user ");  printstring(t_user)
         !! printstring(" at ");  printstring(t_domain)
         !! printstring(", local value ");  phex(value);  newline
         %false %if t_tag # token
         t_local value = value
         %true
      %finish
      %false
%end


! YP access

%recordformat YP request fm(%record(message fm) system part,
                            %integer flags,
                            %string(15) user, domain,
                            %string(*)%name data)
! "" data implies failure
%ownrecord(mailbox fm)%name YP box == nil

%externalpredicatespec check BSD password(%string(31) pass, target)

%integerfn YP validate user by domain(%string(31) user, pass, domain)
   %record(semaphore fm) sem = 0
   %record(mailbox fm) box = 0
   %record(YP request fm) req = 0
   %record(YP request fm)%name rep
   %string(255) data = "", encr
   %integer x, pos
   %bytename ch
      !! printstring("YP validate ");  printstring(user)
      !! printstring(" at ");  printstring(domain);  newline
      %if YP box == nil %start
         %if FS lookup("YP_PASSWD_REQUESTS", x) %start
            !! printstring("YP mailbox at ");  phex(x);  newline
            YP box == record(x)
         %else
            !! printstring("No YP mailbox??");  newline
            %result = -1
         %finish
      %finish
      setup semaphore(sem)
      setup mailbox(box, sem)
      setup message(req, size of(req))
      req_user = user;  req_domain = domain
      req_data == data
      req_flags = 1;  ! Refresh cache
      send message(req, YP box, box)
      rep == receive message(box)
      !! printstring("YP reply:");  newline
      !! print symbol('"');  printstring(data);  print symbol('"')
      !! newline
      %result = -1 %if data = ""
      ! Extract the encrypted password
      %for x = 1, 1, length(data) %cycle
         %if charno(data, x) = ':' %start
            !! printstring("Found first ':' at ");  write(x, 0);  newline
            pos = x + 1
            %exit
         %finish
      %repeat
      encr = ""
      %for x = pos, 1, length(data) %cycle
         ch == charno(data, x)
         %exit %if ch = ':'
         encr = encr . to string(ch)
      %repeat
      !! printstring("Encrypyted pass: ");  printstring(encr);  newline
      %if encr = "" %or check BSD password(pass, encr) %start
         pdate
         printstring("Authority validate: ");  printstring(user)
         printstring(" at ");  printstring(domain)
         printstring(" OK");  newline
         %result = 0
      %else
         pdate
         printstring("Authority validate: password wrong for ")
         printstring(user);  printstring(" at ");  printstring(domain)
         newline
         %result = -1
      %finish
%end

%integerfn YP validate user(%record(authority request fm)%name r,
                            %string(*)%name domain)
   %string(127) user, xdomain
   %integer x
      domain == xdomain %if domain == nil
      %if r_user -> domain . (":") . user %start
         to upper(domain)
         domain = "+cs.ed.ac.uk" %if domain = "CS"
         %result = YP validate user by domain(user, r_pass, domain)
      %else
         x = YP validate user by domain(r_user, r_pass, "EUCSD")
         domain = "EUCSD" %and %result = 0 %if x = 0
         x = YP validate user by domain(r_user, r_pass, "LFCS")
         domain = "LFCS" %and %result = 0 %if x = 0
         %result = x
      %finish
%end


! Token -> UID/GID conversion

%externalroutine authority identify UID(%integer token, %string(15) domain,
                                        %integername xUID, xGID)
   %record(semaphore fm) sem = 0
   %record(mailbox fm) box = 0
   %record(YP request fm) req = 0
   %record(YP request fm)%name rep
   %string(255) data = ""
   %record(user token fm)%name t
   %integername UID, GID
   %integer x, pos
      %on 0 %start;  -> xdud;  %finish
      -> xdud %unless token & 1 = 0;  ! Must be aligned
      %if token = 0 %start
         %if default == nil %start
            -> xdud %unless set default
         %finish
         token = default
      %finish
      t == record(token & 16_00FFFFFF)
      -> xdud %if t_tag # token
      !! printstring("Identify UID: token ");  phex(token)
      !! printstring(", user ");  printstring(t_user)
      !! printstring(" at ");  printstring(t_domain)
      !! printstring(" in domain ");  printstring(domain);  newline
      %if domain = "+cs.ed.ac.uk" %start
         UID == t_EUCSD UID;  GID == t_EUCSD GID
      !%else %if domain = "LFCS"
      !   UID == t_LFCS UID;  GID == t_LFCS GID
      %else
         !! printstring("Unimplemented domain");  newline
         -> xdud
      %finish
      %if UID # 0 %start
         ! Already set
         xUID = UID;  xGID = GID
         %return
      %finish
      ! Not yet known
      %if YP box == nil %start
         %if FS lookup("YP_PASSWD_REQUESTS", x) %start
            !! printstring("YP mailbox at ");  phex(x);  newline
            YP box == record(x)
         %else
            !! printstring("No YP mailbox??");  newline
            -> xdud
         %finish
      %finish
      setup semaphore(sem)
      setup mailbox(box, sem)
      setup message(req, size of(req))
      req_user = t_user;  req_domain = domain
      req_data == data
      send message(req, YP box, box)
      rep == receive message(box)
      !! printstring("YP reply:");  newline
      !! print symbol('"');  printstring(data);  print symbol('"')
      !! newline
      %if data = "" %start
         ! Unknown
         UID = -2;  GID = -2
         xUID = -2;  xGID = -2
         %return
      %finish
      ! Skip to UID
      %for x = 1, 1, length(data) %cycle
         pos = x + 1 %and %exit %if charno(data, x) = ':'
      %repeat
      -> dud %if pos >= length(data)
      %for x = pos, 1, length(data) %cycle
         pos = x + 1 %and %exit %if charno(data, x) = ':'
      %repeat
      -> dud %if pos >= length(data)
      ! Extract the UID
      !! printstring("Extracting UID at ");  write(pos, 0);  newline
      UID = 0
      %for x = pos, 1, length(data) %cycle
         pos = x + 1 %and %exit %if charno(data, x) = ':'
         UID = 10 * UID + charno(data, x) - '0'
      %repeat
      -> dud %if pos >= length(data)
      ! Extract the GID
      !! printstring("Extracting GID at ");  write(pos, 0);  newline
      GID = 0
      %for x = pos, 1, length(data) %cycle
         pos = x + 1 %and %exit %if charno(data, x) = ':'
         GID = 10 * GID + charno(data, x) - '0'
      %repeat
      -> dud %if pos >= length(data)
      xUID = UID;  xGID = GID
      %return

dud:  UID = -2;  GID = -2
xdud: xUID = -2;  xGID = -2
%end


! Database access procedures

%owninteger database ID = 0
%owninteger database token = 0
%ownrecord(semaphore fm) database semaphore = 0

%routine lookup database
   %string(255) textual translation
   %integer status
      !! printstring("Auth: lookup database");  newline
      status = directory lookup one(nil, 0, 0, database name, 0,
                                    database ID, textual translation)
      %if status = 0 %start
         ! Success, so nothing more to do.
         !! printstring("Lookup: ID ");  phex(database ID);  newline
         %return
      %finish
      printstring("Failed to find authority database: ");  write(status, 0)
      printstring("; creating a new one");  newline
      status = B tree create(nil, 0, database name, 1, 0, database ID)
      %if status # 0 %start
         printstring("Create failed: ");  write(status, 0);  newline
         %return
      %finish
      status = directory insert ID(nil, 0, 16_41010002, database name, database ID)
      %if status # 0 %start
         printstring("Failed to insert entry for authority database: ")
         write(status, 0);  newline
      %finish
%end

%constinteger read = 0
%constinteger modify = 1

%integerfn open database(%integer mode)
   %integer status, flags
      semaphore wait(database semaphore)
      status = B tree open by ID(nil, 0, database ID, 1, database token, flags)
      signal semaphore(database semaphore) %if status # 0
      %result = status
%end

%constinteger OK = 0
%constinteger abort = -1

%routine close database(%integer how)
   %integer status
      status = B tree close(database token, how)
      signal semaphore(database semaphore)
%end


! Action routines, one for each request code.

%integerfn do authority add encrypted(%record(authority request fm)%name r)
   %string(127) caller
   %integer status, d pass
      status = open database(modify)
      %result = status %if status # 0
      %if B tree empty(database token) %start
         ! First user added must be privileged
         r_encrypted pass = r_encrypted pass ! priv
      %else
         %unless authority identify user(r_token, caller) %start
            ! Dud token
            close database(abort)
            %result = -4
         %finish
         !! printstring("Caller is ");  printstring(caller);  newline
         status = B tree find entry(database token, caller, d pass)
         %if status # 0 %start
            ! Unknown user in database??
            close database(abort)
            %result = -3
         %finish
         !! printstring("Encrypted password is ");  phex(d pass);  newline
         %if d pass & priv = 0 %start
            ! Must be privileged to add users
            close database(abort)
            %result = -2
         %finish
      %finish
      status = B tree add entry(database token, r_user, r_encrypted pass)
      close database(status)
      %result = status
%end

%integerfn do authority add user(%record(authority request fm)%name r)
   r_encrypted pass = encrypt(r_user, r_pass)
   %result = do authority add encrypted(r)
%end

%integerfn do authority delete user(%record(authority request fm)%name r)
   %result = -4
%end

%integerfn do authority set password(%record(authority request fm)%name r)
   %string(127) caller
   %integer status, u pass, d pass
      %result = -1 %unless authority identify user(r_token, caller)
      status = open database(modify)
      %result = status %if status # 0
      status = B tree find entry(database token, caller, d pass)
      %if status # 0 %start
         close database(status)
         %result = status
      %finish
      %if (%not same(caller, r_user)) %and d pass & priv = 0 %start
         ! Need privilege to change someone else's password
         close database(abort)
         %result = -2
      %finish
      u pass = encrypt(caller, r_pass2)
      %if u pass # d pass & mask %start
         ! Caller's supplied pass was wrong
         close database(abort)
         %result = -1
      %finish
      status = B tree find entry(database token, r_user, d pass)
      %if status # 0 %start
         ! Victim not in database
         close database(abort)
         %result = -1
      %finish
      u pass = encrypt(r_user, r_pass)
      u pass = u pass ! (d pass & priv);  ! Preserve privilege
      status = B tree modify entry(database token, r_user, u pass)
      close database(status)
      %result = status
%end

%integerfn do authority validate user(%record(authority request fm)%name r,
                                      %string(*)%name domain)
   %integer status, u pass, d pass
      %result = YP validate user(r, domain) %if contains colons(r_user)
      status = open database(read)
      %result = status %if status # 0
      status = B tree find entry(database token, r_user, d pass)
      close database(OK)
      %if status # 0 %start
         !pdate
         !printstring("Authority validate: unknown user ")
         !printstring(r_user);  newline
         !%result = status
         %result = YP validate user(r, domain)
      %finish
      !! printstring(r_user);  printstring("'s database pass is ")
      !! phex(d pass);  newline
      u pass = encrypt(r_user, r_pass)
      !! printstring("Supplied pass is ");  phex(u pass);  newline
      %if u pass # d pass & mask %start
         pdate
         printstring("Authority validate: password wrong for ")
         printstring(r_user);  newline
         %result = -1
      %finish
      pdate
      printstring("Authority validate: ");  printstring(r_user)
      printstring(" OK");  newline
      domain = "local" %if domain ## nil
      %result = 0
%end

%integerfn do authority issue token(%record(authority request fm)%name r)
   %record(user token fm)%name t
   %string(31) domain
   %integer status
      status = do authority validate user(r, domain)
      %result = status %if status # 0
      t == allocate token(r_user, domain)
      %if t == nil %start
         pdate
         printstring("Authority issue token: no free tokens")
         newline
         %result = -3
      %finish
      r_token = t_tag
      r_domain = domain %if r_domain ## nil
      %result = 0
%end

%integerfn do authority logon default(%record(authority request fm)%name r)
   %integer status
      status = do authority issue token(r)
      %result = status %if status # 0
      default token = r_token
      %result = 0
%end

%integerfn do authority void token(%record(authority request fm)%name r)
   %record(user token fm)%name t
      t == record(r_token & 16_00FFFFFF)
      %if t ## nil %start
         %result = -3 %if t_tag # r_token
         t = 0
      %finish
      %result = 0
%end

%integerfn do authority logoff default(%record(authority request fm)%name r)
   %integer status
      r_token = default token
      status = do authority void token(r)
      default token = 0
      %result = status
%end

%integerfn do authority set privilege(%record(authority request fm)%name r,
                                      %integer onoff)
   %string(127) caller
   %integer status, u pass, d pass
      %result = -1 %unless authority identify user(r_token, caller)
      %result = -3 %if same(caller, r_user);  ! Can't change self
      status = open database(modify)
      %result = status %if status # 0
      status = B tree find entry(database token, caller, d pass)
      %if status # 0 %start
         ! Caller not in database
         close database(status)
         %result = status
      %finish
      u pass = encrypt(caller, r_pass2)
      %if u pass # d pass & mask %start
         ! Caller's supplied pass was wrong
         close database(abort)
         %result = -1
      %finish
      %if d pass & priv = 0 %start
         ! Need privilege to change someone else's
         close database(abort)
         %result = -2
      %finish
      status = B tree find entry(database token, r_user, d pass)
      %if status # 0 %start
         ! Target not in database
         close database(status)
         %result = status
      %finish
      printstring(caller);  printstring(": ");  printstring("un") %if onoff = 0
      printstring("set authority privilege for ");  printstring(r_user);  newline
      %if onoff = 0 %then d pass = d pass & mask %c
                    %else d pass = d pass ! priv
      status = B tree modify entry(database token, r_user, d pass)
      close database(status)
      %result = status
%end

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

%routine authority process
   %record(authority request fm)%name r
   %switch action(authority add user : authority logoff default)
      open input(2, ":N");  select input(2)
      open output(2, ":T");  select output(2)
      %cycle
         r == receive message(request mailbox)
         !! printstring("Auth: received request type ")
         !! write(r_code, 0);  newline
         -> action(r_code) %c
            %if authority add user <= r_code <= authority logoff default
action(*):
         r_status = -1
         -> reply

action(authority add user):
         r_status = do authority add user(r)
         -> reply

action(authority add encrypted):
         r_status = do authority add encrypted(r)
         -> reply

action(authority delete user):
         r_status = do authority delete user(r)
         -> reply

action(authority set password):
         r_status = do authority set password(r)
         -> reply

action(authority validate user):
         r_status = do authority validate user(r, r_domain)
         -> reply

action(authority issue token):
         r_status = do authority issue token(r)
         -> reply

action(authority void token):
         r_status = do authority void token(r)
         -> reply

!action(authority identify user):
!         r_status = do authority identify user(r)
!         -> reply

action(authority set privilege):
         r_status = do authority set privilege(r, 1)
         -> reply

action(authority unset privilege):
         r_status = do authority set privilege(r, 0)
         -> reply

action(authority logon default):
         r_status = do authority logon default(r)
         -> reply

action(authority logoff default):
         r_status = do authority logoff default(r)
         -> reply

reply:   send message(r, r_system part_reply, nil) %if r_system part_reply ## nil
      %repeat
%end

%begin
   %record(process fm)%name p
   %integer i
   %label x
      open input(3, ":N");  select input(3)
      open output(3, ":T");  select output(3)
      setup semaphore(request semaphore)
      setup mailbox(request mailbox, request semaphore)
      FS insert(authority mailbox name, addr(request mailbox))
      FS insert("AUTHORITY_DEFAULT_TOKEN", addr(default TOKEN))
      setup semaphore(user token semaphore)
      signal semaphore(user token semaphore)
      setup semaphore(database semaphore)
      signal semaphore(database semaphore)
      lookup database
      p == create process(size, addr(x), priority, nil) %for i = 1, 1, processes - 1
      p == nil;  ! Avoid junk diagnostics
      set priority(nil, priority)
      {} printstring("Auth: ");  write(free store, 0)
      {} printstring(" free");  newline
x:    authority process
      ! Never returns...
%end %of %program