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

%constinteger processes = 1
%constinteger priority = 6
%constinteger file tokens = 32
%constinteger max roots = 32

%constinteger T Read File   = 1
%constinteger T Modify File = 2
%constinteger T Create File = 3
%constinteger T Dir Listing = 4

%include "b:Moose:Mouse.Inc"
%include "GDMR_H:FSysAcc.Inc"
%include "GDMR_H:FacMess.Inc"
%include "nfsd:udpint.inc"
%include "nfsd:nfs.inc"
%include "nfsd:mount.inc"
%include "nfsd:errors.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

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

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

%recordformat file token fm(%record(mailbox fm)%name followup mailbox,
                            %record(UDPStreamfm) UDP stream, 
                            %record(fhandlefm) fhandle,
                            %string(15) domain,
                            %string(15) user,
                            %integer size,
                            %integer mode,
                            %record(dirptrfm) dirptr)

%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_followup mailbox == nil %start
            ! Found a free one
            t_followup mailbox == request mailbox
            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)
   %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_followup mailbox == nil;  ! Invalid
            m_error code = 0
            %return
         %finish
      %repeat
      m_error code = -302;  m_status = -3
      m_error text = "Invalid file token"
%end

%routine zap (%record(file token fm)%name t)
   t=0
%end

%recordformat rootfm    (%string(31)        host,
                         %string(127)       path,
                         %record(fhandlefm) fhandle,
                         %integer           blocksize)

%ownrecord(rootfm)%array  roots (1:maxroots) =0(*)
%owninteger last root = 0

%integerfn get file handle (%string(31) host, %string(127) path, 
                            %record(fhandlefm)%name fhandle)
   %record(rootfm)%name root
   %record(UDPstreamfm) c
   %integer i, x, status

   %for i = 1, 1, last root %cycle
      root == roots(i)
      %if root_host = host %and root_path = path %start
         fhandle = root_fhandle
         %result = 0
      %finish
   %repeat

{} Printstring("Mounting ".path." on ".host);newline
   
   c_uid = -1; c_gid = -1

   x = connect to mnt (host, status, c)
   %result = status %if status # 0

   x = mnt mnt (c, status, path, fhandle)
   x = udp close stream (c)
   %result = status %if status # 0

   last root = last root + 1
   root == roots(lastroot)
   root_host = host; root_path = path; root_fhandle = fhandle

   %result = 0
%end      

%integerfn lookup file (%record(udpstreamfm)%name c, %string(127) filename,
                        %record(fhandlefm) did, %record(fhandlefm)%name fid,
                        %integername size)
   %integer x, status
   %record(diropargsfm) dir
   %record(diropresfm)  res

   dir_fhandle = did
   dir_filename = filename
   x = NFS lookup (c, status, dir, res)
      %result = status %if status # 0
   fid = res_fhandle
   size = res_fattr_size
   %result = 0
%end

%integerfn create file (%record(udpstreamfm)%name c, %string(127) filename,
                        %record(fhandlefm) did, %record(fhandlefm)%name fid)
   %integer x, status
   %record(diropresfm) res
   %record(diropargsfm) dir
   %record(sattrfm) sattr=0
   
   dir_fhandle = did
   dir_filename = filename

   sattr_mode = 8_0100777
   sattr_uid = c_uid; sattr_gid = c_gid
   sattr_size = 1

   x = NFS Create (c, status, dir, sattr, res)
      %result = status %if status # 0
   fid = res_fhandle
   %result = 0
%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_error text = "Unknown error " . itos(m_error code, 0)
   %finish
%end

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

%routine do open file(%record(fs message fm)%name m)
   %record(file token fm)%name file token
   %record(UDPStreamfm)%name c
   %integer mode, x, status
   %record(pathfm)%name p
   %record(fhandlefm) fhandle, dhandle
   %string(31) host
   %string(127) root

   %integerfn guddle (%record(dirptrfm)%name d)
      %record(direntfm)%name f
      %integer siz = 0

      f == d_root
      %while f ## nil %cycle
         siz = siz + length(f_filename)+1
         f == f_next
      %repeat
      %result = siz
   %end

      !! printstring("Do open file: mode ");  phex2(m_access mode)
      !! printstring(", compatible ");  phex2(m_compatible mode)
      !! printstring(", flags ");  phex(m_request flags);  newline
      !! show path(m_filename)
      m_response flags = 0;  m_bytes = 0;  m_file token = 0;  ! Provisionally

   %if m_access mode & change file = 0 %start
      ! open for reading only
      mode = T Read File
   %else
      %if m_request flags & create flag = 0 %then mode = T Modify File %c
                                            %else mode = T Create File
   %finish
   p == m_filename; host = p_key

   file token == get new file token
   %if file token == NIL %start
      m_error code = -1; m_status = -1
      m_error text = "(NFS) No free file token"
      %return
   %finish
   c == file token_UDP stream

   p == p_next
   root = p_key

   x = get file handle (host, root, dhandle)
   %if x # 0 %start
      zap (file token)
      m_error code = -1; m_status = -1
      m_error text = "(NFS) Failed to mount root ".root
   %finish

   c_uid = 38; c_gid = 20 {*** should get these from m_access ***}      

   x = connect to nfs (host, c)

   p == p_next
   %while p ## nil %cycle
      %if p_key = "" %start
         mode = T Dir Listing
         x = NFS Read Dir (c, status, dhandle, filetoken_dirptr)
         file token_size = guddle (filetoken_dirptr)
         %if status # 0 %start
            x = udp close stream (c)
            zap (file token)
            m_error code = -1; m_status = -1
            m_error text = "Failed to read directory"
            %return
         %finish
      %else
         %if mode = T Create File %and p_next == NIL %start 
            x = create file (c, p_key, dhandle, fhandle)
            %if x # 0 %start
               x = udp close stream (c)
               zap (file token)
               m_error code = -1; m_status = -1
               m_error text = "Failed to create file"
               %return
            %finish
            %exit
         %else
            x = lookup file (c, p_key, dhandle, fhandle, file token_size)
            %if x # 0 %start
               x = udp close stream (c)           
               zap (file token)
               m_error code = -1; m_status = -1
               m_error text = "Failed to open file"
               %return
            %finish
            dhandle = fhandle
         %finish
      %finish
      p == p_next
   %repeat

   file token_fhandle = fhandle
   file token_mode = mode

   m_file token = addr(file token)
   m_bytes = file token_size
   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
   %record(fattrfm) fattr
   %integer n, cnt, status, x, ad, sad
   %record(direntfm)%name f, dead

   %routine plant (%string(127) s, %integername ad)
      %integer i

      %for i = 1, 1, length (s) %cycle
         byteinteger(ad) = charno(s,i)
         ad = ad + 1
      %repeat
      byteinteger (ad) = nl
      ad = ad + 1
   %end

   validate file token(m);  %return %if m_error code < 0
   t == record(m_file token)

 Printstring ("Read "); write(m_bytes,0); printstring(" bytes from ")
 write(m_block,0);printstring (" to "); phex(addr(m_buffer));newline

   %if t_mode = T Read File %or t_mode = T Modify File %start
      x = NFS Read (t_udp stream,
                  status,t_fhandle,m_block<<9,512,addr(m_buffer),cnt,fattr)
      %if status # 0 %start
         m_error code = -1; m_status = -1
         printstring("NFS Read = ")
         write(status,0);newline
         m_error text = "(NFS) Failure while reading"
      %else
         m_bytes = cnt
         m_error code = 0; m_status = 0
      %finish
   %elseif t_mode = T Dir Listing
      m_bytes = 0; ad = addr(m_buffer) ; sad = ad
      f == t_dirptr_root
      %while f ## NIL %cycle
         plant (f_filename,ad)
         dead == f
         f == f_next
         dispose (dead)
      %repeat
      m_bytes = ad - sad
      t_dirptr_root == NIL
      m_error code = 0; m_status = 0
   %else
      m_error code = -1; m_status = -1
      m_error text = "(NFS) can't write to read-only file"
   %finish
%end

%routine do write data(%record(fs message fm)%name m)
   %record(file token fm)%name t
      validate file token(m);  %return %if m_error code < 0
      t == record(m_file token)
%end

%routine do close file(%record(fs message fm)%name m)
   %record(file token fm)%name t
   %integer x

   validate file token(m);  %return %if m_error code < 0
   t == record(m_file token)

   x = udp close stream (t_udp stream)
   zap (t)
%end

%routine do truncate file(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "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_error text = "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_error text = "Subrequest (obtain attributes) not implemented yet"
%end

%routine do short form attributes(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "Subrequest (short form attributes) not implemented yet"
%end

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

%routine do list directory contents(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "Subrequest (list directory contents) not implemented yet"
%end

%routine do insert directory entry(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "Subrequest (insert directory entry) not implemented yet"
%end

%routine do remove directory entry(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "Subrequest (remove directory entry) not implemented yet"
%end

%routine do create new directory(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "Subrequest (create new directory) not implemented yet"
%end

%routine do rename file(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "Subrequest (rename file) not implemented yet"
%end

%routine do copy file(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "Subrequest (copy file) not implemented yet"
%end

%routine do exchange files(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "Subrequest (exchange files) not implemented yet"
%end

%routine do delete file(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "Subrequest (delete file) not implemented yet"
%end

%routine do generate unique name(%record(fs message fm)%name m)
   m_error code = -1;  m_status = -3
   m_error text = "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_error text = "Subrequest (timestamp enquiry) not implemented yet"
%end

! Request code demultiplexing routines, one for each of the major request
! codes.  These just switch on the subcodes....

%routine data access(%record(fs message fm)%name m)
   %if m_subcode = open file subcode %start
      do open file(m)
   %else %if m_subcode = read data subcode
      do read data(m)
   %else %if m_subcode = write data subcode
      do write data(m)
   %else %if m_subcode = close file subcode
      do close file(m)
   %else %if m_subcode = truncate file subcode
      do truncate file(m)
   %else %if m_subcode = make accessible subcode
      do make accessible(m)
   %else
      m_error code = -1;  m_status = -1
      m_error text = "Subrequest not recognised"
   %finish
%end

%routine file attributes access(%record(fs message fm)%name m)
   %if m_subcode = obtain attributes subcode %start
      do obtain attributes(m, 0)
   %else %if m_subcode = obtain attributes token subcode
      do obtain attributes(m, 1)
   %else %if m_subcode = short form attributes subcode
      do short form attributes(m)
   %else %if m_subcode = modify attributes subcode
      do modify attributes(m, 0)
   %else %if m_subcode = modify attributes token subcode
      do modify attributes(m, 1)
   %else
      m_error code = -1;  m_status = -1
      m_error text = "Subrequest not recognised"
   %finish
%end

%routine directory access(%record(fs message fm)%name m)
   %if m_subcode = list directory contents subcode %start
      do list directory contents(m)
   %else %if m_subcode = insert directory entry subcode
      do insert directory entry(m)
   %else %if m_subcode = remove directory entry subcode
      do remove directory entry(m)
   %else %if m_subcode = create new directory subcode
      do create new directory(m)
   %else
      m_error code = -1;  m_status = -1
      m_error text = "Subrequest not recognised"
   %finish
%end

%routine miscellaneous file operation(%record(fs message fm)%name m)
   %if m_subcode = rename file subcode %start
      do rename file(m)
   %else %if m_subcode = copy file subcode
      do copy file(m)
   %else %if m_subcode = exchange files subcode
      do exchange files(m)
   %else %if m_subcode = delete file subcode
      do delete file(m)
   %else %if m_subcode = translate redirections subcode
      ! Null operation, since we don't know about redirections.
      ! Just return success, and nothing translated.
      m_status = 0;  m_error code = 0
      m_components translated = 0
   %else
      m_error code = -1;  m_status = -1
      m_error text = "Subrequest not recognised"
   %finish
%end

%routine miscellaneous other operation(%record(fs message fm)%name m)
   %if m_subcode = generate unique name subcode %start
      do generate unique name(m)
   %else %if m_subcode = timestamp enquiry subcode
      do timestamp enquiry(m)
   %else
      m_error code = -1;  m_status = -1
      m_error text = "Subrequest not recognised"
   %finish
%end

!%routine nonstandard operation(%record(fs message fm)%name m)
!   %if m_subcode = 0 %start
!      do filestore logon(m)
!   %else %if m_subcode = 1
!      do filestore logoff(m)
!   %else %if m_subcode = 2
!      do filestore quote(m)
!   %else
!      m_error code = -1;  m_status = -1
!      m_error text = "Subrequest (nonstandard) not recognised"
!   %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.

%routine local filesystem process
   %record(fs message fm)%name m
   %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("NFSP: 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)
      mark %if POA_heap_level = 1
      %cycle
         !! printstring("Waiting for message to ");  phex(addr(request mailbox))
         !! newline
         m == receive message(request mailbox)
         !! printstring("Code is ");  write(m_code, 0);  newline
         %if m_code = data access code %start
            data access(m)
         %else %if m_code = file attributes access code
            file attributes access(m)
         %else %if m_code = directory access code
            directory access(m)
         %else %if m_code = miscellaneous file operation code
            miscellaneous file operation(m)
         %else %if m_code = miscellaneous other operation code
            miscellaneous other operation(m)
!         %else %if m_code = 128
!            nonstandard operation(m)
         %else
            m_error code= -1;  m_status = -1
            m_error text = "Unknown request code"
         %finish
         !! printstring("Replying, status ");  write(m_status, 0)
         !! printstring(", error code ");  write(m_error code, 0)
         !! printstring(", text """);  printstring(m_error text)
         !! print symbol('"');  newline
         send message(m, m_system part_reply, nil)
      %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)
      FS insert(NFS file system mailbox, addr(request mailbox))
      {} printstring("Starting ");  write(processes, 0)
      {} printstring(" NFS process");  newline
!      p == create process(10240, addr(x), priority, nil) %for i = 1, 1, processes - 1
      set priority(nil, priority)
      {} printstring("NFSP: ");  write(free store, 0)
      {} printstring(" free");  newline
      ! Fall through to form one of the processes....
x:    local filesystem process
      ! Never returns...
%end %of %program