sakurasuite/IdSLPP20.pas

   1 {*******************************************************}
   2 {       IdSLPP20 - Indy Client for SLPP Connection      }
   3 {                                                       }
   4 {       Copyright (c) 2002-2003 naruto/CANO-Lab         }
   5 {*******************************************************}
   6
   7 unit IdSLPP20;
   8
   9 interface
  10
  11 uses
  12   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  13   IdTCPClient, IdCoderMIME, IdGlobal, IdException;
  14
  15 const
  16   SLPP_PORT = 9871;
  17   SLPP_HOST = 'bottle.mikage.to';
  18
  19 type
  20   TIdSLPPEventType = (etConnectOk, etScript, etMemberCount, etChannelCount,
  21                     etChannelList, etUnicast, etForceBroadcast, etCloseChannel,
  22                     etForceBroadcastInformation, etBroadcastInformation);
  23   TIdSLPPEvent = procedure (Sender: TObject;
  24     EventType: TIdSlppEventType; const Param: String) of Object;
  25
  26   TIdSLPP20 = class;
  27
  28   TIdSLPP20ReadThread = class(TThread)
  29   private
  30   protected
  31     FClient: TIdSLPP20;
  32     FRecvData: TStringList;
  33     FEvent: TIdSLPPEventType; // SLPP Command
  34     FParam: String;           // SLPP Command Parameter
  35     FReceivedLog: TStringList;
  36     function Parse: boolean;
  37     procedure Execute; override;
  38   public
  39     constructor Create(AClient: TIdSLPP20); reintroduce;
  40     property  Client: TIdSLPP20 read FClient;
  41   end;
  42
  43   TIdSLPP20 = class(TIdTCPClient)
  44   private
  45     FSLPPThread: TIdSLPP20ReadThread;
  46     FDebugMode: boolean;
  47     FProxyMode: boolean;
  48     FProxyUser: String;
  49     FProxyPass: String;
  50     FLUID: String;
  51     FOnSlppEvent: TIdSlppEvent;
  52     FOnConnect: TNotifyEvent;
  53     FOnDisconnect: TNotifyEvent;
  54     FLastReadTime: Int64;
  55     FTimeout: Integer;
  56     FOnConnectFailed: TNotifyEvent;
  57     procedure SetDebugMode(const Value: boolean);
  58     procedure SetLUID(const Value: String);
  59     procedure SetOnSlppEvent(const Value: TIdSlppEvent);
  60     procedure SetProxyMode(const Value: boolean);
  61     procedure SetProxyUser(const Value: String);
  62     procedure SetProxyPass(const Value: String);
  63     procedure SetOnConnect(const Value: TNotifyEvent);
  64     procedure SetOnDisconnect(const Value: TNotifyEvent);
  65     function GetLastReadTimeInterval: integer;
  66     procedure SetLastReadTime(const Value: Int64);
  67     procedure SetOnConnectFailed(const Value: TNotifyEvent);
  68   public
  69     constructor Create(AOwner: TComponent); override;
  70     destructor Destroy; override;
  71     procedure Connect(const ATimeout: Integer = IdTimeoutDefault); override;
  72     procedure ConnectServer(const ATimeout: Integer = IdTimeoutDefault);
  73     procedure Disconnect; override;
  74     procedure DoOnSlppEvent;
  75     procedure DoOnConnect;
  76     procedure DoOnConnectFailed;
  77     property SLPP20ReadThread: TIdSLPP20ReadThread read FSLPPThread;
  78     property LastReadTime: Int64 read FLastReadTime write SetLastReadTime;
  79     property LastReadTimeInterval: integer read GetLastReadTimeInterval;
  80   published
  81     property LUID: String read FLUID write SetLUID;
  82     property Port default SLPP_PORT;
  83     property DebugMode: boolean read FDebugMode write SetDebugMode;
  84     property ProxyMode: boolean read FProxyMode write SetProxyMode;
  85     property ProxyUser: String read FProxyUser write SetProxyUser;
  86     property ProxyPass: String read FProxyPass write SetProxyPass;
  87     property OnConnect: TNotifyEvent read FOnConnect write SetOnConnect;
  88     property OnConnectFailed: TNotifyEvent read FOnConnectFailed write SetOnConnectFailed;
  89     property OnDisconnect: TNotifyEvent read FOnDisconnect write SetOnDisconnect;
  90     property OnSLPPEvent: TIdSlppEvent read FOnSlppEvent write SetOnSlppEvent;
  91     {ProxyMode = true\82Ì\82Æ\82«\82Í\81AHost, Port\82É\83v\83\8d\83L\83V\96¼\82ð}
  92   end;
  93
  94   EIdSlppError = class(EIdException);
  95   EIdSlppClientConnectError = class(EIdSlppError);
  96
  97 procedure Register;
  98
  99 implementation
 100
 101 procedure Register;
 102 begin
 103   RegisterComponents('Indy Clients', [TIdSLPP20]);
 104 end;
 105
 106 { TIdSLPP20 }
 107
 108 procedure TIdSLPP20.Connect(const ATimeout: Integer);
 109 begin
 110   inherited Connect(ATimeout);
 111 end;
 112
 113 procedure TIdSLPP20.ConnectServer;
 114 begin
 115   try
 116     FTimeout := ATimeout;
 117     FSLPPThread := TIdSLPP20ReadThread.Create(self);
 118   except on E: EIdSocketError do
 119     raise EIdSlppClientConnectError.Create('Connection Failed');
 120   end;
 121 end;
 122
 123 constructor TIdSLPP20.Create(AOwner: TComponent);
 124 begin
 125   inherited Create(AOwner);
 126   Port := SLPP_PORT;
 127   Host := SLPP_HOST;
 128   ProxyUser := '';
 129   ProxyPass := '';
 130 end;
 131
 132 destructor TIdSLPP20.Destroy;
 133 begin
 134   inherited;
 135 end;
 136
 137 procedure TIdSLPP20.Disconnect;
 138 begin
 139   inherited Disconnect;
 140   if Assigned(FSLPPThread) then begin
 141     FSLPPThread.Terminate;
 142     // FSLPPThread.WaitFor;
 143     FSLPPThread := nil;
 144   end;
 145   if Assigned(FOnDisconnect) then begin
 146     OnDisconnect(self);
 147   end;
 148 end;
 149
 150 procedure TIdSLPP20.DoOnConnect;
 151 begin
 152   if Assigned(FOnConnect) then
 153     FOnConnect(self);
 154 end;
 155
 156 procedure TIdSLPP20.DoOnConnectFailed;
 157 begin
 158   if Assigned(FOnConnectFailed) then
 159     FOnConnectFailed(self);
 160 end;
 161
 162 procedure TIdSLPP20.DoOnSlppEvent;
 163 begin
 164   try
 165     FOnSlppEvent(self, FSLPPThread.FEvent, FSLPPThread.FParam);
 166   except
 167     on E: Exception do
 168       ShowMessage('Exception occured in OnSlppEvent: '#13#10 + E.Message);
 169   end;
 170 end;
 171
 172 function TIdSLPP20.GetLastReadTimeInterval: integer;
 173 begin
 174   Result := 0;
 175   if Connected then Result := GetTickCount - FLastReadTime;
 176 end;
 177
 178 procedure TIdSLPP20.SetDebugMode(const Value: boolean);
 179 begin
 180   FDebugMode := Value;
 181 end;
 182
 183 procedure TIdSLPP20.SetLastReadTime(const Value: Int64);
 184 begin
 185   FLastReadTime := Value;
 186 end;
 187
 188 procedure TIdSLPP20.SetLUID(const Value: String);
 189 begin
 190   FLUID := Value;
 191 end;
 192
 193 procedure TIdSLPP20.SetOnConnect(const Value: TNotifyEvent);
 194 begin
 195   FOnConnect := Value;
 196 end;
 197
 198 procedure TIdSLPP20.SetOnConnectFailed(const Value: TNotifyEvent);
 199 begin
 200   FOnConnectFailed := Value;
 201 end;
 202
 203 procedure TIdSLPP20.SetOnDisconnect(const Value: TNotifyEvent);
 204 begin
 205   FOnDisconnect := Value;
 206 end;
 207
 208 procedure TIdSLPP20.SetOnSlppEvent(const Value: TIdSlppEvent);
 209 begin
 210   FOnSlppEvent := Value;
 211 end;
 212
 213 procedure TIdSLPP20.SetProxyMode(const Value: boolean);
 214 begin
 215   FProxyMode := Value;
 216 end;
 217
 218 procedure TIdSLPP20.SetProxyUser(const Value: String);
 219 begin
 220   FProxyUser := Value;
 221 end;
 222
 223 procedure TIdSLPP20.SetProxyPass(const Value: String);
 224 begin
 225   FProxyPass := Value;
 226 end;
 227
 228 { TIdSLPP20ReadThread }
 229
 230 constructor TIdSLPP20ReadThread.Create(AClient: TIdSLPP20);
 231 begin
 232   inherited Create(true);
 233   FClient := AClient;
 234   FreeOnTerminate := true;
 235   Resume;
 236 end;
 237
 238 procedure TIdSLPP20ReadThread.Execute;
 239 var Line: String;
 240     EncodedPassword,PlainPassword: String;
 241     Base64Encoder: TIdEncoderMIME;
 242 begin
 243   try
 244     FClient.Connect(FClient.FTimeout);
 245     if Assigned(FClient.OnConnect) then begin
 246       Synchronize(FClient.DoOnConnect);
 247     end;
 248   except
 249     Synchronize(FClient.DoOnConnectFailed);
 250     Exit;
 251   end;
 252
 253   EncodedPassword := '';
 254   if FClient.ProxyUser <> '' then begin
 255     if FClient.ProxyPass <> '' then begin
 256       PlainPassword := FClient.ProxyUser + ':' + FClient.ProxyPass;
 257       Base64Encoder.Create(nil);
 258       EncodedPassword := Base64Encoder.Encode(PlainPassword);
 259       FreeAndNil(Base64Encoder);
 260     end;
 261   end;
 262
 263   FRecvData := TStringList.Create;
 264   FReceivedLog := TStringList.Create;
 265   if FClient.ProxyMode then begin
 266     FClient.Writeln('POST http://bottle.mikage.to:9871/ HTTP/1.0');
 267     FClient.Writeln('Content-Length: ' + IntToStr(Length(FClient.LUID)));
 268     FClient.Writeln('Connection: close');
 269
 270     if EncodedPassword <> '' then begin
 271       FClient.Writeln('Proxy-Authorization: Basic ' + EncodedPassword);
 272     end;
 273
 274     FClient.Writeln;
 275     FClient.Writeln(FClient.LUID);
 276   end else begin
 277     FClient.WriteLn('POST / HTTP/1.0');
 278     FClient.WriteLn;
 279     FClient.WriteLn(FClient.LUID);
 280   end;
 281   while not Terminated do begin
 282     try
 283       FClient.CheckForDisconnect;
 284       Line := FClient.ReadLn(EOL);
 285       if FClient.DebugMode then begin
 286         FReceivedLog.Add(Line);
 287         FReceivedLog.SaveToFile(ExtractFilePath(Application.ExeName)+'slpp20_debug.log');
 288       end;
 289       if not FClient.ReadLnTimedOut then FClient.LastReadTime := getTickCount;
 290       if Length(Line) = 0 then begin
 291         if FRecvData.Count > 0 then begin
 292           FClient.CheckForDisconnect; //\90Ø\92f\8cã\82Ì\92\86\93r\94¼\92[\82È\83f\81[\83^\91\97\90M\82ð\96h\82®
 293           while Parse do begin
 294             Synchronize(FClient.DoOnSlppEvent);
 295           end;
 296           FRecvData.Clear;
 297         end;
 298       end else begin
 299         FRecvData.Add(Line);
 300       end;
 301     except
 302       on EIdException do begin
 303         Synchronize(self.Terminate);
 304       end;
 305     end;
 306   end;
 307
 308   if ( FClient.Connected ) then FClient.Disconnect;
 309   FreeAndNil(FReceivedLog);
 310   FreeAndNil(FRecvData);
 311 end;
 312
 313 function TIdSLPP20ReadThread.Parse: boolean;
 314 var
 315   command: String;
 316 begin
 317   //\8dÅ\92á\8cÀ\83R\83}\83\93\83h\8ds+1\82Í\82È\82¢\82Æ\83_\83\81 - 2\88È\8fã
 318   if FRecvData.Count <= 1 then begin
 319     Result := false;
 320     Exit;
 321   end;
 322
 323   command := FRecvData[0];
 324   FRecvData.Delete(0);
 325   FParam := FRecvData.Text;
 326
 327   Result := true;
 328   if command = 'broadcastMessage' then begin
 329     FEvent := etScript;
 330   end else if command = 'allUsers' then begin
 331     FEvent := etMemberCount;
 332   end else if command = 'channelUsers' then begin
 333     FEvent := etChannelCount;
 334   end else if command = 'channelList' then begin
 335     FEvent := etChannelList;
 336   end else if (command = 'HTTP/1.0 200 OK') or (command = 'HTTP/1.1 200 OK') then begin
 337     FEvent := etConnectOk;
 338   end else if command = 'forceBroadcastMessage' then begin
 339     FEvent := etForceBroadcast;
 340   end else if command = 'forceBroadcastInformation' then begin
 341     FEvent := etForceBroadcastInformation;
 342   end else if command = 'BroadcastInformation' then begin
 343     FEvent := etBroadcastInformation;
 344   end else if command = 'closeChannel' then begin
 345     FEvent := etCloseChannel;
 346   end else if command = 'unicastMessage' then begin
 347     FEvent := etUnicast;
 348   end else Result := false;
 349 end;
 350
 351 end.