%begin
{**********************************************************************}
{*              APMTEL Server - based on P_H2 by GDMR                 *}
{*                  Andrew Ness  1988  CS4 project                    *}
{*               Modded version - see mod list below                  *}
{*                                                                    *}
{*                    Version 3.2  2 Nov 1988                         *}
{**********************************************************************}

!JHB 21/06/88:   New BBC command format <channel>.<page> as one command.
!JHB 16/06/88:   Device :Q becomes :Q:0
!                'D' command with parameter "!" forces a %stop, "*" a restart.
!                Range check on chars A0-FA performed here not in Beeb
!                15 sec timeout on page acquisition
!JHB  7/07/88:   Code to handle CANCEL.    Message to Beeb now "c.pppssss"
!JHB  1/09/88:   Now transmits 25th line

%conststring (255) version = "Version 3.1 17 Oct 1988"

%externalstring(47) copyright %alias "APMTEL_(C)" = %c
         "APMTEL (C) 1987, EUCSD Andie Ness"


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

%constinteger           processes = 4              {Number of listeners
%constinteger           max contexts = 4           {Number of listeners
%constinteger           ether max = 536            {Maximum packet size
%constinteger           process size = 10240       {The memory each process is given
%constinteger           tty channel = 0            {I/O channel to terminal
%constinteger           qsart channel = 1          {I/O channel to RS-232/423

%conststring(31)        facility name = "PORT_0_FACILITY_16"     {MAGIC NUMBER

!"inc:util.imp"
%system%string(255)%fn%spec ITOS(%integer v,p)
%externalroutinespec PHEX2(%integer x)
%externalroutinespec PHEX(%integer x)

%include                "Moose:Mouse.Inc"
%include                "GDMR_E:2Meg.Inc"
%include                "GDMR_H:IO_F.Inc"
%include                "GDMR_H:DateTime.Inc"

%conststring(31) context table name = "APMTEL_PORT_TABLE"

!
!  The context record is the store for all the information about the clients
!
%recordformat context fm(%integer remote address, remote port, local port,
                         %integer tag,
                         %integer open datestamp, transmit datestamp,
                         %record(ether request fm) ether request,
                         %bytename buffer)

%ownrecord(context fm)%array context info(1 : max contexts) = 0(*)

!
!  The mutex to stop multiple access to the BBC 
!  (actually the QSART board)
!
%ownrecord(semaphore fm) beeb semaphore = 0

!
!  And other system semaphores
!
%ownrecord(semaphore fm) our request semaphore = 0
%ownrecord(mailbox fm) our request mailbox = 0
%ownrecord(mailbox fm)%name ether request mailbox == nil


! Protocol interpreter.  Take a request (context, bytes, buffer), interpret it,
! and return a response in the same buffer.  Special request (bytes < 0) asks
! for the context to be cleared down (reconnect, probably).  These are
! sorted alphabetically so we can see easily what hasn't been used.

! reserved                   '@'       { Can't be used for some reason!
%constinteger APMTEL START = 'A'
%constinteger APMTEL PAGE  = 'B'
%constinteger APMTEL CHAN  = 'C'
%constinteger APMTEL STOP  = 'D'
%constinteger APMTEL CANCEL= 'E'
! unused                     '_'

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

! Uno and Xno table formats.  Note that access to these tables is implicitly
! synchronised by the protocol: Uno 0 is read-only, while all other Unos and
! Xnos are context-specific.  We only have a read outstanding on a context while
! we are not processing a request, hence each Uno or Xno can only be active
! once.
!
! HOOK FOR AUTHORISATION FEATURE
!

%conststring(31) Uno table name = "APMTEL_UNO_TABLE"

%recordformat p0 buffer fm(%record(message fm) system part,
                           %byte ra, rp,
                           (%bytearray x(0 : 532) %c
                        %or %byte facility %c
                            %or %string(127) reply text))



%systemintegerfnspec    global heap get(%integer amount)

%externalintegerfnspec  q testsymbol
%externalroutinespec    FS insert(%string(31) what, %integer where)
%externalpredicatespec  FS lookup(%string(15) what, %integername result)

%conststring(31)        fsys state name = "FSYS_STATE"
%ownintegername         fsys state == nil

!
!  QSART board declarations
!
%recordformat           DEVICE FM (%byte bstatus,data,intvec,dstatus,x,mode,y,command)
%ownrecord              (device fm) %name qsart
%constinteger           dev add = 16_7FFC0,
                        mode1=16_4e,
                        mode2=16_30,
                        comm=16_37,
                        errormask=16_38,
                        txie=1,
                        rxie=2,
                        reset=8


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


%routine oplog(%integer context, %string (255) text)
   !Put TEXT out to server console in standard timestamped format
   ptime
   printstring("APMTEL->")
   %if context>=0 %then write(context, 2) %and space
   printstring(text); newline
%end


%string (255) %fn zstring(%string(255) s)
   %string (255) t
   %integer i, ch
   %result="" %if s = ""
   t=""
   %for i = 1, 1, length(s) %cycle
      ch = charno(s, i)
      %if ' ' <= ch <= '~' %start
         t=t.tostring(ch)
      %else
         t=t."<".itos(ch,0).">"
      %finish
   %repeat
   %result=t
%end


! Communications stuff follows...

%integerfn new context tag
   %owninteger tag = 0
      tag = tag + 1
      %result = tag
%end

%routine print context info(%integer context)
   %record(context fm)%name context data
      context data == context info(context)
      write(context, 0);  print symbol('(')
      phex2(context data_local port);  printstring(").")
      phex(context data_tag);  printstring(" -> ")
      phex2(context data_remote address)
      print symbol('.');  phex2(context data_remote port)
%end

%routine receive next request(%integername context, tag, bytes, status)
   %record(ether request fm)%name r
      !printstring("Receive next request");  newline
      r == receive message(our request mailbox)
      context = r_context
      tag = r_tag
      bytes = r_bytes
      status = r_status
%end

%routine start receive(%integer context, tag)
   %record(context fm)%name p
      %unless 0 < context <= max contexts %start
         oplog(context, "?????? *** Starting receive on dud context ")
         %return
      %finish
      p == context info(context)
      %if p_remote address = 0 %start
         oplog(context, "Starting receive on closed context ")
      %else
         p_ether request_code = ether old read
         p_ether request_context = context
         p_ether request_tag = tag
         p_ether request_timeout = -1;  ! None
         p_ether request_buffer == p_buffer
         send message(p_ether request, ether request mailbox, our request mailbox)
      %finish
%end

%predicate send response(%integer context, tag, bytes)
%record(semaphore fm) semaphore = 0
%record(mailbox fm) mailbox = 0
%record(ether request fm) request = 0
%record(ether request fm)%name reply
%record(context fm)%name p
   %if 0 <= context <= max contexts %start
      p == context info(context)
      %if p_remote address = 0 %start
         oplog(context, "Sending to closed context ")
         %false
      %else
         p_transmit datestamp = get datestamp
         setup semaphore(semaphore)
         setup mailbox(mailbox, semaphore)
         setup message(request, size of(request))
         request_code = ether old write
         request_context = context
         request_tag = tag
         request_buffer == p_buffer
         request_bytes = bytes
         send message(request, ether request mailbox, mailbox)
         reply == receive message(mailbox)
         %if reply_status < 0 %start
            oplog(context, " (send response): ".ether errors(reply_status))
            %false
         %else
            %true
         %finish
      %finish
   %else
      oplog(context, "*** Sending to dud context ???")
      %false
   %finish
%end

%integerfn initialise client comms(%integer ra, rp)
   %record(semaphore fm) semaphore = 0
   %record(mailbox fm) mailbox = 0
   %record(ether request fm) request = 0
   %record(ether request fm)%name reply == nil
   %record(context fm)%name p
      setup semaphore(semaphore)
      setup mailbox(mailbox, semaphore)
      setup message(request, size of(request))
      request_code = ether old define
      request_ra = ra
      request_rp = rp
      send message(request, ether request mailbox, mailbox)
      reply == receive message(mailbox)
      %result = reply_status %if reply_status < 0
      ptime
      printstring("APMTEL->");  write(reply_context, 0)
      printstring(" Local port ");  phex2(reply_lp);  printstring(" connected to ")
      phex2(ra);  print symbol('.');  phex2(rp);  newline
      p == context info(reply_context)
      p_remote address = ra
      p_remote port = rp
      p_local port = reply_lp
      p_open datestamp = get datestamp
      p_tag = new context tag
      setup message(p_ether request, size of(p_ether request))
      start receive(reply_context, p_tag)
      %result = reply_lp
%end

%routine drop context(%integer context, tag)
   %record(semaphore fm) semaphore = 0
   %record(mailbox fm) mailbox = 0
   %record(ether request fm) request = 0
   %record(ether request fm)%name reply == nil
   %record(context fm)%name p
      %unless 0 < context <= max contexts %start
         oplog(context, "Drop dud context ???")
         %return
      %finish
      p == context info(context);  p_remote address = 0
      setup semaphore(semaphore)
      setup mailbox(mailbox, semaphore)
      setup message(request, size of(request))
      request_code = ether old undefine
      request_context = context
      request_tag = tag
      send message(request, ether request mailbox, mailbox)
      reply == receive message(mailbox)
      %if reply_status < 0 %start
         oplog(context, " (drop context): ".ether errors(reply_status))
      %finish
%end


%routine move(%integer bytes, %bytename from, to)
   !Move BYTES bytes from FROM to TO. Pinched from IE.
   !If addr(FROM) < addr(TO) do the move from the top down to allow overlap
   %return %if Bytes = 0 %or  From == To

   %if Addr (To) < Addr (From) %start
      *Subq.l #1, d0
   f loop:
      *move.b (a0)+, (a1)+
      *dbra   d0, f loop
   %else
      *add.l  d0, a0
      *add.l  d0, a1
      *subq.l #1, d0
   b loop:
      *move.b -(a0), -(a1)
      *dbra   d0, b loop
   %finish
%end

%routine copy string(%string(255) s, %bytename buffer, %integername pos)
   ! **Assume** that there's room!
   %integer i
      %return %if s = ""
!!      move(length(s), charno(s, 1), buffer[pos]); pos=pos+length(s)
      %for i = 1, 1, length(s) %cycle
         buffer [pos] = charno(s, i)
         pos = pos + 1
      %repeat
%end

!! %routine copy bytes(%bytearray from(0:31,0:39) , %integer start,bytes,
!!                     %bytename buffer, %integername pos)
!!    %while bytes > 0 %cycle
!!       buffer [pos] = from((pos+start)//40, rem(pos+start,40));  pos = pos + 1
!!       bytes = bytes - 1
!!    %repeat
!! %end

%predicate split request(%bytename buf, 
                         %bytename comm,
                         %string(255) %name rest,
                         %integer len)
%integer i
   comm= buf[0];
   rest=""
   %for i=1,1,len-1 %cycle
      rest = rest.tostring(buf[i]) %unless buf[i]=0 %or buf[i]=NL
   %repeat
   %true
%end



%routine cleardown context(%integer tag, Uno)
%end


   %constinteger BBCack='O', BBCnak='N'

   %routine put(%record (device fm) %name dev,  %Integer sym)
      %integer state = 1, msec
      %on 0 %start
         %stop %if event_sub = 1
         -> s1 %if state = 1
         -> s2 %if state = 2
      %finish
       msec = realtime + 10
   s1: %While dev_dstatus&1=0 %cycle; %return %if realtime >= msec; %repeat
       state = 2
   s2: dev_data =sym
   %End
   
   %routine put q0 line(%string (255) s)
      %integer i
      %return %if s=""
      %for i=1,1,length(s) %cycle
          put(qsart, charno(s, i))
      %repeat
      put(qsart, 13)
   %end

   %integerfn handshake(%integer context, expected, timeout)
      !Loop till we get either the expected ack/nak or the unexpected nak/ack
      !or get bored or see a cancel request.
      !We check the mailbox every 2 seconds to see if a cancel came in.
      %integer unexpected, c, timer, ctimer
      unexpected=BBCack+BBCnak-expected
      timer = realtime+timeout; ctimer = realtime + 2000

      %integerfn cancel queued for(%integer context)
         %integer rc
         %bytename buff
         %record(ether request fm)%name r
         r == dequeue(our request mailbox_queue)
         %result=0 %if r == nil
         %if r_context=context %start
            buff == context info(context)_buffer
            %if buff = APMTEL CANCEL %start
               requeue(r, our request mailbox_queue)
               %result=1
            %finish
         %finish
         rc=cancel queued for(context)
         requeue(r, our request mailbox_queue)
         %result=rc
      %end

      %cycle
         c = q test symbol
         %if c>=0 %start
            %result=0 %if c=expected
            %result=c %if c=unexpected
         %else
            %result=-1 %if realtime>=timer
         %finish
         %if realtime>=ctimer %start
            ctimer = ctimer + 2000
            %result = -2 %if cancel queued for(context)#0
         %finish
      %repeat
   %end

%routine interpret request(%integer context, tag, request bytes,
                           %bytename buffer,
                           %integername response bytes)
%bytearray data(0 : ethermax)
%bytename data buffer == data(0)
%string(255) textual response
%integer buffer pos = 0, data bytes = -1, status, rc
%constinteger trows=25, tcols=40
%ownbytearray page(0:1279)=0(*)
%string(255) p1
%ownstring(3) %array channel(0:max contexts) = "1" (*)
%byte command
%switch op(first FC : last FC)

%integerfn acquire page(%string(255) p, %c
                        %bytearrayname page(0:1279), %integer context)
   %integer i,j,c,t,rc,mag,row

   semaphore wait(beeb semaphore)
   open input(qsart channel,":Q:0")
   select input(qsart channel)

   put q0 line(channel(context).".".p)
!!   rc = handshake(context, BBCack, 2000) ;!Expect an instantaneous ack...
!!   %if rc#0 %start ;!  (Try once more if that failed...)
!!      put q0 line(channel(context).".".p)
!!      rc = handshake(context, BBCack, 2000)
!!   %finish
   %cycle; %repeatuntil readsymbol = BBCack; rc=0

   !... followed later by either a nak or the ack followed by the page
   %if rc=0 %start
      rc = handshake(context, BBCack, 60 * 1000) ;!This is longer than the BBC's timer

      %if rc=0 %start
         t=realtime+5000 
         !Page should not take > 5 seconds to transmit from receipt of ack.
         %for i=0,1,1279 %cycle
            rc=3 %and ->return %if realtime>t
            c = readsymbol
            c = c & 16_7F %if 16_A0<= c <=16_FA
            page(i) = c
         %repeat
         rc=0
      %finish
   %finish

return:
   close input
   select input(tty channel)
   signal semaphore(beeb semaphore)
   %result=rc
%end
   

     %if request bytes < 0 %or buffer = 4 %or buffer = 12 %start
         ! Cleardown request
         cleardown context(tag, 0)
         drop context(context, tag) %if request bytes > 0
         response bytes = -1
         %return
      %finish

      %unless split request(buffer,command,P1,request bytes) %start
         -> not implemented
      %finish
      -> op(command)

op(APMTEL START):
      oplog(context, " STARTING. User = ".zstring(p1))
      channel(context)= "1"                             {BBC 1}
      textual response = "HI THERE"
      -> send with newline
                     
op(APMTEL PAGE):
      oplog(context, " ASKING FOR PAGE ".zstring(p1))
      rc = acquire page(P1,page,context)
oplog(-1,"got it")
      %if rc=0 %start ;!Got it OK
         move(512, page(0), buffer); buffer pos=512
         %if send response(context, tag, buffer pos) %start
            move(512, page(512), buffer); buffer pos=512
            %if send response(context, tag, buffer pos) %start
            %finish
            buffer pos = 0
         %finish
            textual response= "PAGE ".p1." SENT OK"
            -> send with newline
      %else ;!Some failure
         oplog(context, "Page request fails . ".itos(rc,-1))
         textual response = "PAGE ACQUISITION FAILS ".itos(rc,-1); status = -1
         -> send with newline
      %finish
         
op(APMTEL CHAN):
      oplog(context, "CHANNEL ".p1." SELECTED")
      textual response = "OK"
      channel(context) = p1
      -> send with newline

op(APMTEL CANCEL):
      oplog(context, " cancelled request")
      textual response = "OK"
      -> send with newline

op(APMTEL STOP):
      oplog(context, " stopped ")
      cleardown context(context, 0);
      textual response = "Bye"
      %if p1="!" %start ;!Diagnostic halt
         %signal 15,1
      %elseif p1="*" ;!Diagnostic restart
         %signal 15,2
      %finish
      -> send with newline

op(*):
not implemented:
      textual response = "Pardon ?"
send with newline:
      copy string(textual response,buffer, buffer pos)
      buffer [buffer pos] = NL;  response bytes = buffer pos + 1
      %return

send textual error:
      %if status < 0 %start
         copy string("-? ", buffer, buffer pos)
      %else
         copy string("-> ", buffer, buffer pos)
      %finish
      -> send with newline
%end

%integerfn interpreter process
   %record(context fm)%name p
   %integer bytes, context, tag, status
   %bytearray x(0 : 3)
   %ownrecord(semaphore fm) disaster = 0
   %record(poa fm)%name process
   %integer i
      select input(0)
      select output(0)
      setup semaphore(disaster)
      %cycle
         receive next request(context, tag, bytes, status)
         %if 0 < context <= max contexts %and status = ether success %start
            p == context info(context)
            %if p_buffer = 4 %or p_buffer = 12 %start
               interpret request(context, tag, bytes, p_buffer, bytes)
               ! Don't start another receive operation.
            %else
               interpret request(context, tag, bytes, p_buffer, bytes)
               %if bytes >= 0 %and send response(context, tag, bytes) %start;  %finish
               start receive(context, tag)
            %finish
         %else
            interpret request(context, tag, -1, x(0), bytes) %c
               %if 0 < context <= max contexts
            ! Don't start another receive operation.  It'll be done for
            ! us when the (re)connection is completed.
         %finish
      %repeat
%end

   %record(p0 buffer fm)%name p0 buffer
   %record(mailbox fm) our p0 mailbox = 0
   %record(semaphore fm) our p0 semaphore = 0
   %record(process fm)%name created
   %record(context fm)%name p
   %ownrecord(semaphore fm) disaster = 0
   %record(poa fm)%name process
   %integer i, rc
   %label x
!
!Initialise the QSART input channel.
!
      open output(qsart channel,":Q:0")
      open input(qsart channel,":Q:0")

      select input(qsart channel)
      select output(0)

      qsart == record(dev add)
      i=0
      %cycle
         put q0 line("+")
         rc=handshake(-1, BBCnak, 2000)
         oplog(-1, "Polling Teletext receiver")
         i=i+1
      %repeatuntil rc=0 %or i=5
      %if rc=0 %then oplog(-1, "OK.") %else %c
      oplog(-1, "*** Warning: Teletext receiver not responding")

      select input(0)
      setup semaphore(disaster)
      %if FS lookup(ether mailbox name, i) %start
         ether request mailbox == record(i)
      %else
         oplog(-1, "No ether mailbox??")
         %stop
      %finish
      setup semaphore(our p0 semaphore)
      setup semaphore(beeb semaphore)
      signal semaphore(beeb semaphore);                  ! Prevent wait
      setup mailbox(our p0 mailbox, our p0 semaphore)
      FS insert(facility name, addr(our p0 mailbox))
      setup semaphore(our request semaphore)
      setup mailbox(our request mailbox, our request semaphore)
      context info(i)_buffer == byteinteger(global heap get(ether max + 16)) %c
         %for i = 1, 1, max contexts
      FS insert(context table name, addr(context info(1)))
      !
      ! Start the interpreter processes here....
      !
      created == create process(process size, addr(x), 6, nil) %c
         %for i = 1, 1, processes

total restart:
      created == nil;  ! Don't want junk diagnostics
      oplog(-1, version)
!!      oplog(-1, "Started with ".itos(free store, 0)." free store listening .")
      ! Now wait for port 0 messages and act on them
      %cycle
         p0 buffer == receive message(our p0 mailbox)
         %if fsys state == nil %start
            %if FS lookup(fsys state name, i) %start
               fsys state == integer(i)
               %if fsys state & 1 = 0 %start
                  ! Local file system isn't running yet
                  p0 buffer_reply text = "-? Local filesystem not initialised" . SNL
                  -> reply
               %finish
            %else
               p0 buffer_reply text = "-? No local filesystem??"
               -> reply
            %finish
         %else %if fsys state & 1 = 0
            ! Local file system isn't running yet
            p0 buffer_reply text = "-? Local filesystem not initialised" . SNL
            -> reply
         %finish
!First have a look to see if we already know about this
! client -- we'll have to clear it down if we find one.
         %for i = 1, 1, max contexts %cycle
            p == context info(i)
            %if p_remote address = p0 buffer_ra %c
                  %and p_remote port = p0 buffer_rp %start
               oplog(i, "Client already known ")
               drop context(i, p_tag)
               %exit
            %finish
         %repeat
         ! Now get a new port for the client and make the initial read.
         i = initialise client comms(p0 buffer_ra, p0 buffer_rp)
         %if i > 0 %then p0 buffer_reply text = to string(i + '0') . SNL %c
                   %else p0 buffer_reply text = "-? No free contexts" . SNL
reply:   send message(p0 buffer, p0 buffer_system part_reply, nil)
      %repeat
x:    i=interpreter process

%end %of %program