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