! H2 file system proccesses.  These processes interpret requests in standard
! internal message form, whether from an external-service manager or from a
! local process.  The processes make requests to a remote server using the
! 1976 H2 protocol.

! This version converted to use the raw ether handler.

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

! To do: implement redirection

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

%constinteger processes = 4
%constinteger priority = 6
%constinteger default initial allocation = 32
%constinteger file tokens = 32

%constinteger filestore specifier = 1

%include "Moose:Mouse.Inc"
%include "GDMR_H:FSysAcc.Inc"
%include "GDMR_H:NFac.Inc"
%include "GDMR_E:2Meg.Inc"

%include "GDMR_H:Lights.Inc"

%externalpredicatespec FS lookup(%string(31) what, %integername value)

%constinteger change file = modify file mode ! append to file mode

%conststring(1) SNL = "
"

%recordformat path fm(%record(path fm)%name next,
                      %integer version, %string(*)%name key,
                      %string(255) text)

%systemroutinespec phex(%integer i)
%systemroutinespec phex2(%integer i)
%systemstring(31)%fnspec itos(%integer i, j)
%systemintegerfnspec free store

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

%externalroutinespec dump(%integer n, %bytename b)

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


! Diagnostic

!! %routine show path(%record(path fm)%name p)
!!    %while p ## nil %cycle
!!       print symbol('@');  phex(addr(p))
!!       printstring(" -> ");  phex(addr(p_next))
!!       printstring(" v ");  write(p_version, 0)
!!       printstring(" c ");  printstring(p_key)
!!       newline
!!       p == p_next
!!    %repeat
!! %end

!! %routine xprintstring(%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


! Filestore connection tables

%constinteger first filestore = 'A'
%constinteger last filestore  = 'Z'
%recordformat filestore fm(%record(semaphore fm) semaphore,
                           %integer context, Uno)
%ownrecord(filestore fm)%array filestore(first filestore : last filestore) = 0(*)

%constintegerarray filestore addresses(first filestore : last filestore) =
      16_14 { A },  16_15 { B },  16_1B { C },  16_35 { D },
      16_00 { E },  16_00 { F },  16_7E { G },  16_00 { H },
      16_00 { I },  16_00 { J },  16_00 { K },  16_00 { L },
      16_44 { M },  16_00 { N },  16_00 { O },  16_00 { P },
      16_00 { Q },  16_00 { R },  16_48 { S },  16_00 { T },
      16_00 { U },  16_72 { V },  16_00 { W },  16_3E { X },
      16_00 { Y },  16_00 { Z }


! Filestore communications

! reserved                   '@'       { Can't be used for some reason!
%constinteger FC openmod   = 'A'       { Uno: filename                : Xno
%constinteger FC rename    = 'B'       { Uno: filename, filename      :
%constinteger FC dchange   = 'C'       { Uno: filename, date          :
%constinteger FC delete    = 'D'       { Uno: filename                :
%constinteger FC permit    = 'E'       { Uno: filename, permissions   :
%constinteger FC finfo     = 'F'       { Uno: ownername, file-number  : packet
%constinteger FC general   = 'G'       { Uno:                         : packet
%constinteger FC uclose    = 'H'       { Xno:                         :
%constinteger FC readback  = 'I'       { Xno:                         : packet
%constinteger FC setdir    = 'J'       { Uno: ownername               :
%constinteger FC close     = 'K'       { Xno:                         :
%constinteger FC logon     = 'L'       { 0  : ownername, password     : Uno
%constinteger FC logoff    = 'M'       { Uno:                         :
%constinteger FC ninfo     = 'N'       { Uno: filename                : packet
%constinteger FC copyfile  = 'O'       { Uno: filename, filename      :
%constinteger FC pass      = 'P'       { Uno: password, username      :
%constinteger FC quote     = 'Q'       { Uno: password                :
%constinteger FC readda    = 'R'       { Xno: block-number, blocks    : packet
%constinteger FC openr     = 'S'       { Uno: filename                : Xno
%constinteger FC openw     = 'T'       { Uno: filename                : Xno
%constinteger FC reset     = 'U'       { Xno: block-number            :
%constinteger FC credir    = 'V'       { Uno: new-diectory-name       :
%constinteger FC writeda   = 'W'       { Xno: block-number, ...packet :
%constinteger FC readsq    = 'X'       { Xno: blocks                  : packet
%constinteger FC writesq   = 'Y'       { Xno: ...packet               :
%constinteger FC readfile  = 'Z'       { Uno: filename                : ...file
%constinteger FC new owner = '['       { Uno: <p>ownername, quota     :
%constinteger FC owners    = '\'       { Uno: partition number        : packet
%constinteger FC fcomm     = ']'       { Uno: system command          : packet
%constinteger FC new quota = '^'       { Uno: ownername, delta        :
! unused                     '_'       {

%constinteger first FC = '@';  ! This one is reserved.
%constinteger last  FC = '_'

%integerfn H to I(%string(127) h)
   %integer i, j, k
      %result = 0 %if h = ""
      %result = -1 %if charno(h, 1) = '-'
      i = 0
      %for j = 1, 1, length(h) %cycle
         k = charno(h, j) - '0'
         %exit %if k < 0
         i = 16 * i + k
      %repeat
      %result = i
%end

%string(7)%fn I to H(%integer i)
   %string(31) h
   %integer j
      h = ""
      h = h . to string((i >> j) & 15 + '0') %for j = 12, -4, 0
      %result = h
%end

%ownrecord(mailbox fm)%name ether mailbox == nil

%integerfn transact(%integer ether context,
                    %bytename send buffer, %integer send bytes,
                    %bytename receive buffer, %integername receive bytes)
   %record(semaphore fm) semaphore
   %record(mailbox fm) mailbox
   %record(ether request fm) request = 0
   %record(ether request fm)%name response
      %if ether mailbox == nil %start
         printstring("F_H2: ether mailbox unknown??")
         newline
         %result = -1
      %finish
      setup semaphore(semaphore)
      setup mailbox(mailbox, semaphore)
      setup message(request, size of(request))
      request_code = ether old write
      request_context = ether context
      request_buffer == send buffer
      request_bytes = send bytes
      send message(request, ether mailbox, mailbox)
      response == receive message(mailbox)
      %result = response_status %if response_status < 0
      request_code = ether old read
      request_context = ether context
      request_buffer == receive buffer
      request_timeout = 100;  ! Deciseconds
      send message(request, ether mailbox, mailbox)
      response == receive message(mailbox)
      %result = response_status %if response_status < 0
      receive bytes = response_bytes
      %result = 0
%end

%integerfn receive more(%integer ether context,
                        %bytename receive buffer, %integername receive bytes)
   %record(semaphore fm) semaphore
   %record(mailbox fm) mailbox
   %record(ether request fm) request = 0
   %record(ether request fm)%name response
      %if ether mailbox == nil %start
         printstring("F_H2: ether mailbox unknown??")
         newline
         %result = -1
      %finish
      setup semaphore(semaphore)
      setup mailbox(mailbox, semaphore)
      setup message(request, size of(request))
      request_code = ether old read
      request_context = ether context
      request_buffer == receive buffer
      request_timeout = 100;  ! Deciseconds
      send message(request, ether mailbox, mailbox)
      response == receive message(mailbox)
      %result = response_status %if response_status < 0
      receive bytes = response_bytes
      %result = 0
%end

%integerfn establish connection(%integer target)
   %record(semaphore fm) semaphore
   %record(mailbox fm) mailbox
   %record(ether request fm) request = 0
   %record(ether request fm)%name response
   %record(filestore fm)%name f
   %string(127) from FS = "Dummy"
   %integer n, i
   %byte two = 2
      %if ether mailbox == nil %start
         %if FS lookup(ether mailbox name, i) %start
            ether mailbox == record(i)
         %else
            printstring("F_H2: No ether mailbox?");  newline
            %result = -1
         %finish
      %finish
      f == filestore(target)
      setup semaphore(semaphore)
      setup mailbox(mailbox, semaphore)
      setup message(request, size of(request))
      request_code = ether old define
      request_ra = filestore addresses(target)
      request_rp = 0
      send message(request, ether mailbox, mailbox)
      response == receive message(mailbox)
      n = response_status %and -> error %if response_status < 0
      f_context = response_context
      n = transact(f_context, two, 1, charno(from FS, 1), i)
      -> error %if n < 0
      length(from FS) = i
      i = H to I(from FS)
      %if i < 0 %start
         ! Error response from filestore
         printstring("F_H2: Filestore ");  print symbol(target)
         printstring(": ");  printstring(from FS);  ! NL supplied in response
         -> undef
      %finish
      request_code = ether old redefine
      request_context = f_context
      request_rp = i
      send message(request, ether mailbox, mailbox)
      response == receive message(mailbox)
      n = response_status %and -> error %if response_status < 0
      !! printstring("Connected to Filestore ");  print symbol(target)
      !! printstring(" (");  phex2(filestore addresses(target));  print symbol(')')
      !! printstring(" context ");  write(f_context, 0)
      !! newline
      %result = 0

error:printstring("F_H2: ");  printstring(ether errors(n));  newline
undef:%if f_context # 0 %start
         ! Connection was defined.  Break it.
         request_code = ether old undefine
         request_context = f_context
         send message(request, ether mailbox, mailbox)
         response == receive message(mailbox)
         ! Ignore any error status here
         f_context = 0
      %finish
      %result = -1
%end

%routine break connection(%integer target)
   %record(semaphore fm) semaphore
   %record(mailbox fm) mailbox
   %record(ether request fm) request
   %record(ether request fm)%name response
   %record(filestore fm)%name f
   %integer n, i
   %byte twelve = 12
      !! printstring("Break connection to filestore ")
      !! print symbol(target);  newline
      f == filestore(target)
      setup semaphore(semaphore)
      setup mailbox(mailbox, semaphore)
      setup message(request, size of(request))
      semaphore wait(f_semaphore)
      signal semaphore(f_semaphore) %and %return %if f_context = 0
      request_code = ether old write
      request_context = f_context
      request_buffer == twelve
      request_bytes = 1
      send message(request, ether mailbox, mailbox)
      response == receive message(mailbox)
      n = response_status
      request_code = ether old undefine
      request_context = f_context
      send message(request, ether mailbox, mailbox)
      response == receive message(mailbox)
      f_context = 0
      signal semaphore(f_semaphore)
      n = response_status %if n = 0
      %if n < 0 %start
         printstring("F_H2 (informational): ")
         printstring(ether errors(n));  newline
      %finish
%end

%string(255)%fn send command(%integer target, UXno, command,
                             %string(255) parameters)
   %record(filestore fm)%name f
   %string(255) sending, response
   %integer status = 0, n
      !! printstring("Send command to ");  print symbol(target);  newline
      %result = "-- Bad target filestore " . to string(target) %c
         %unless first filestore <= target <= last filestore
      %result = "-- Undefined target filestore " . to string(target) %c
         %if filestore addresses(target) = 0
      f == filestore(target)
      semaphore wait(f_semaphore)
      %if f_context = 0 %start
         status = establish connection(target)
         %if status < 0 %start
            signal semaphore(f_semaphore)
            %result = "-- Connect to filestore " . %c
                      to string(target) . " rejected"
         %finish
      %finish
      %if command = FC logon %and f_Uno # 0 %start   
         signal semaphore(f_semaphore)
         %result = "-- Already logged on to " . to string(target)
      %else %if command = FC logoff %and f_Uno = 0
         ! Not logged on, so do nothing
         signal semaphore(f_semaphore)
         %result = ""
      %finish
      UXno = f_Uno %if UXno < 0
      response = "-- Dummy"
      sending = to string(command) . to string(UXno + '0') . parameters . SNL
      !! printstring(">>> ");  xprintstring(sending);  newline
      status = transact(f_context, charno(sending, 1), length(sending),
                        charno(response, 1), n)
      response = "-- Send command: " . ether errors(status) %c
         %and -> out %if status < 0
      %if n > 0 %and charno(response, n) = NL %start
         ! Non-packet response -- drop the trailing NewLine
         length(response) = n - 1
      %else
         ! No trailing NewLine.  Must be a packet response, so we'll let
         ! our caller worry about decoding it all....
         length(response) = n
      %finish
      !! printstring("<<< ");  xprintstring(response);  newline
      %if response # "" %and charno(response, 1) = '-' %start
         signal semaphore(f_semaphore)
         %result = response
      %finish
out:  %if command = FC logon %start
         n = H to I(response)
         f_Uno = n
      %else %if command = FC logoff
         f_uno = 0
      %finish
      signal semaphore(f_semaphore)
      %result = response
%end

%routine copy block(%integer n, %bytename from, to)
   D0 = D0 - 1
L: *move.b (A0)+, (A1)+
   *dbra D0, L
%end

%string(255)%fn make read request(%integer target, Xno,
                                  %integername next block,
                                  %integer block,
                                  %bytename buffer,
                                  %integername bytes)
   %bytearray b(0 : 532)
   %record(filestore fm)%name f
   %string(255) sending
   %string(*)%name response
   %integer status = 0, n, newline pos, i, expecting, got
      %result = "-- Bad target filestore " . to string(target) %c
         %unless first filestore <= target <= last filestore
      %result = "-- Undefined target filestore " . to string(target) %c
         %if filestore addresses(target) = 0
      f == filestore(target)
      semaphore wait(f_semaphore)
      %if f_context = 0 %start
         status = establish connection(target)
         %if status < 0 %start
            signal semaphore(f_semaphore)
            %result = "-- Connect to filestore " . %c
                      to string(target) . " rejected"
         %finish
      %finish
      !! printstring("R . ");  write(next block, 1);  write(block, 1);  newline
      ! Now for a horrible hack: the old-style filestores don't understand
      ! multi-block readDAs, just readSQs....  VAX doesn't even know about multi-
      ! block readSQs!
      %if target = 'B' %or target = 'C' %or target = 'M' %start
         %if block = next block %start
            ! Sequential access, so we can use a multi-block readSQ
            expecting = bytes >> 9
            %if expecting <= 0 %start
               signal semaphore(f_semaphore)
               next block = -1
               %result = "-- Dud byte count to <make read request>"
            %finish
            sending = to string(FC readSQ) . to string(Xno + '0') . %c
                      I to H(expecting) . SNL
         %else
            ! Non-sequential, convert it to single-block readDA
            sending = to string(FC readDA) . to string(Xno + '0') . %c
                      I to H(block) . SNL
            expecting = 1
         %finish
      %else %if target = 'V'
         ! VAX -- turn it into a single-block read (but only if it's sequential).
         %if block # next block %start
            signal semaphore(f_semaphore)
            next block = -1
            %result = "-- Unsupported non-sequential read to ECSVAX: " . %c
                      itos(block, 0) . " " . itos(next block, 0)
         %finish
         bytes = 512;  expecting = 1
         sending = to string(FC readSQ) . to string(Xno + '0') . SNL
      %else
         ! Must be a new-style filestore, so can use multi-block readDA
         expecting = bytes >> 9
         %if expecting <= 0 %start
            signal semaphore(f_semaphore)
            next block = -1
            %result = "-- Dud byte count to <make read request>"
         %finish
         sending = to string(FC readDA) . to string(Xno + '0') . %c
                   I to H(block) . "," . I to H(expecting) . SNL
      %finish
      bytes = 0
      !! printstring("R > ");  xprintstring(sending);  newline
      status = transact(f_context, charno(sending, 1), length(sending), b(1), n)
      %if status < 0 %start
         signal semaphore(f_semaphore)
         !! printstring("R ! ");  printstring(ether errors(status));  newline
         next block = -1
         %result = "-- Make read request: " . ether errors(status)
      %finish
      ! The first block of data has come back as part of the above call....
      newline pos = 531
      %for i = 1, 1, n %cycle
         newline pos = i %and %exit %if b(i) = NL
      %repeat
      b(0) = newline pos - 1;  ! Drop the NewLine
      response == string(addr(b(0)))
      !! printstring("R < ");  xprintstring(response);  newline
      %if response # "" %and charno(response, 1) = '-' %start
         signal semaphore(f_semaphore)
         next block = -1
         %result = response
      %finish
      got = n - newline pos
      copy block(got, b(newline pos + 1), buffer) %if got > 0
      bytes = bytes + got
      next block = next block + 1
      expecting = expecting - 1
      buffer == buffer [512]
      ! Now process any following blocks
      %while expecting > 0 %and got = 512 %cycle
         status = receive more(f_context, b(1), n)
         %if status < 0 %start
            signal semaphore(f_semaphore)
            !! printstring("R ! ");  printstring(ether errors(status));  newline
            next block = -1
            %result = "-- Make read request: " . ether errors(status)
         %finish
         newline pos = 531
         %for i = 1, 1, n %cycle
            newline pos = i %and %exit %if b(i) = NL
         %repeat
         b(0) = newline pos - 1;  ! Drop the NewLine
         response == string(addr(b(0)))
         !! printstring("R + ");  xprintstring(response);  newline
         %if response # "" %and charno(response, 1) = '-' %start
            signal semaphore(f_semaphore)
            next block = -1
            %result = response
         %finish
         got = n - newline pos
         %exit %if got <= 0;  ! Special for empty last block (avoid "copy")
         copy block(got, b(newline pos + 1), buffer)
         bytes = bytes + got
         next block = next block + 1
         expecting = expecting - 1
         buffer == buffer [512]
      %repeat
      signal semaphore(f_semaphore)
      next block = -1 %if got # 512
      %result = response
%end

%string(255)%fn make write request(%integer target, Xno, block, bytes,
                                   %bytename buffer)
   %bytearray b(0 : 532)
   %record(filestore fm)%name f
   %string(255) sending, response = "Dummy"
   %integer status, n
      %result = "-- Bad target filestore " . to string(target) %c
         %unless first filestore <= target <= last filestore
      %result = "-- Undefined target filestore " . to string(target) %c
         %if filestore addresses(target) = 0
      f == filestore(target)
      semaphore wait(f_semaphore)
      %if f_context = 0 %start
         status = establish connection(target)
         %if status < 0 %start
            signal semaphore(f_semaphore)
            %result = "-- Connect to filestore " . %c
                      to string(target) . " rejected"
         %finish
      %finish
      sending = to string(FC writeDA) . to string(Xno + '0') . %c
                I to H(block) . "," . I to H(bytes) . SNL
      string(addr(b(0))) = sending
      copy block(bytes, buffer, b(length(sending) + 1)) %if bytes > 0
      !! printstring("W > ");  xprintstring(sending);  newline
      status = transact(f_context, b(1), length(sending) + bytes,
                        charno(response, 1), n)
      %if status < 0 %start
         signal semaphore(f_semaphore)
         !! printstring("W ! ");  printstring(ether errors(status));  newline
         %result = "-- Make write request: " . ether errors(status)
      %finish
      length(response) = n - 1
      !! printstring("W < ");  xprintstring(response);  newline
      signal semaphore(f_semaphore)
      %result = response
%end

%string(255)%fn make packet request(%integer target, Uno, command,
                                    %string(255) parameters,
                                    %bytename buffer,
                                    %integername bytes)
   %bytearray b(0 : 532)
   %record(filestore fm)%name f
   %string(255) sending
   %string(*)%name response
   %integer status = 0, n, newline pos, i
      %result = "-- Bad target filestore " . to string(target) %c
         %unless first filestore <= target <= last filestore
      %result = "-- Undefined target filestore " . to string(target) %c
         %if filestore addresses(target) = 0
      f == filestore(target)
      semaphore wait(f_semaphore)
      %if f_context = 0 %start
         status = establish connection(target)
         %if status < 0 %start
            signal semaphore(f_semaphore)
            %result = "-- Connect to filestore " . %c
                      to string(target) . " rejected"
         %finish
      %finish
      bytes = 0
      Uno = f_Uno %if Uno < 0
      sending = to string(command) . to string(Uno + '0') . parameters . SNL
      !! printstring("P > ");  xprintstring(sending);  newline
      status = transact(f_context, charno(sending, 1), length(sending), b(1), n)
      %if status < 0 %start
         signal semaphore(f_semaphore)
         !! printstring("P ! ");  printstring(ether errors(status));  newline
         %result = "-- Make packet request: " . ether errors(status)
      %finish
      newline pos = 531
      %for i = 1, 1, n %cycle
         newline pos = i %and %exit %if b(i) = NL
      %repeat
      b(0) = newline pos - 1;  ! Drop the NewLine
      response == string(addr(b(0)))
      !! printstring("P < ");  xprintstring(response);  newline
      %if response # "" %and charno(response, 1) = '-' %start
         signal semaphore(f_semaphore)
         %result = response
      %finish
      bytes = n - newline pos
      copy block(bytes, b(newline pos + 1), buffer) %if bytes > 0
      signal semaphore(f_semaphore)
      %result = response
%end


! File tokens (issued by us, incorporating lower-level ones)

%recordformat file token fm(%integer filestore, Xno, next block)
%ownrecord(file token fm)%array our file tokens(1 : file tokens) = 0(*)
%ownrecord(semaphore fm) file token semaphore = 0

%record(file token fm)%map get new file token
   %record(file token fm)%name t
   %integer i
      semaphore wait(file token semaphore)
      %for i = 1, 1, file tokens %cycle
         t == our file tokens(i)
         %if t_Xno = 0 %start
            ! Found a free one
            t_Xno = -1
            signal semaphore(file token semaphore)
            %result == t
         %finish
      %repeat
      signal semaphore(file token semaphore)
      %result == nil
%end

%routine validate file token(%record(fs message fm)%name m, %integer allow)
   %record(file token fm)%name t
   %integer i
      %for i = 1, 1, file tokens %cycle
         %if m_file token = addr(our file tokens(i)) %start
            t == record(m_file token)
            %exit %if t_Xno <= 0 %and t_Xno # allow;  ! Invalid
            m_error code = 0
            %return
         %finish
      %repeat
      m_error code = -302;  m_status = -3
      m_textual response = "Invalid file token"
%end


! Error code interpretation

%routine set status(%record(fs message fm)%name m)
   %if m_error code = 0 %start
      m_status = 0
   %else
      m_status = -2;  ! Meantime
      m_textual response = "Unknown error " . itos(m_error code, 0)
   %finish
%end


! Filename munging.  Always fill in the target filestore from the first
! component of the filename

%routine determine filename(%record(fs message fm)%name m,
                            %string(255)%name filename)
   %record(path fm)%name p, last p
      p == m_filename
      m_fsys work = charno(p_key, 1)
      p == p_next
      filename = ""
      last p == p
      %while p ## nil %cycle
         filename = filename . ":" %if filename # ""
         filename = filename . p_key
         last p == p
         p == p_next
      %repeat
      filename = filename . ":" . itos(last p_version, 0) %c
         %if last p ## nil %and last p_version # 0
      !! printstring("Filename is ");  printstring(filename)
      !! printstring(" at ");  print symbol(m_fsys work);  newline
%end

%routine determine second filename(%record(fs message fm)%name m,
                                   %string(255)%name filename,
                                   %integername target filestore)
   %record(path fm)%name p, last p
      p == m_filename2
      target filestore = m_fsys work;  ! i.e. from first filename
      target filestore = charno(p_key, 1)
      p == p_next
      filename = ""
      last p == p
      %while p ## nil %cycle
         filename = filename . ":" %if filename # ""
         filename = filename . p_key
         last p == p
         p == p_next
      %repeat
      filename = filename . ":" . itos(last p_version, 0) %c
         %if last p ## nil %and last p_version # 0
      !! printstring("Filename is ");  printstring(filename)
      !! printstring(" at ");  print symbol(m_fsys work);  newline
%end

%routine split at newline(%string(*)%name s, d1, d2)
   %bytename ch
   %integer i
      d1 = "";  d2 = ""
      %return %if s = ""
      ch == charno(s, 1);  i = length(s)
      %while i > 0 %and ch # NL %cycle
         d1 = d1 . to string(ch)
         ch == ch [1];  i = i - 1
      %repeat
      ch == ch [1];  i = i - 1
      %while i > 0 %cycle
         d2 = d2 . to string(ch)
         ch == ch [1];  i = i -1
      %repeat
%end


! One action routine for each of the request (sub)types.

%ownbytearray root directory(0 : 16 * 512 - 1)
%owninteger root directory size = 0
%ownbytearray root buffer(0 : 511)

%routine copy root
   ! This routine copies the contents of a "register" buffer as supplied by
   ! an old-style filestore into the root directory.  It knows about the
   ! format supplied to it, and assumes that the buffer provided is correct.
   %integer n, name = 0, bad = 0
   %bytename reg
      %for n = 0, 1, 511 %cycle
         reg == root buffer(n)
         %if bad = 0 %and ('A' <= reg <= 'Z' %or '0' <= reg <= '9' %c
                           %or reg = '$' %or reg = '.' %c
                           %or reg = '_' %or reg = '#') %start
            root directory(root directory size) = reg
            root directory size = root directory size + 1
            name = 1
         %else %if reg = '*'
            bad = 1
         %else %if reg = ' ' %or reg = NL
            %if bad = 0 %and name # 0 %start
               root directory(root directory size) = ':'
               root directory size = root directory size + 1
               root directory(root directory size) = NL
               root directory size = root directory size + 1
            %finish
            bad = 0
            name = 0
         %finish
      %repeat
%end

%routine do open file(%record(fs message fm)%name m)
   %record(file token fm)%name file token
   %string(255) filename, response, size, pad
   %integer command, i, bytes
      !! printstring("Do open file: mode ");  phex2(m_mode)
      !! printstring(", compatible ");  phex2(m_compatible mode)
      !! printstring(", flags ");  phex(m_request flags);  newline
      !! show path(m_filename)
      m_response flags = 0;  m_byte count = 0;  m_file token = 0;  ! Provisionally
      %if m_mode & change file = 0 %start
         ! Open for reading only
         command = FC openR
      %else
         ! Open for writing.  Should we create a new one (unconditionally)?
         %if m_request flags & create flag = 0 %then command = FC openMod %c
                                               %else command = FC openW
      %finish
      ! Translate the name from list form
      determine filename(m, filename)
      %if filename = "" %start
         %if command = FC openR %start
            !! printstring("Get root directory for ")
            !! print symbol(m_fsys work);  newline
            %if m_fsys work = 'B' %or m_fsys work = 'C' %or m_fsys work = 'M' %start
               %if root directory size # 0 %start
                  m_error code = -303;  m_status = -3
                  m_textual response = "(F_H2) Root directory buffer busy"
                  %return
               %finish
               %for i = 0, 1, 15 %cycle
                  response = make packet request(m_fsys work, -1, '\',
                                                 to string(i + '0'),
                                                 root buffer(0), bytes)
                  %exit %if response # "" %and charno(response, 1) = '-'
                  %if bytes # 512 %start
                     m_error code = -303;  m_status = -3
                     m_textual response = "(F_H2) Dud register response size"
                     %return
                  %finish
                  copy root
               %repeat
               !! printstring("Root directory size is ")
               !! write(root directory size, 0);  newline
               file token == get new file token
               %if file token == nil %start
                  m_error code = -303;  m_status = -3
                  m_textual response = "(F_H2) No free file token"
                  root directory size = 0
               %else
                  file token_Xno = -2
                  m_file token = addr(file token)
                  m_response flags = 0;  m_byte count = root directory size
                  m_error code = 0;   m_status = 0
               %finish
               %return
            %else %if m_fsys work = 'V'
               m_error code = -303;  m_status = -3
               m_textual response = "(F_H2) Root not available from VAX"
               %return
            %else
               filename = "Local:"
               -> open real file
            %finish
         %else
            m_error code = -303;  m_status = -3
            m_textual response = "(F_H2) Invalid (write) operation on root directory"
            %return
         %finish
      %finish
open real file:
      ! Get a file token for the file
      file token == get new file token
      !! printstring("New file token is at ")
      !! phex(addr(file token));  newline
      %if file token == nil %start
         m_error code = -303;  m_status = -3
         m_textual response = "(F_H2) No free file token"
         %return
      %finish
      ! Open file file
      response = send command(m_fsys work, -1, command, filename)
      %if response # "" %and charno(response, 1) = '-' %start
         ! Open failed.  Drop the token & return error
         file token_Xno = 0
         m_error code = H to I(response);  m_status = -1
         m_textual response = response
         %return
      %finish
      file token_Xno = charno(response, 1) - '0'
      file token_filestore = m_fsys work
      file token_next block = 0
      %if command = FC openW %start
         m_byte count = 0
      %else
         %if length(response) < 5 %start
            ! Dud response
            file token_Xno = 0
            m_error code = -304;  m_status = -1
            m_textual response = "Dud (short) response from filestore"
            %return
         %finish
         response = sub string(response, 3, length(response))
         %unless response -> size . (",") . pad %start
            ! Dud response
            file token_Xno = 0
            m_error code = -304;  m_status = -1
            m_textual response = "Dud (missing fields) response from filestore"
            %return
         %finish
         m_byte count = 512 * H to I(size) - H to I(pad)
      %finish
      m_file token = addr(file token)
      m_response flags = 0
      m_error code = 0;   m_status = 0
%end

%routine do read data(%record(fs message fm)%name m)
   %record(file token fm)%name t
   %integer n
      validate file token(m, -2);  %return %if m_error code < 0
      t == record(m_file token)
      %if t_Xno > 0 %start
         m_textual response = make read request(t_filestore, t_Xno,
                                                t_next block, m_byte offset >> 9,
                                                m_data buffer, m_byte count)
         %if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
            m_error code = -1;  m_status = -1
         %else
            m_error code = 0;  m_status = 0
         %finish
      %else {%if t_Xno = -2
         ! Root directory buffer
         !! printstring("Root directory read: offset ");  write(m_byte offset, 0)
         !! printstring(", bytes ");  write(m_byte count, 0);  newline
         n = root directory size - m_byte offset
         %if n <= 0 %start
            !! printstring("End of root directory");  newline
            m_byte count = 0
            m_error code = 0;  m_status = 0
            %return
         %finish
         n = m_byte count %if n > m_byte count
         copy block(n, root directory(m_byte offset), m_data buffer) %if n > 0
         m_byte count = n
         m_error code = 0;  m_status = 0
         !! printstring("Returning ");  write(m_byte count, 0);  newline
      %finish
%end

%routine do write data(%record(fs message fm)%name m)
   %record(file token fm)%name t
      validate file token(m, 1);  %return %if m_error code < 0
      t == record(m_file token)
      m_textual response = make write request(t_filestore, t_Xno,
                                        m_byte offset >>9, m_byte count,
                                        m_data buffer)
      %if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
         m_error code = -1;  m_status = -1
      %else
         m_error code = 0;  m_status = 0
      %finish
      t_next block = -1
%end

%routine do close file(%record(fs message fm)%name m)
   %record(file token fm)%name t
      validate file token(m, -2);  %return %if m_error code < 0
      t == record(m_file token)
      %if t_Xno > 0 %start
         m_textual response = send command(t_filestore, t_Xno, FC close, "")
         %if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
            m_error code = -1;  m_status = -1
         %else
            m_error code = 0;  m_status = 0
         %finish
      %else {%if t_Xno = -2
         !! printstring("Close root directory");  newline
         root directory size = 0
      %finish
      t = 0
%end

!%routine do truncate file(%record(fs message fm)%name m)
!   m_error code = -1;  m_status = -3
!   m_textual response = "Subrequest (truncate file) not implemented yet"
!%end
!
!%routine do make accessible(%record(fs message fm)%name m)
!   m_error code = -1;  m_status = -3
!   m_textual response = "Subrequest (make accessible) not implemented yet"
!%end
!
!%routine do obtain attributes(%record(fs message fm)%name m, %integer type)
!   m_error code = -1;  m_status = -3
!   m_textual response = "Subrequest (obtain attributes) not implemented yet"
!%end

%routine do short form attributes(%record(fs message fm)%name m)
   %string(255) filename
   %integer pos
      determine filename(m, filename)
      !! printstring("Short form attributes: ");  printstring(filename);  newline
      m_textual response = send command(m_fsys work, -1, FC ninfo, filename)
      !! printstring("response: ");  xprintstring(m_textual response);  newline
      %if m_textual response = "" %or charno(m_textual response, 1) = '-' %start
         m_error code = -1;  m_status = -1
         %return
      %finish
      pos = 1
      ! Lose filename, then spaces...
      pos = pos + 1 %while pos < length(m_textual response) %c
         %and charno(m_textual response, pos) # ' '
      pos = pos + 1 %while pos < length(m_textual response) %c
         %and charno(m_textual response, pos) = ' '
      m_textual data = sub string(m_textual response, pos, length(m_textual response))
      m_status = 0;  m_error code = 0
%end

!%routine do modify attributes(%record(fs message fm)%name m, %integer type)
!   m_error code = -1;  m_status = -3
!   m_textual response = "Subrequest (modify attributes) not implemented yet"
!%end

%routine do create new directory(%record(fs message fm)%name m)
   %string(255) filename
      determine filename(m, filename)
      m_textual response = send command(m_fsys work, -1, FC credir, filename)
      %if m_textual response # "" %start
         m_error code = -1;  m_status = -1
      %else
         m_error code = 0;  m_status = 0
      %finish
%end

%routine do rename file(%record(fs message fm)%name m)
   ! We have to make sure here that we aren't being asked to rename
   ! from one filestore to another....
   %string(255) from, to
   %integer second filestore
      determine filename(m, from)
      determine second filename(m, to, second filestore)
      %if m_fsys work # second filestore %start
         m_error code = -1;  m_status = -1
         m_textual response = "-- Inter-filestore rename not allowed"
         %return
      %finish
      m_textual response = send command(m_fsys work, -1, FC rename,
                                 from . "," . to)
      %if m_textual response # "" %start
         m_error code = -1;  m_status = -1
      %else
         m_error code = 0;  m_status = 0
      %finish
%end

%routine do permit file(%record(fs message fm)%name m)
   %string(255) filename
      determine filename(m, filename)
      m_textual response = send command(m_fsys work, -1, FC permit,
                                        filename . "," . m_textual data)
      %if m_textual response # "" %start
         m_error code = -1;  m_status = -1
      %else
         m_error code = 0;  m_status = 0
      %finish
%end

%routine do copy file(%record(fs message fm)%name m)
   ! We have to make sure here that we aren't being asked to copy
   ! from one filestore to another (that should be done by our caller)....
   %string(255) from, to
   %integer second filestore
      determine filename(m, from)
      determine second filename(m, to, second filestore)
      %if m_fsys work # second filestore %start
         m_error code = -1;  m_status = -1
         m_textual response = "-- Inter-filestore copy not allowed"
         %return
      %finish
      m_textual response = send command(m_fsys work, -1, FC copyfile,
                                 from . "," . to)
      %if m_textual response # "" %start
         m_error code = -1;  m_status = -1
      %else
         m_error code = 0;  m_status = 0
      %finish
%end

%routine do delete file(%record(fs message fm)%name m)
   %string(255) filename
      determine filename(m, filename)
      m_textual response = send command(m_fsys work, -1, FC delete, filename)
      %if m_textual response # "" %start
         m_error code = -1;  m_status = -1
      %else
         m_error code = 0;  m_status = 0
      %finish
%end

!%routine do generate unique name(%record(fs message fm)%name m)
!   m_error code = -1;  m_status = -3
!   m_textual response = "Subrequest (unique name) not implemented yet"
!%end
!
!%routine do timestamp enquiry(%record(fs message fm)%name m)
!   m_error code = -1;  m_status = -3
!   m_textual response = "Subrequest (timestamp enquiry) not implemented yet"
!%end

%routine do filestore logon(%record(fs message fm)%name m)
   %record(path fm)%name p
      p == m_filename
      m_textual response = send command(m_request specific, -1, FC logon,
                                  p_key . "," . m_textual data)
      %if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
         m_error code = -1;  m_status = -1
      %else
         m_error code = 0;  m_status = 0
      %finish
%end

%routine do filestore logoff(%record(fs message fm)%name m)
   m_textual response = send command(m_request specific, -1, FC logoff, "")
   break connection(m_request specific)
   %if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
      m_error code = -1;  m_status = -1
   %else
      m_error code = 0;  m_status = 0
   %finish
%end

%routine do filestore quote(%record(fs message fm)%name m)
   %record(path fm)%name p
      p == m_filename
      m_textual response = send command(m_request specific, -1, FC quote, p_key)
      %if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
         m_error code = -1;  m_status = -1
      %else
         m_error code = 0;  m_status = 0
      %finish
%end

%routine do set pass(%record(fs message fm)%name m)
   %string(255) param
      %if m_request specific = 'B' %or m_request specific = 'C' %c
      %or m_request specific = 'M' %start
         ! Old filestore: only new password required (P2 is username)
         param = m_textual data
      %else
         ! Must be new filestore: old password required in P2 as verifier
         param = m_textual data . "," . m_textual data2
      %finish
      m_textual response = send command(m_request specific, -1, FC pass, param)
      %if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
         m_error code = -1;  m_status = -1
      %else
         m_error code = 0;  m_status = 0
      %finish
%end


! Main code of local file system process.  Loop, reading the mailbox and
! calling a code-demultiplexing routine to interpret the subcodes as
! appropriate.

%owninteger which = 0
%ownrecord(semaphore fm) which sem = 0

%routine local filesystem process
   %record(fs message fm)%name m
   %ownrecord(semaphore fm) disaster = 0
   %record(poa fm)%name P
   %switch standard(-1 : last standard request)
   %switch specific(-1 : last old request)
   %integer i, L set, L clear
      !%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("X_H2: 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(2, ":N");  select input(2)
      open output(2, ":T");  select output(2)
      setup semaphore(disaster)
      semaphore wait(which sem)
      L set = 16_100 << which
      which = which + 1
      signal semaphore(which sem)
      L clear = \ L set
      %cycle
         !! printstring("Waiting for message to ");  phex(addr(request mailbox))
         !! newline
         m == receive message(request mailbox)
!L!      lights set B(L set)
         !! printstring("H2 filesystem request: code ");  phex(m_request)
         !! printstring(", reply box ");  phex(addr(m_system header_reply))
         !! printstring(", sema ");  phex(addr(m_system header_reply_semaphore))
         !! newline
         %if m_request & filesystem mask = 0 %start
            i = m_request & request mask
            -> standard(i) %if 0 <= i <= last standard request
         %else %if m_request & filesystem mask = old style request
            i = m_request & request mask
            -> specific(i) %if 0 <= i <= last old request
         %finish
dud request:
         m_error code= -1;  m_status = -1
         m_textual response = "Unknown request code"
         -> send reply

standard(interpret filename request & request mask):
         ! We don't know how to do this yet, so we just kid on that there
         ! were no redirectors along the way...
         m_error code = 0;  m_status = 0;  m_textual response = ""
         m_components translated = 0;  ! This, at least, is true
         -> send reply

standard(open file request & request mask):
         do open file(m)
         -> send reply

standard(close file request & request mask):
         do close file(m)
         -> send reply

standard(read data request & request mask):
         do read data(m)
         -> send reply

standard(write data request & request mask):
         do write data(m)
         -> send reply

!standard(truncate file request & request mask):
!         do truncate file(m)
!         -> send reply
!
!standard(make accessible request & request mask):
!         do make accessible(m)
!         -> send reply

standard(create directory request & request mask):
         do create new directory(m)
         -> send reply

standard(remove file request & request mask):
         do delete file(m)
         -> send reply

standard(rename file request & request mask):
         do rename file(m)
         -> send reply

standard(textual file attributes request & request mask):
         do short form attributes(m)
         -> send reply

standard(textual permit file request & request mask):
         do permit file(m)
         -> send reply

specific(old logon request & request mask):
         do filestore logon(m)
         -> send reply

specific(old logoff request & request mask):
         do filestore logoff(m)
         -> send reply

specific(old quote request & request mask):
         do filestore quote(m)
         -> send reply

specific(old copy file request & request mask):
         do copy file(m)
         -> send reply

specific(old set pass request & request mask):
         do set pass(m)
         -> send reply

standard(*):
specific(*):
unimplemented request:
         m_error code= -1;  m_status = -1
         m_textual response = "Unimplemented request code"
send reply:
         !! printstring("Replying to ");  phex(addr(m_system header_reply))
         !! printstring(", sema ");  phex(addr(m_system header_reply_semaphore))
         !! printstring(", status ");  write(m_status, 0)
         !! printstring(", error code ");  write(m_error code, 0)
         !! printstring(", text """);  printstring(m_textual response)
         !! print symbol('"');  newline
         m_followup mailbox == request mailbox
         send message(m, m_system header_reply, nil)
!L!      lights and B(L clear)
      %repeat
%end

%begin
   %record(process fm)%name p
   %integer i
   %label x
      open input(3, ":T");  select input(3)
      open output(3, ":T");  select output(3)
      setup semaphore(request semaphore)
      setup mailbox(request mailbox, request semaphore)
      setup semaphore(file token semaphore)
      signal semaphore(file token semaphore)
      setup semaphore(which sem)
      signal semaphore(which sem)
      %for i = first filestore, 1, last filestore %cycle
         setup semaphore(filestore(i)_semaphore)
         signal semaphore(filestore(i)_semaphore)
      %repeat
      FS insert(H2 file system mailbox, addr(request mailbox))
      !! printstring("Starting ");  write(processes, 0)
      !! printstring(" remote (H2) file system processes");  newline
      p == create process(10240, addr(x), priority, nil) %for i = 1, 1, processes - 1
      set priority(nil, priority)
      {} printstring("F_H2: ");  write(free store, 0)
      {} printstring(" free");  newline
      ! Fall through to form one of the processes....
x:    local filesystem process
      ! Never returns...
%end %of %program