ServerLoop.pas

   1 UNIT ServerLoop;
   2
   3 INTERFACE
   4 uses MemStream,NetAddr;
   5
   6 procedure Main;
   7
   8 {#Message handling#}
   9 type tSMsg=object
  10  Source: ^tNetAddr;
  11  Length: {Long}Word;
  12  Data: pointer;
  13  stream: tMemoryStream;
  14  channel: word;
  15  end;
  16 type tMessageHandler=procedure(msg:tSMsg);
  17 procedure SetMsgHandler(OpCode:byte; handler:tMessageHandler);
  18 procedure SetHiMsgHandler(handler:tMessageHandler);
  19
  20 {#Sheduling and watching#}
  21 type tFDEventHandler=procedure(ev:Word) of object;
  22 type tOnTimer=procedure of object;
  23 procedure WatchFD(fd:tHandle; h:tFDEventHandler);
  24 procedure Shedule(timeout{ms}: LongWord; h:tOnTimer);
  25 procedure UnShedule(h:tOnTimer);
  26  {note unshed will fail when called from OnTimer proc}
  27
  28 IMPLEMENTATION
  29
  30 USES SysUtils,Sockets,UnixType,BaseUnix
  31      ,Unix
  32      ;
  33
  34 {aim for most simple implementation, since could be extended anytime}
  35
  36 var s_inet:tSocket;
  37
  38 type tPollTop=0..7;
  39 var pollArr: packed array [tPollTop] of tPollFd;
  40 type tFdHndDsc=record
  41  cb: tFDEventHandler; {proc+object}
  42  end;
  43 var pollHnd: array [tPollTop] of tFdHndDsc;
  44 var pollTop: tPollTop;
  45
  46 var hnd: array [1..36] of tMessageHandler;
  47 var HiHnd: tMessageHandler;
  48
  49 type tSheduled_ptr=^tSheduled; tSheduled=record
  50  left:LongWord;
  51  cb:tOnTimer;
  52  next:tSheduled_ptr;
  53  end;
  54 var ShedTop: ^tSheduled;
  55 var ShedUU: ^tSheduled;
  56 var LastShed: UnixType.timeval;
  57 var PollTimeout:LongInt;
  58
  59 procedure SC(fn:pointer; retval:cint);
  60  begin
  61   if retval < 0 then begin
  62    raise eXception.Create(Format('Socket error %d operation %P',[SocketError,fn]));
  63   end;
  64  end;
  65
  66 procedure s_SetupInet;
  67  var bind_addr:tInetSockAddr;
  68  begin
  69   with bind_addr do begin
  70    family:=AF_INET;
  71    port:=htons(3511);
  72    addr:=0; {any}
  73    s_inet:=fpSocket(family,SOCK_DGRAM,IPPROTO_UDP);
  74    SC(@fpSocket,s_inet);
  75   end;
  76   SC(@fpBind,fpBind(s_inet,@bind_addr,sizeof(bind_addr)));
  77   with PollArr[0] do begin
  78    fd:=s_inet;
  79    events:=pollIN;
  80    revents:=0;
  81   end;
  82  end;
  83
  84 var Terminated:boolean=false;
  85
  86 procedure SendMessage(const data; len:word; const rcpt:tSockAddr );
  87  var rc:Integer;
  88  begin
  89  SC(@fpsendto,fpsendto(s_inet,@data,len,0,@rcpt,sizeof(sockaddr_in)));
  90 end;
  91
  92 procedure SignalHandler(sig:cint);CDecl;
  93  begin
  94   writeln;
  95   if terminated then raise eControlC.Create('CtrlC DoubleTap') ;
  96   Terminated:=true;
  97   writeln('Shutdown requested');
  98  end;
  99
 100 {do not waste stack on statics}
 101  var EventsCount:integer;
 102  var Buffer:array [1..1024] of byte;
 103  var pkLen:LongWord;
 104  var From:tSockAddrL; {use larger struct so everything fits}
 105  var FromLen:LongWord;
 106  var FromG:tNetAddr;
 107  var curhnd:tMessageHandler;
 108  var Msg:tSMsg;
 109  var tp:tPollTop;
 110
 111 procedure PrepareHandler;
 112  begin
 113  FromG.FromSocket(from);
 114  if Buffer[1]>128 then curhnd:=HiHnd else curhnd:=hnd[Buffer[1]];
 115  if not assigned(curhnd) then raise eXception.Create('No handler for opcode '+IntToStr(Buffer[1]));
 116  Msg.Source:=@FromG; {!thread}
 117  Msg.Length:=pkLen;
 118  Msg.Data:=@Buffer; {!thread}
 119  Msg.stream.Init(@Buffer,pkLen,sizeof(Buffer));
 120  Msg.channel:=0; {!multisocket}
 121 end;
 122
 123 procedure ShedRun;
 124  var cur:^tSheduled;
 125  var pcur:^pointer;
 126  var now:UnixType.timeval;
 127  var delta:LongWord;
 128  var olTop:^tSheduled;
 129  begin
 130  {Sheduling}
 131  olTop:=ShedTop;
 132  pcur:=@olTop;
 133  cur:=pcur^;
 134  ShedTop:=nil; {unlink the current shed list}
 135  fpgettimeofday(@Now,nil);
 136  delta:=(Now.tv_sec-LastShed.tv_sec);
 137  if delta>6 then delta:=5000 else delta:=(delta*1000)+((Now.tv_usec-LastShed.tv_usec) div 1000);
 138  LastShed:=Now;
 139  //writeln('DeltaTime: ',delta);
 140  while assigned(cur) do begin
 141   if cur^.left<delta then begin
 142    cur^.cb;
 143    pcur^:=cur^.next;
 144    cur^.next:=ShedUU;
 145    ShedUU:=cur;
 146    cur:=pcur^;
 147   end else begin
 148    DEC(cur^.left,delta);
 149    if pollTimeOut>cur^.left then PollTimeOut:=cur^.left;
 150    //if pollTimeout>20 then pollTimeOut:=pollTimeOut div 2;
 151    if pollTimeout=0 then pollTimeOut:=1;
 152    pcur:=@cur^.next;
 153    cur:=cur^.next;
 154   end;
 155  end;
 156  pcur^:=ShedTop; {append newly added tasks to end of untriggererd list}
 157  ShedTop:=olTop; {link in the untriggered tasks}
 158 end;
 159
 160 procedure Main;
 161  begin
 162  s_setupInet;
 163  while not terminated  do begin
 164   PollTimeout:=5000;
 165   ShedRun;
 166   EventsCount:=fpPoll(@PollArr[0],PollTop,PollTimeout);
 167   if (eventscount=-1)and terminated then break;
 168   if eventscount=-1 then break;  {fixme: print error}
 169   if eventscount=0 then continue else begin
 170    {INET socket}
 171    with PollArr[0] do begin
 172     if (revents and pollIN)>0 then begin
 173      FromLen:=sizeof(From);
 174      pkLen:=fprecvfrom(s_inet,@Buffer,sizeof(Buffer),0,@from,@fromlen);
 175      SC(@fprecvfrom,pkLen);
 176      PrepareHandler;
 177      curhnd(Msg);
 178      revents:=0;
 179     end;
 180    end;
 181    {INET6...}
 182    {Generic}
 183    for tp:=1 to pollTop do if PollArr[tp].revents>0 then begin
 184     PollHnd[tp].CB(PollArr[tp].rEvents);
 185     PollArr[tp].revents:=0;
 186    end;
 187   end;
 188  end;
 189  write('Loop broken [');
 190  CloseSocket(s_inet);
 191  writeln(']');
 192 end;
 193
 194 procedure SetMsgHandler(OpCode:byte; handler:tMessageHandler);
 195 begin hnd[OpCode]:=handler; end;
 196 procedure SetHiMsgHandler(handler:tMessageHandler);
 197 begin Hihnd:=handler; end;
 198
 199 procedure WatchFD(fd:tHandle; h:tFDEventHandler);
 200  var opt: tPollTop;
 201 begin
 202  if assigned(h) then begin
 203   PollHnd[pollTop].CB:=h;
 204   PollArr[pollTop].fd:=fd;
 205   PollArr[pollTop].events:=POLLERR or POLLHUP or POLLIN or POLLPRI or
 206   POLLRDBAND or POLLRDNORM;
 207   PollArr[pollTop].revents:=0;
 208   //writeln('Add watch ',pollTop,' on ',fd,' to ',IntToHex(qword(@h),8));
 209   Inc(PollTop);
 210  end else for opt:=0 to high(opt) do if PollArr[opt].fd=fd then begin
 211   if (pollTop-1)>opt then begin
 212    PollArr[opt]:=PollArr[pollTop-1];
 213    PollHnd[opt]:=PollHnd[pollTop-1];
 214   end;
 215   dec(pollTop);
 216   PollArr[pollTop].fd:=-1;
 217   PollArr[pollTop].events:=0;
 218   PollArr[pollTop].revents:=0;
 219   break;
 220  end;
 221 end;
 222
 223 procedure Shedule(timeout{ms}: LongWord; h:tOnTimer);
 224  var old:^tSheduled;
 225  begin
 226  old:=ShedTop;
 227  if Assigned(ShedUU) then begin
 228   ShedTop:=ShedUU;
 229   ShedUU:=ShedUU^.next;
 230  end else New(ShedTop);
 231  ShedTop^.Left:=timeout;
 232  ShedTop^.CB:=h;
 233  ShedTop^.Next:=old;
 234 end;
 235
 236 procedure UnShedule(h:tOnTimer);
 237  var cur:^tSheduled;
 238  var pcur:^pointer;
 239  begin
 240  pcur:=@ShedTop;
 241  cur:=pcur^;
 242  while assigned(cur) do begin
 243   if cur^.cb=h then begin
 244    pcur^:=cur^.next; {unlink from main list}
 245    cur^.next:=ShedUU; ShedUU:=cur; {link to unused}
 246    break;
 247   end else begin
 248    pcur:=@cur^.next;
 249    cur:=pcur^;
 250   end;
 251  end;
 252 end;
 253
 254 var i:byte;
 255 BEGIN
 256  fpSignal(SigInt,@SignalHandler);
 257  fpSignal(SigTerm,@SignalHandler);
 258  for i:=1 to high(hnd) do hnd[i]:=nil;
 259  pollTop:=1; {1 for basic listen}
 260  ShedTop:=nil;
 261  ShedUU:=nil;
 262  fpgettimeofday(@LastShed,nil);
 263 END.