bottleclient/BottleSstp.pas

   1 unit BottleSstp;
   2
   3 (* \95Ê\83X\83\8c\83b\83h\82ÅSSTP\83T\81[\83o\82ÆDirectSSTP\82ð\92Ê\82¶\82Ä\92Ê\90M\82·\82é *)
   4
   5 interface
   6
   7 uses Classes, Contnrs, SyncObjs, Windows, Logs, SysUtils, Controls, Forms,
   8   Messages, BottleDef, SakuraSeekerInstance, Dialogs;
   9
  10 type
  11   TBottleSstpResult = (
  12     srOk,
  13     srNoContent,
  14     srBreak,
  15     srBadRequest,
  16     srRequestTimeout,
  17     srConflict,
  18     srRefuse,
  19     srNotImplemented,
  20     srServiceUnavailable,
  21     srNotLocalIP,
  22     srInBlackList,
  23     srInvisible,
  24     srUnknownError
  25   );
  26
  27   TBottleSstpResendEvent = procedure(Sender: TObject; MID: String) of object;
  28
  29   TBottleSstp = class(TThread)
  30   private
  31     FTargetHwnd: HWND;
  32     FTargetSetName: String;
  33     FProcessBottle: TLogItem;
  34     FDirectSstpResult: String;
  35     FSentLog: TStringList;
  36     FRecvLog: TStringList;
  37     FCueLock: TCriticalSection;
  38     FCue: TObjectList; // \83X\83\8c\83b\83h\83Z\81[\83t\82É\82È\82é\82æ\82¤\82É\92\8d\88Ó
  39     FWindowHandle: HWND;
  40     FOnResendCountChange: TNotifyEvent;
  41     FOnResendTrying: TBottleSstpResendEvent;
  42     FOnResendEnd: TBottleSstpResendEvent;
  43     FLastTickCount: Int64;
  44     FResendSleep: boolean;
  45     function GetCueCount: integer;
  46     procedure SetOnResendCountChange(const Value: TNotifyEvent);
  47     procedure SetOnResendEnd(const Value: TBottleSstpResendEvent);
  48     procedure SetOnResendTrying(const Value: TBottleSstpResendEvent);
  49     procedure SetResendSleep(const Value: boolean);
  50   protected
  51     function ConnectSstp(Source: TStrings): TBottleSstpResult;
  52     procedure WndProc(var Msg: TMessage);
  53     function ExtractCode(const CodeStr: String): integer;
  54     function CodeToStatus(const Code: integer): TBottleSstpResult;
  55     procedure DetectTargetHWND;
  56     procedure DoOnResendCountChange;
  57     procedure DoOnResendTrying;
  58     procedure DoOnResendEnd;
  59   public
  60     constructor Create(CreateSuspended: boolean);
  61     destructor Destroy; override;
  62     procedure Execute; override;
  63     procedure Push(Bottle: TLogItem); //\8dÄ\91\97\83o\83b\83t\83@\82Ì\8dÅ\8cã\82É\92Ç\89Á(\95\81\92Ê)
  64     procedure Unshift(Bottle: TLogItem); //\8dÄ\91\97\83o\83b\83t\83@\82Ì\90æ\93ª\82É\92Ç\89Á
  65     procedure Clear; //\8dÄ\91\97\83o\83b\83t\83@\82ð\83N\83\8a\83A
  66     property ResendSleep: boolean read FResendSleep write SetResendSleep;
  67     property CueCount: integer read GetCueCount;
  68     property OnResendCountChange: TNotifyEvent read FOnResendCountChange write SetOnResendCountChange;
  69     property OnResendEnd: TBottleSstpResendEvent read FOnResendEnd write SetOnResendEnd;
  70     property OnResendTrying: TBottleSstpResendEvent read FOnResendTrying write SetOnResendTrying;
  71   end;
  72
  73 implementation
  74
  75 const
  76   //\82±\82Ì\83G\83\89\81[\82Í\81ASSTP\83T\81[\83o\82ª\83X\83e\81[\83^\83X\82ð\95Ô\82³\82¸\82É\90Ø\92f\82µ\82½\82Æ\82«\82È\82Ç\82É\95Ô\82é
  77   UnknownError = -1000;
  78
  79 { TBottleSstp }
  80
  81 procedure TBottleSstp.Clear;
  82 begin
  83   FCueLock.Enter;
  84   try
  85     FCue.Clear;
  86   finally
  87     FCueLock.Leave;
  88   end;
  89   Synchronize(DoOnResendCountChange);
  90 end;
  91
  92 function TBottleSstp.CodeToStatus(const Code: integer): TBottleSstpResult;
  93 begin
  94   case Code of
  95     200: Result := srOk;
  96     204: Result := srNoContent;
  97     210: Result := srBreak;
  98     400: Result := srBadRequest;
  99     408: Result := srRequestTimeout;
 100     409: Result := srConflict;
 101     420: Result := srRefuse;
 102     501: Result := srNotImplemented;
 103     503: Result := srServiceUnavailable;
 104     504: Result := srNotLocalIP;
 105     541: Result := srInBlackList;
 106     512: Result := srInvisible;
 107   else
 108     Result := srUnknownError;
 109   end;
 110 end;
 111
 112 function TBottleSstp.ConnectSstp(Source: TStrings): TBottleSstpResult;
 113 var Mes: TCopyDataStruct;
 114     MesStr: String;
 115     Dummy: DWORD; //SendMessageTimeout\97p
 116     StatusCode: integer;
 117 begin
 118   Result := srUnknownError;
 119
 120   if FTargetHWnd <> 0 then begin
 121     MesStr := Source.Text;
 122     Mes.dwData := 9801;
 123     Mes.cbData := Length(MesStr);
 124     Mes.lpData := PChar(MesStr);
 125     FDirectSstpResult := '';
 126     //FSentLog.Text := MesStr;
 127     SendMessageTimeout(FTargetHWnd, WM_COPYDATA, FWindowHandle, LPARAM(@Mes),
 128                        SMTO_ABORTIFHUNG or SMTO_NORMAL, 50000, Dummy);
 129     FRecvLog.Text := FDirectSstpResult;
 130     if FRecvLog.Count > 0 then
 131       StatusCode := ExtractCode(FRecvLog[0])
 132     else
 133       StatusCode := UnknownError;
 134     Result := CodeToStatus(StatusCode);
 135   end;
 136 end;
 137
 138 constructor TBottleSstp.Create(CreateSuspended: boolean);
 139 begin
 140   inherited;
 141   FCueLock := TCriticalSection.Create;
 142   FCue := TObjectList.Create(true);
 143   FWindowHandle := AllocateHWnd(WndProc);
 144   FSentLog := TStringList.Create;
 145   FRecvLog := TStringList.Create;
 146 end;
 147
 148 destructor TBottleSstp.Destroy;
 149 begin
 150   FRecvLog.Free;
 151   FSentLog.Free;
 152   FCue.Free;
 153   FCueLock.Free;
 154   DeallocateHWnd(FWindowHandle);
 155   inherited;
 156 end;
 157
 158 procedure TBottleSstp.DetectTargetHWND;
 159 var Ghost: String;
 160 begin
 161   // \96Ú\95W\83S\81[\83X\83g\8ew\92è
 162   if ChannelList.Channel[FProcessBottle.Channel] <> nil then
 163     Ghost := ChannelList.Channel[FProcessBottle.Channel].Ghost;
 164   if FProcessBottle.Ghost <> '' then Ghost := FProcessBottle.Ghost;
 165
 166   SakuraSeeker.BeginDetect; //\8dÅ\90V\82ÌFMO\8eæ\93¾
 167   if SakuraSeeker.ProcessByName[Ghost] <> nil then begin
 168     FTargetHWnd := SakuraSeeker.ProcessByName[Ghost].HWnd;
 169     FTargetSetName := SakuraSeeker.ProcessByName[Ghost].SetName;
 170   end else if SakuraSeeker.Count > 0 then begin
 171     FTargetHWnd := SakuraSeeker[0].HWnd;
 172     FTargetSetName := SakuraSeeker[0].SetName;
 173   end else begin
 174     FTargetHwnd := 0;
 175     FTargetSetName := '';
 176   end;
 177 end;
 178
 179 procedure TBottleSstp.DoOnResendCountChange;
 180 begin
 181   if Assigned(FOnResendCountChange) then
 182     FOnResendCountChange(self);
 183 end;
 184
 185 procedure TBottleSstp.DoOnResendEnd;
 186 begin
 187   if Assigned(FOnResendEnd) then
 188     FOnResendEnd(self, FProcessBottle.MID);
 189 end;
 190
 191 procedure TBottleSstp.DoOnResendTrying;
 192 begin
 193   if Assigned(FOnResendTrying) then
 194     FOnResendTrying(self, FProcessBottle.MID);
 195 end;
 196
 197 procedure TBottleSstp.Execute;
 198 var Source: TStringList;
 199     Opt: String;
 200     Res: TBottleSstpResult;
 201 begin
 202   inherited;
 203   while not Terminated do begin
 204     sleep(100);
 205     if ResendSleep then Continue;
 206     if (GetTickCount - FLastTickCount < 2000) and (GetTickCount > FLastTickCount) then
 207       Continue;
 208     FLastTickCount := GetTickCount;
 209
 210     try
 211       FCueLock.Enter;
 212       try
 213         if FCue.Count = 0 then Continue;
 214         FProcessBottle := FCue.Items[0] as TLogItem;
 215         if FProcessBottle.LogType <> ltBottle then
 216         begin
 217           FCue.Delete(0);
 218           Continue;
 219         end;
 220       finally
 221         FCueLock.Leave;
 222       end;
 223       // SakuraSeeker\82Í\83X\83\8c\83b\83h\83A\83\93\83Z\81[\83t\82È\82Ì\82Å
 224       // Synchronize\82Å\8cÄ\82Ñ\8fo\82·
 225       Synchronize(DetectTargetHWND);
 226       if FTargetHWnd = 0 then
 227         Continue; // \89½\82Å\82à\82¢\82¢\82©\82ç\83v\83\8d\83Z\83X\8c©\82Â\82©\82é\82Ü\82Å\82Í\91Ò\82Â
 228
 229       Synchronize(DoOnResendTrying);
 230
 231       // \82Å\82Í\91\97\90M\92v\82µ\82Ü\82µ\82å\82¤
 232       Source := TStringList.Create;
 233       try
 234         if Pref.NoTranslate then begin
 235          Opt := 'notranslate';
 236         end;
 237         if Pref.NoDescript then begin
 238           if Opt <> '' then Opt := Opt + ',';
 239           Opt := Opt + 'nodescript';
 240         end;
 241         Source.Add('SEND SSTP/1.4');
 242         if FProcessBottle.Ghost <> '' then
 243           Source.Add('Sender: SSTP Bottle / ' + FProcessBottle.Channel + '/' + FProcessBottle.Ghost)
 244         else
 245           Source.Add('Sender: SSTP Bottle / ' + FProcessBottle.Channel);
 246         Source.Add('Charset: Shift_JIS');
 247         if FProcessBottle.Ghost <> '' then begin
 248           Source.Add('IfGhost: ' + FTargetSetName);
 249         end;
 250         Source.Add('Script: ' + FProcessBottle.Script);
 251         Source.Add('Option: ' + Opt);
 252         Source.Add('HWnd: ' + IntToStr(FWindowHandle));
 253         Source.Add(''); //\8bó\8ds\82ª\8fI\97¹\82ð\8e¦\82·
 254         // \8eÀ\8dÛ\82Ì\91\97\90M\81B\95Ê\82É\82±\82Ì\95\94\95ª\82³\82¦\95Ê\83X\83\8c\83b\83h\82È\82ç\82¢\82¢\82ñ\82Å\82·\82¯\82Ç\81B
 255         // Source.SaveToFile(ChangeFileExt(Application.ExeName, '.debug'));
 256         Res := ConnectSstp(Source);
 257       finally
 258         Source.Free;
 259       end;
 260
 261       // \91\97\90M\8cã\82Ì\8f\88\97\9d\81B\91\97\90M\90¬\8c÷\82È\82ç\8fÁ\82¦\82Ä\82à\82ç\82¢\82Ü\82µ\82å\82¤
 262       if Res in [srOk] then begin
 263         Synchronize(DoOnResendEnd);
 264         FCueLock.Enter;
 265         try
 266           // Delete(0)\82¾\82ÆSSTP\90Ú\91±\92\86\82É\89½\82©\91\9d\82¦\82Ä\82é\89Â\94\\90«\82ª\82 \82é
 267           FCue.Extract(FProcessBottle);
 268           FProcessBottle.Free;
 269         finally
 270           FCueLock.Leave;
 271         end;
 272         Synchronize(DoOnResendCountChange);
 273       end;
 274     except
 275       on E: Exception do begin
 276         ShowMessage('Exception occured in SSTP dispatcher class:'#13#10#13#10 + E.Message);
 277       end;
 278     end;
 279   //\81«\83\8b\81[\83v\8fI\97¹
 280   end;
 281 end;
 282
 283 function TBottleSstp.ExtractCode(const CodeStr: String): integer;
 284 var i, l: integer;
 285     s, p: String;
 286 begin
 287   if CodeStr = '' then begin
 288     Result := UnknownError;
 289     Exit;
 290   end;
 291   i := 1;
 292   l := length(CodeStr);
 293   while (CodeStr[i] <> ' ') and (i<=l) do begin
 294     p := p + CodeStr[i];
 295     Inc(i);
 296   end;
 297   Inc(i);
 298   while (CodeStr[i] in ['0'..'9']) and (i<=l) do begin
 299     s := s + CodeStr[i];
 300     Inc(i);
 301   end;
 302   try
 303     Result := StrToInt(s);
 304   except
 305     on EConvertError do Result := UnknownError;
 306   end;
 307 end;
 308
 309
 310 function TBottleSstp.GetCueCount: integer;
 311 begin
 312   Result := FCue.Count;
 313 end;
 314
 315 procedure TBottleSstp.Push(Bottle: TLogItem);
 316 begin
 317   FCueLock.Enter;
 318   try
 319     FCue.Add(Bottle);
 320   finally
 321     FCueLock.Leave;
 322   end;
 323   Synchronize(DoOnResendCountChange);
 324 end;
 325
 326 procedure TBottleSstp.SetOnResendCountChange(const Value: TNotifyEvent);
 327 begin
 328   FOnResendCountChange := Value;
 329 end;
 330
 331 procedure TBottleSstp.SetOnResendEnd(const Value: TBottleSstpResendEvent);
 332 begin
 333   FOnResendEnd := Value;
 334 end;
 335
 336 procedure TBottleSstp.SetOnResendTrying(
 337   const Value: TBottleSstpResendEvent);
 338 begin
 339   FOnResendTrying := Value;
 340 end;
 341
 342 procedure TBottleSstp.SetResendSleep(const Value: boolean);
 343 begin
 344   FResendSleep := Value;
 345 end;
 346
 347 procedure TBottleSstp.Unshift(Bottle: TLogItem);
 348 var Item: TLogItem;
 349 begin
 350   Item := TLogItem.Create(Bottle);
 351   FCueLock.Enter;
 352   try
 353     FCue.Insert(0, Item);
 354   finally
 355     FCueLock.Leave;
 356   end;
 357   Synchronize(DoOnResendCountChange);
 358 end;
 359
 360 procedure TBottleSstp.WndProc(var Msg: TMessage);
 361 var Dat: TWMCopyData;
 362 begin
 363   //\83X\83\8c\83b\83h\93à\8aÖ\90\94
 364   if Msg.Msg = WM_COPYDATA then begin
 365     Dat := TWMCopyData(Msg);
 366     FDirectSstpResult := PChar(Dat.CopyDataStruct^.lpData);
 367   end else begin
 368     Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.wParam, Msg.lParam);
 369   end;
 370 end;
 371
 372 end.