home *** CD-ROM | disk | FTP | other *** search
/ Beijing Paradise BBS Backup / PARADISE.ISO / software / BBSDOORW / SHSUCD11.ZIP / SERVTASK.ADB < prev    next >
Text File  |  1995-06-29  |  17KB  |  540 lines
  1. --************************************************************************
  2. --
  3. --  SERVTASK.ADB               Version 3.0
  4. --
  5. --  A copyright-reserved, free use program.
  6. --  (c)John H. McCoy, 1994,1995 Sam Houston St. Univ., TX 77341-2206
  7. --
  8. --************************************************************************
  9.  
  10. with drivers; use drivers;
  11. with cdroms; use cdroms;
  12. with video, cursor, box;
  13. with calendar;
  14. with tty;
  15. with text_io; use text_io;
  16. with unchecked_deallocation;
  17. with common_display_types; use common_display_types;
  18.  
  19. package body ServerTasks is
  20.  
  21.  
  22. MaxBlocks   : constant := 15;       -- NETBIOS limits dta to 64K -1 bytes
  23. BlockSize   : constant := 2048;     -- assume cooked mode only
  24.  
  25. type UserEntries is record
  26.      SessionNumber: types.byte;
  27.      Client       : String16;
  28.      StartTime    : calendar.time;
  29.      LastAccess   : calendar.time;
  30.   end record;
  31.  
  32. type UsersArray is array (natural range <>) of UserEntries;
  33. type UsersAccess is access UsersArray;
  34.  
  35. task type LCalls is
  36.   entry Que(Ncb: ncbAccess);
  37.   entry Xit;
  38.   entry Cancel;
  39.   entry ShutDown;
  40.   pragma priority (19);
  41. end LCalls;
  42. for LCalls'storage_size use 512;
  43.  
  44. N_Listen : LCalls;
  45.  
  46. NCBInit: NetBiosCmdBlks;
  47.  
  48. task body Consoles is
  49.  
  50.   MaxClients   : integer;
  51.   Users        : UsersAccess;
  52.   LastUser     : integer := 0;
  53.   LastCD       : integer;
  54.   I            : integer;
  55.   ServerName   : string16;
  56.   DriverName   : string16;
  57.   DeviceStatus : DEV_ReturnCodes;
  58.   CDStatus     : DW;
  59.   Stop         : boolean := false;
  60.   DriverUnit   : types.byte;
  61.   CDLabel      : string11;
  62.   StatusCode   : string(1..1);
  63.  
  64.   task type Displays is
  65.       entry init;
  66.       entry Shutdown;
  67.   end Displays;
  68.   Display: Displays;
  69.  
  70.   task body Displays is
  71.     Stop    : boolean:= false;
  72.     procedure paint is
  73.     begin
  74.       tty.put(2,39,TOD(calendar.clock));
  75.       tty.put(1,76,"   ");
  76.       tty.put(1,76,integer'image(LastUser));
  77.       video.scroll_up(0,4,0,23,79);
  78.       if LastUser <= 0 then
  79.         tty.put(4,8,"No Users Connected.");
  80.       else
  81.         for j in reverse 1..LastUser loop
  82.           tty.put(4,0,types.byte'image(Users(j).SessionNumber));
  83.           tty.put(4,5,Users(j).Client);
  84.           tty.put(4,22,TOD(Users(j).StartTime));
  85.           tty.put(4,29,TOD(Users(j).LastAccess));
  86.           if LastUser > 20 then
  87.             delay(0.10);
  88.           end if;
  89.           if j /= 1 then
  90.             video.scroll_down(1,4,0,23,40);
  91.           end if;
  92.         end loop;
  93.       end if;
  94.       for i in reverse 0..LastCd loop
  95.         delay(0.0);
  96.         GetCDStatus(i,DeviceStatus,CDStatus,DriverName,DriverUnit,CDLabel);
  97.         delay(0.0);
  98.         tty.put(row_range(4), column_range(37),integer'image(i));
  99.         tty.put(row_range(4), column_range(41),DriverName);
  100.         tty.put(row_range(4), column_range(59),
  101.                   integer'image(integer(DriverUnit)));
  102.         if DeviceStatus = DeviceDone then
  103.           StatusCode(1) := ASCII.nul;
  104.           if (CDStatus(2) and 8) /= 0 then
  105.             CDLabel := "---Empty---";
  106.           elsif (CDStatus(1) and 2) /= 0 then
  107.             StatusCode  := "U";
  108.           else
  109.             StatusCode  := "L";
  110.           end if;
  111.           tty.put(row_range(4), column_range(62),CDLabel);
  112.           tty.put(row_range(4), column_range(74),StatusCode);
  113.         elsif ((DeviceStatus and DeviceNotReady)/= word_to_W(0)) then
  114.           tty.put(row_range(4), column_range(62),
  115.                       "Drive not ready. ");
  116.         else
  117.           tty.put(row_range(4), column_range(62),
  118.                       "                  ");
  119.         end if;
  120.         if i /= 0 then
  121.           video.scroll_down(1,4,37,23,79);
  122.         end if;
  123.       end loop;
  124.     end paint;
  125.  
  126.   begin
  127.     accept init;                      -- holds til main has loaded everything
  128.     video.clear_screen;
  129.     box.draw(0,0,2,79,box.double_sided);
  130.     tty.put(0,13," Sam Houston State University CD-ROM SERVER 3.0 ");
  131.     tty.put(1,1,"Server:");
  132.     tty.put(1,9,ServerName);
  133.     tty.put(1,27,"Up: ");
  134.     tty.put(1,31,MDY(calendar.clock));
  135.     tty.put(1,40,TOD(calendar.clock));
  136.     tty.put(1,48,"Max Users:");
  137.     tty.put(1,58,integer'image(MaxClients));
  138.     tty.put(1,63,"Active Users:");
  139.     tty.put(1,76,integer'image(LastUser));
  140.     tty.put(2,10," Users ");
  141.     tty.put(2,32," Time:       ");
  142.     tty.put(2,58," CDs ");
  143.     tty.put(3,0," No   User            First  Last");
  144.     tty.put(3,37,"No   Driver/File    Unit    ID     Status");
  145.     paint;
  146.     loop
  147.       select
  148.         delay(20.0);
  149.         paint;
  150.         cursor.move(24,0);
  151.        or
  152.         accept Shutdown do
  153.           Stop := True;
  154.         end Shutdown;
  155.       end select;
  156.       exit when Stop;
  157.     end loop;
  158.   end Displays;
  159.  
  160. begin
  161.  
  162.   accept Init(MaxSessions: integer;
  163.               LastCd     : integer;
  164.               ServerName : string16 ) do
  165.     MaxClients          := MaxSessions;
  166.     Consoles.LastCd     := LastCd;
  167.     Consoles.ServerName := ServerName;
  168.   end Init;
  169.  
  170.   Users := new UsersArray(0..MaxClients);
  171.   Display.init;
  172.  
  173.   loop
  174.       select
  175.         accept SignIn(SessionNumber: types.byte;
  176.                       Client       : String16) do
  177.           LastUser       := LastUser + 1;
  178.           Users(LastUser).SessionNumber:= SessionNumber;
  179.           Users(LastUser).Client:= Client;
  180.           Users(LastUser).StartTime := calendar.clock;
  181.           Users(LastUser).LastAccess := calendar.clock;
  182.         end SignIn;
  183.       or
  184.         accept SignOut(SessionNumber: types.byte) do
  185.           Users(0).SessionNumber := SessionNumber;
  186.           I := LastUser;
  187.           loop
  188.             exit when Users(I).SessionNumber = SessionNumber;
  189.             I := I - 1;
  190.           end loop;
  191.           LastUser := LastUser-1;
  192.           for j in I..LastUser loop
  193.             Users(j) := Users(j + 1);
  194.           end loop;
  195.         end SignOut;
  196.       or
  197.         accept CkIn(SessionNumber: types.byte) do
  198.           Users(0).SessionNumber := SessionNumber;
  199.           I := LastUser;
  200.           loop
  201.             exit when Users(I).SessionNumber = SessionNumber;
  202.             I := I - 1;
  203.           end loop;
  204.           Users(I).LastAccess := calendar.clock;
  205.         end CkIn;
  206.       or
  207.         accept Shutdown do
  208.           Display.Shutdown;
  209.           Stop := True;
  210.         end Shutdown;
  211.       end select;
  212.     exit when Stop;
  213.   end loop;
  214. end Consoles;
  215.  
  216. task body Sessions is
  217.   rh           : rhs;
  218.   pkt          : pkts;
  219.   dta          : bytesAccess;
  220.   NCB, NCBinit : ncbAccess := new NetBiosCmdBlks;
  221.   NCBclr       : ncbAccess := new NetBiosCmdBlks;
  222.   Net          : NetAccess;
  223.   LocalSession : types.byte;
  224.   DtaSave      : DW;
  225.   CB           : CBAccess := new CBs;
  226.   CbSave       : DW;
  227.   CdSubUnits   : types.byte;
  228.   Hub          : SchedulerAccess;
  229.   AllocError   : boolean;
  230.   procedure Wait is
  231.   begin
  232.     loop
  233.       delay (0.0);                      -- give other tasks a chance
  234.       exit when (NCB.CommandStatus /= NB_CommandPending);
  235.     end loop;
  236.   end Wait;
  237.  
  238.   procedure SendRH is
  239.   begin
  240.      -- send rh back to client
  241.      pkt := Rhs_to_Pkts(rh);
  242.      pkt(3..pkts'last-1) := pkt(4..pkts'last);
  243.      NCB.all              := NCBinit.all;
  244.      NCB.Command          := NB_Send_NoWait;
  245.      NCB.BufferPtr        := pkt(1)'address;
  246.      NCB.BufferLength     := word(rh.length);
  247.      Net.Call(NCB);
  248.      Wait;
  249.   end SendRH;
  250.  
  251. begin
  252.   accept Start(Net       : NetAccess;
  253.                LocalName : string16;
  254.                SubUnits  : types.byte;
  255.                Scheduler : SchedulerAccess ) do
  256.     Sessions.Net  := Net;
  257.     NCBclr.name   := LocalName;
  258.     CdSubUnits    := SubUnits;
  259.     Hub           := Scheduler;
  260.   end Start;
  261.  
  262.  
  263. que: loop                             -- new sessions start here
  264.  
  265.   loop
  266.     NCB.all         := NCBclr.all;
  267.     NCB.Command     := NB_Listen_NoWait;
  268.     NCB.CallName(1) := '*';             -- listen for any caller
  269.     Hub.Listen(Net, NCB);               -- get in queue for a call
  270.                                         -- won't return until a session request
  271.                                         -- is received or NET is terminated.
  272.     case NCB.ReturnCode is
  273.       when NB_Ok   =>  exit;
  274.       when NB_CommandCanceled  => exit Que;   -- only occurs if shutdown
  275.       when others => delay(0.0);
  276.     end case;
  277.  
  278.   end loop;
  279.  
  280.   LocalSession         := NCB.LocalSession;
  281.   NCBinit.LanAdapter   := NCB.LanAdapter;
  282.   NCBinit.LocalSession := NCB.LocalSession;
  283.   NCBinit.CallName     := NCB.CallName;
  284.   NCBinit.Name         := NCB.Name;
  285.   NCBinit.NameNumber   := NCB.NameNumber;
  286.  
  287.   Console.SignIn(SessionNumber => LocalSession,
  288.                  Client        => NCBinit.CallName);
  289.  
  290. session: loop                       -- intra session loop starts here
  291.  
  292.   -- get request header
  293.  
  294.   NCB.all              := NCBinit.all;
  295.   NCB.Command          := NB_Receive_NoWait;
  296.   NCB.BufferPtr        := pkt(1)'address;
  297.   NCB.BufferLength     := pkts'last;
  298.   Net.Call(NCB);
  299.   Wait;
  300.   exit session when NCB.ReturnCode /= NB_Ok;      -- abort session
  301.  
  302.   Console.CkIn(SessionNumber => LocalSession);
  303.   pkt(4..pkts'last) := pkt(3..pkts'last-1);
  304.   pkt(3)    := 0;
  305.   rh        := Pkts_to_Rhs(pkt);
  306.  
  307.   case rh.rhX.command is
  308.     when DeviceReadLong =>
  309.       if rh.rhX.ReadLong.SectorsToRead = Word_to_W(0) then
  310.         rh.rhX.ReadLong.Status := DeviceDone;
  311.         -- send rh back to client
  312.         SendRH;
  313.         exit session when NCB.ReturnCode /= NB_Ok;
  314.       else
  315.         if W_to_Word(rh.rhX.ReadLong.SectorsToRead) > MaxBlocks then
  316.           -- request to big, chop to fit.
  317.           rh.rhX.ReadLong.SectorsToRead := Word_to_W(MaxBlocks);
  318.         end if;
  319.         loop -- retry storage allocation until enough memory to alloc
  320.           begin
  321.           -- local block for exception handler
  322.           dta := new types.bytes(1..
  323.                      W_to_Word(rh.rhX.ReadLong.SectorsToRead)*(BlockSize));
  324.           AllocError := false;
  325.           exception
  326.             when storage_error    => AllocError := true;
  327.           end;  -- end of local block
  328.           exit when not AllocError;
  329.           delay(0.0);
  330.         end loop;
  331.           --  pass rh on to the CD
  332.           dtaSave := rh.rhX.ReadLong.DtaPtr;       -- save remote dta ptr
  333.           rh.rhX.ReadLong.dtaPtr:=bytesAccess_to_DW(dta);  -- point to local
  334.           CDs.Call(rh);                             -- device status now in rhX
  335.           rh.rhX.ReadLong.DtaPtr := dtaSave;       -- restore for return
  336.           -- send rh back to client
  337.           SendRH;
  338.           if NCB.ReturnCode /= NB_Ok then
  339.              ZapBytes(dta);
  340.              exit session;
  341.           end if;
  342.           -- send dta back to client
  343.           NCB.all := NCBinit.all;
  344.           NCB.BufferLength:= W_to_Word(rh.rhX.ReadLong.SectorsToRead)*(BlockSize);
  345.           if rh.rhX.ReadLong.status = DeviceDone
  346.              and then NCB.BufferLength /= 0 then
  347.             NCB.Command          := NB_Send_NoWait;
  348.             NCB.BufferPtr        := dta(1)'address;
  349.             Net.Call(NCB);
  350.             Wait;
  351.             if NCB.ReturnCode /= NB_Ok then
  352.               ZapBytes(dta);
  353.               exit session;
  354.             end if;
  355.           end if;
  356.       ZapBytes(dta);
  357.       end if;
  358.     when DeviceIoctlInput =>
  359.         --  get the Command Block from client
  360.         NCB.all              := NCBinit.all;
  361.         NCB.Command          := NB_Receive_NoWait;
  362.         NCB.BufferPtr        := CB(1)'address;
  363.         NCB.BufferLength     := W_to_word(rh.rhX.IoctlIn.TransferCount);
  364.         Net.Call(NCB);              -- get the CB
  365.         Wait;                               -- until command completes
  366.         exit session when NCB.ReturnCode /= NB_Ok;  -- abort session
  367.         --  pass it on to the CD
  368.         CBSave       := rh.rhX.IoctlIn.CBPtr;            -- save remote CB ptr
  369.         rh.rhX.IoctlIn.CBPtr := SA_to_DW(CB(1)'address); -- point to local CB
  370.         CDs.Call(rh);     -- device status now in rhX
  371.         -- send rh back to client
  372.         rh.rhX.IoctlIn.CBPtr := CBSave;        -- set dta back for return
  373.         SendRH;
  374.         exit session when NCB.ReturnCode /= NB_Ok;   -- aborts session
  375.         -- send CB back to client
  376.         NCB.all              := NCBinit.all;
  377.         NCB.Command          := NB_Send_NoWait;
  378.         NCB.BufferPtr        := CB(1)'address;
  379.         NCB.BufferLength     := W_to_Word(rh.rhX.IoctlIn.TransferCount);
  380.         Net.Call(NCB);
  381.         Wait;
  382.         exit session when NCB.ReturnCode /= NB_Ok;   -- aborts session
  383.     when DeviceIoctlOutput =>
  384.         --  get the Command Block from client
  385.         NCB.all              := NCBinit.all;
  386.         NCB.Command          := NB_Receive_NoWait;
  387.         NCB.BufferPtr        := CB(1)'address;
  388.         NCB.BufferLength     := W_to_word(rh.rhX.IoctlOut.TransferCount);
  389.         Net.Call(NCB);              -- get the CB
  390.         Wait;                               -- until command completes
  391.         exit session when NCB.ReturnCode /= NB_Ok;  -- abort session
  392.         --  pass it on to the CD
  393.         CBSave       := rh.rhX.IoctlOut.CBPtr;   -- save remote CB ptr
  394.         rh.rhX.IoctlOut.CBPtr := SA_to_DW(CB(1)'address); -- point to local CB
  395.         CDs.Call(rh);     -- device status now in rhX
  396.         -- send rh back to client
  397.         rh.rhX.IoctlOut.CBPtr         := CBSave;       -- set dta back for return
  398.         SendRH;
  399.         exit session when NCB.ReturnCode /= NB_Ok;   -- aborts session
  400.     when DeviceInit =>
  401.         rh.rhX.Init.NumberUnits := CDSubUnits;  -- for MSCDEX only, client
  402.         rh.rhX.Init.Status := DeviceDone;       -- always tells DOS 1
  403.         -- send rh back to client
  404.         SendRH;
  405.         exit session when NCB.ReturnCode /= NB_Ok;   -- aborts session
  406.     when DeviceSeek | DeviceReadLongPrefetch =>
  407.         --  pass it on to the CD
  408.         CDs.Call(rh);     -- device status now in rhX
  409.         -- send rh back to client
  410.         SendRH;
  411.         exit session when NCB.ReturnCode /= NB_Ok;   -- aborts session
  412.  
  413.     when Others =>      -- should never come here, but !!!
  414.         rh.rhX.Other.Status := DeviceDone OR
  415.                                DeviceUnknownCommand OR
  416.                                DeviceError;
  417.         SendRH;          -- just send it back
  418.         exit session when NCB.ReturnCode /= NB_Ok;   -- aborts session
  419.  
  420.   end case;
  421.  
  422. end loop session;
  423.  
  424.   -- session aborted to get here
  425.  
  426.   Console.SignOut(SessionNumber => LocalSession);
  427.  
  428.   if (NCB.ReturnCode /= NB_SessionClosed) and then
  429.      (NCB.ReturnCode /= NB_SessionEndedAbnormally) then
  430.      NetHangUp (LocalSession);
  431.   end if;
  432.  
  433. end loop que;
  434.  
  435.   -- only comes here on shutdown so no need to clean up
  436.  
  437. exception
  438.  
  439.   -- not safe to zap the NCBs unless the NB lsn using it has terminated
  440.  
  441.   when others =>  tty.put(24,55,"Queue terminated.");
  442.  
  443. end Sessions;
  444.  
  445. task body Schedulers is
  446.   Stop   : boolean:= False;
  447. begin
  448.  
  449. loop
  450.   select
  451.     accept Shutdown do
  452.       Stop := True;
  453.     end Shutdown;
  454.   or
  455.     accept Listen(Net : NetAccess; Ncb : ncbAccess ) do
  456.       N_Listen.Que(NCB);
  457.       loop
  458.         exit when NCB.CommandStatus /= NB_CommandPending;
  459.         delay (0.0);
  460.       end loop;
  461.       N_Listen.Xit;
  462.     end Listen;
  463.   end select;
  464.   exit when Stop;
  465.   delay(0.0);
  466. end loop;
  467.  
  468. end Schedulers;
  469.  
  470. task body LCalls is
  471.   Stop   : boolean := False;
  472.   Holding: boolean:= False;
  473.   NcbListen: ncbAccess := new NetBiosCmdBlks;
  474. begin
  475.   loop
  476.     select
  477.       accept Que(Ncb: ncbAccess) do
  478.         NcbListen.bufferptr:=ncbAccess_to_SA(NCB);
  479.         if Holding then
  480.             NCB.ReturnCode    := NB_CommandCanceled;
  481.             NCB.CommandStatus := NB_CommandCanceled;
  482.         else
  483.             NetBiosCall (Ncb => Ncb);
  484.         end if;
  485.       end Que;
  486.     or
  487.       accept Xit do
  488.         NcbListen.bufferptr := ncbAccess_to_SA(null);
  489.       end Xit;
  490.     or
  491.       accept Cancel do
  492.         Holding := True;
  493.         if not(SA_to_ncbAccess(NcbListen.BufferPtr) = null) then
  494.           NcbListen.Command := NB_Cancel;
  495.           NetBiosCall (NcbListen);
  496.         end if;
  497.       end Cancel;
  498.     or
  499.       accept ShutDown do
  500.         Stop := True;
  501.       end ShutDown;
  502.     end select;
  503.     exit when Stop;
  504.   end loop;
  505. end LCalls;
  506.  
  507. task body Nets is
  508.   Stop   : boolean := False;
  509.   Holding: boolean:= False;
  510.  
  511.   begin
  512.     accept Start(Name: string16) do
  513.       NetAddName(NetName => Name);
  514.     end Start;
  515.   loop
  516.     select
  517.       accept Call(Ncb: ncbAccess) do
  518.         if Holding then
  519.           NCB.ReturnCode    := NB_CommandCanceled;
  520.           NCB.CommandStatus := NB_CommandCanceled;
  521.         else
  522.           NetBiosCall (Ncb => Ncb);
  523.         end if;
  524.       end Call;
  525.     or
  526.       accept Hold do
  527.         Holding := True;
  528.         N_Listen.Cancel;
  529.       end Hold;
  530.     or
  531.       accept ShutDown do
  532.         Stop := True;
  533.         N_Listen.Shutdown;
  534.       end ShutDown;
  535.     end select;
  536.     exit when Stop;
  537.   end loop;
  538. end Nets;
  539.  
  540. end ServerTasks;