WebModuleUnit1.pas

   1 unit WebModuleUnit1;
   2
   3 interface
   4
   5 uses System.SysUtils, System.Classes, Web.HTTPApp, FireDAC.Stan.Intf,
   6   FireDAC.Stan.Option, FireDAC.Stan.Param, FireDAC.Stan.Error, FireDAC.DatS,
   7   FireDAC.Phys.Intf, FireDAC.DApt.Intf, FireDAC.Stan.Async, FireDAC.DApt,
   8   FireDAC.UI.Intf, FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Phys,
   9   FireDAC.Phys.SQLite, FireDAC.Phys.SQLiteDef, FireDAC.Stan.ExprFuncs, Data.DB,
  10   FireDAC.Comp.Client, FireDAC.Comp.DataSet, Web.HTTPProd, Web.DSProd,
  11   AnsiStrings, System.DateUtils;
  12
  13 type
  14   TWebModule1 = class(TWebModule)
  15     FDTable1: TFDTable;
  16     FDConnection1: TFDConnection;
  17     FDTable2: TFDTable;
  18     FDTable2home: TWideMemoField;
  19     FDTable2title: TWideMemoField;
  20     FDTable2title2: TWideMemoField;
  21     FDTable2pass: TWideMemoField;
  22     PageProducer1: TPageProducer;
  23     DataSetPageProducer2: TDataSetPageProducer;
  24     FDTable1name: TWideMemoField;
  25     FDTable1no: TIntegerField;
  26     FDTable1date: TWideMemoField;
  27     FDTable1sub: TWideMemoField;
  28     FDTable1com: TWideMemoField;
  29     FDTable1pass: TWideMemoField;
  30     adminDS: TDataSetPageProducer;
  31     FDTable2ngwords: TWideMemoField;
  32     FDTable3: TFDTable;
  33     FDTable3link: TIntegerField;
  34     FDTable3count: TIntegerField;
  35     procedure WebModule1DefaultHandlerAction(Sender: TObject;
  36       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  37     procedure PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  38       const TagString: string; TagParams: TStrings; var ReplaceText: string);
  39     procedure WebModule1registAction(Sender: TObject; Request: TWebRequest;
  40       Response: TWebResponse; var Handled: Boolean);
  41     procedure DataSetPageProducer2HTMLTag(Sender: TObject; Tag: TTag;
  42       const TagString: string; TagParams: TStrings; var ReplaceText: string);
  43     procedure WebModule1userdelAction(Sender: TObject; Request: TWebRequest;
  44       Response: TWebResponse; var Handled: Boolean);
  45     procedure WebModule1adminAction(Sender: TObject; Request: TWebRequest;
  46       Response: TWebResponse; var Handled: Boolean);
  47     procedure WebModule1admindelAction(Sender: TObject; Request: TWebRequest;
  48       Response: TWebResponse; var Handled: Boolean);
  49     procedure WebModule1loginAction(Sender: TObject; Request: TWebRequest;
  50       Response: TWebResponse; var Handled: Boolean);
  51     procedure WebModuleBeforeDispatch(Sender: TObject; Request: TWebRequest;
  52       Response: TWebResponse; var Handled: Boolean);
  53     procedure WebModule1setupAction(Sender: TObject; Request: TWebRequest;
  54       Response: TWebResponse; var Handled: Boolean);
  55     procedure WebModule1searchAction(Sender: TObject; Request: TWebRequest;
  56       Response: TWebResponse; var Handled: Boolean);
  57     procedure WebModuleCreate(Sender: TObject);
  58     procedure WebModuleDestroy(Sender: TObject);
  59   private
  60     { private \90é\8c¾ }
  61   public
  62     { public \90é\8c¾ }
  63     user: string;
  64     time: Int64;
  65     words: TStringList;
  66     pos: integer;
  67     foo: string;
  68     function footer(const path: string): string;
  69   end;
  70
  71 var
  72   WebModuleClass: TComponentClass = TWebModule1;
  73
  74 implementation
  75
  76 { %CLASSGROUP 'Vcl.Controls.TControl' }
  77
  78 {$R *.dfm}
  79
  80 const
  81   path = '';// 'C:\Users\fuke masasi\Documents\Embarcadero\Studio\Projects\pbbs\';
  82
  83 procedure TWebModule1.DataSetPageProducer2HTMLTag(Sender: TObject; Tag: TTag;
  84   const TagString: string; TagParams: TStrings; var ReplaceText: string);
  85 begin
  86   if TagString = 'home' then
  87   begin
  88     ReplaceText := FDTable2.FieldByName('home').AsString;
  89   end
  90   else
  91   begin
  92     ReplaceText := FDTable1.FieldByName(TagString).AsString;
  93   end;
  94 end;
  95
  96 function TWebModule1.footer(const path: string): string;
  97 var
  98   s1, s2, t1, t2: string;
  99   i, k, count: integer;
 100   function linkcontent: string;
 101   var
 102     j, link: integer;
 103   begin
 104     result := '';
 105     link := FDTable3.FieldByName('link').AsInteger;
 106     if pos > link div 2 then
 107     begin
 108       if (FDTable1.RecordCount - 1) div count < pos + link div 2 then
 109       begin
 110         i := FDTable1.RecordCount div count - link - pos;
 111       end
 112       else
 113       begin
 114         i := -(link div 2);
 115       end;
 116     end
 117     else if pos = -1 then
 118     begin
 119       i := -pos + FDTable1.RecordCount div count - link;
 120     end
 121     else
 122     begin
 123       i := -pos;
 124     end;
 125     for j := 0 to link do
 126     begin
 127       if FDTable1.RecordCount <= (pos + i + j) * count then
 128         break;
 129       if pos + i + j < 0 then
 130         continue;
 131       if i + j = 0 then
 132       begin
 133         result := result + '  ' + IntToStr(pos + 1) + '  ';
 134       end
 135       else
 136       begin
 137         result := result + Format('  <a href="' + FDTable2.FieldByName('home')
 138           .AsString + path + '?pos=%d">%d</a>  ',
 139           [pos + i + j, pos + 1 + i + j]);
 140       end;
 141     end;
 142   end;
 143
 144 begin
 145   count := FDTable3.FieldByName('count').AsInteger;
 146   if pos <= -1 then
 147   begin
 148     s1 := '\8dÅ\90V%d\8c\8f\82Ì\8bL\8e\96\82ð\95\\8e¦<br><center>Pages : [<b>';
 149     s2 := '<<' + linkcontent + '>>]  \8dÅ\90V</b><br></center>';
 150     result := Format(s1, [count]) + s2;
 151   end
 152   else
 153   begin
 154     if pos = 0 then
 155     begin
 156       t1 := '?pos=0';
 157     end
 158     else
 159     begin
 160       t1 := '?pos=' + IntToStr(pos - 1);
 161     end;
 162     i := (FDTable1.RecordCount - 1) div count;
 163     if pos > i then
 164       pos := i;
 165     if pos = i then
 166     begin
 167       t2 := '?pos=' + IntToStr(pos);
 168       k := FDTable1.RecordCount;
 169     end
 170     else
 171     begin
 172       t2 := '?pos=' + IntToStr(pos + 1);
 173       k := (pos + 1) * count;
 174     end;
 175     s1 := '%d \8c\8f\92\86 %d \8c\8f\82©\82ç %d \8c\8f\82Ü\82Å\95\\8e¦<br><center>Page : [<b>';
 176     s2 := '<a href="' + FDTable2.FieldByName('home').AsString + path + t1 +
 177       '"><<</a>' + linkcontent + '<a href="' + FDTable2.FieldByName('home')
 178       .AsString + path + t2 + '">>></a>]  <a href="' +
 179       FDTable2.FieldByName('home').AsString + path + '">\8dÅ\90V</a></b></center>';
 180     result := Format(s1, [FDTable1.RecordCount, pos * count + 1, k]) + s2;
 181   end;
 182 end;
 183
 184 procedure TWebModule1.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
 185   const TagString: string; TagParams: TStrings; var ReplaceText: string);
 186 var
 187   i, j, count: integer;
 188   s: TDataSetPageProducer;
 189   t: string;
 190 begin
 191   if (TagString = 'home') or (TagString = 'title') or (TagString = 'title2')
 192   then
 193     ReplaceText := FDTable2.FieldByName(TagString).AsString;
 194   if TagString = 'username' then
 195     ReplaceText := user;
 196   if TagString = 'main' then
 197   begin
 198     t := ExtractFileName(PageProducer1.HTMLFile);
 199     if FDTable1.RecordCount = 0 then
 200     begin
 201       if t = 'index.htm' then
 202         ReplaceText := '\82Ü\82¾\93\8a\8de\82ª\82 \82è\82Ü\82¹\82ñ.';
 203     end
 204     else
 205     begin
 206       count := FDTable3.FieldByName('count').AsInteger;
 207       if t = 'admin.htm' then
 208       begin
 209         s := adminDS;
 210       end
 211       else
 212       begin
 213         s := DataSetPageProducer2;
 214       end;
 215       if pos < -1 then
 216         pos := -1;
 217       if (pos + 1) * count > FDTable1.RecordCount then
 218         pos := (FDTable1.RecordCount - 1) div count;
 219       if pos = -1 then
 220       begin
 221         if FDTable1.RecordCount < count then
 222         begin
 223           j := FDTable1.RecordCount mod count;
 224         end
 225         else
 226         begin
 227           j := count;
 228         end;
 229       end
 230       else if FDTable1.RecordCount < (pos + 1) * count then
 231       begin
 232         j := FDTable1.RecordCount - pos * count;
 233       end
 234       else
 235       begin
 236         j := count;
 237       end;
 238       if pos = -1 then
 239       begin
 240         FDTable1.Last;
 241       end
 242       else
 243       begin
 244         FDTable1.RecNo := (pos + 1) * count;
 245       end;
 246       for i := 1 to j do
 247       begin
 248         ReplaceText := ReplaceText + s.Content;
 249         FDTable1.Prior;
 250       end;
 251     end;
 252   end;
 253   if TagString = 'footer' then
 254     if TagParams.Values['refer'] = 'true' then
 255     begin
 256       ReplaceText := foo;
 257     end
 258     else
 259     begin
 260       t := ExtractFileName(PageProducer1.HTMLFile);
 261       foo := footer(ChangeFileExt(t, ''));
 262       ReplaceText := foo;
 263     end;
 264   if TagString = 'text' then
 265     if FDTable1.Filter = '' then
 266     begin
 267       ReplaceText := '\8c\9f\8dõ\82µ\82Ü\82·';
 268     end
 269     else
 270     begin
 271       ReplaceText := '\8aY\93\96\8c\8b\89Ê ' + IntToStr(FDTable1.RecordCount) + ' \8c\8f' +
 272         '<br><#main>';
 273     end;
 274 end;
 275
 276 procedure TWebModule1.WebModule1adminAction(Sender: TObject;
 277   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 278 var
 279   s: string;
 280   x: Boolean;
 281   procedure something;
 282   begin
 283     x := false;
 284     FDTable1.Filtered := false;
 285     PageProducer1.HTMLFile := path + 'admin.htm';
 286     Response.ContentType := 'text/html; charset=utf-8;';
 287     Response.Content := PageProducer1.Content;
 288   end;
 289
 290 begin
 291   x := true;
 292   s := Request.ContentFields.Values['password'];
 293   pos := StrToIntDef(Request.QueryFields.Values['pos'], -1);
 294   if s <> '' then
 295   begin
 296     with Response.Cookies.Add do
 297     begin
 298       path := FDTable2.FieldByName('home').AsAnsiString + 'admin';
 299       Expires := Now + 1;
 300       Name := 'psw';
 301       Value := AnsiString(s);
 302       // Secure := true;
 303     end;
 304     if s = FDTable2.FieldByName('pass').AsString then
 305       something;
 306   end
 307   else if Request.CookieFields.Values['psw'] = FDTable2.FieldByName('pass').AsString
 308   then
 309     something;
 310   if x = true then
 311     Response.SendRedirect(FDTable2.FieldByName('home').AsAnsiString + 'login');
 312 end;
 313
 314 procedure TWebModule1.WebModule1admindelAction(Sender: TObject;
 315   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 316 var
 317   i: integer;
 318 begin
 319   for i := 0 to Request.ContentFields.count - 1 do
 320     if FDTable1.Locate('no', Request.ContentFields.ValueFromIndex[i], []) = true
 321     then
 322       FDTable1.Delete;
 323   Response.SendRedirect(FDTable2.FieldByName('home').AsAnsiString + 'admin');
 324 end;
 325
 326 procedure TWebModule1.WebModule1DefaultHandlerAction(Sender: TObject;
 327   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 328 begin
 329   pos := StrToIntDef(Request.QueryFields.Values['pos'], -1);
 330   FDTable1.Filtered := false;
 331   user := Request.CookieFields.Values['UID'];
 332   PageProducer1.HTMLFile := path + 'index.htm';
 333   Response.ContentType := 'text/html; charset=utf-8;';
 334   Response.Content := PageProducer1.Content;
 335 end;
 336
 337 procedure TWebModule1.WebModule1loginAction(Sender: TObject;
 338   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 339 begin
 340   PageProducer1.HTMLFile := path + 'login.htm';
 341   Response.ContentType := 'text/html; charset=utf-8;';
 342   Response.Content := PageProducer1.Content;
 343 end;
 344
 345 procedure TWebModule1.WebModule1registAction(Sender: TObject;
 346   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 347 var
 348   na, sub, com, pass: string;
 349   no: integer;
 350   s: AnsiString;
 351   i: integer;
 352 begin
 353   with Request.ContentFields do
 354   begin
 355     na := Values['name'];
 356     sub := Values['title'];
 357     com := Values['comment'];
 358     pass := Values['password'];
 359   end;
 360   if na = '' then
 361     na := '\92N\82©\82³\82ñ';
 362   if sub = '' then
 363     sub := '\83^\83C\83g\83\8b\82È\82µ';
 364   if com = '' then
 365   begin
 366     Response.Content := '\96{\95¶\82ª\82 \82è\82Ü\82¹\82ñ.'#$D#$A;
 367   end
 368   else
 369   begin
 370     s := ReplaceText(AnsiString(com), #$D#$A, '<br>');
 371   end;
 372   for i := 0 to words.count - 1 do
 373     if ContainsText(s, AnsiString(words[i])) = true then
 374     begin
 375       Response.Content := Response.Content + '\8bÖ\8e~\8cê\8bå\82ª\8aÜ\82Ü\82ê\82Ü\82·.';
 376       break;
 377     end;
 378   if FDTable1.RecordCount = 0 then
 379   begin
 380     no := 1;
 381   end
 382   else
 383   begin
 384     FDTable1.Last;
 385     no := FDTable1.FieldByName('no').AsInteger + 1;
 386     if SecondsBetween(Now, StrToDateTime(FDTable1.FieldByName('date').AsString))
 387       < time then
 388       Response.Content := '\8d¬\82Ý\8d\87\82Á\82Ä\82¢\82Ü\82·.';
 389   end;
 390   if Response.Content <> '' then
 391   begin
 392     Response.ContentType := 'text/plain;';
 393     Exit;
 394   end;
 395   FDTable1.AppendRecord([na, no, DateTimeToStr(Now), sub, s, pass]);
 396   with Response.Cookies.Add do
 397   begin
 398     path := FDTable2.FieldByName('home').AsAnsiString;
 399     Name := 'UID';
 400     Value := AnsiString(na);
 401     Expires := Now + 1;
 402   end;
 403   Response.SendRedirect(FDTable2.FieldByName('home').AsAnsiString);
 404 end;
 405
 406 procedure TWebModule1.WebModule1searchAction(Sender: TObject;
 407   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 408 var
 409   s: TStringList;
 410   t1, t2, t3: string;
 411   i: integer;
 412 begin
 413   t1 := Request.ContentFields.Values['filter'];
 414   t3 := '';
 415   s := TStringList.Create;
 416   try
 417     s.DelimitedText := Request.ContentFields.Values['word1'];
 418     for i := 0 to s.count - 1 do
 419     begin
 420       t2 := Trim(s[i]);
 421       if t2 = '' then
 422         continue;
 423       if t3 <> '' then
 424         t3 := t3 + ' and ';
 425       t3 := t3 + t1 + ' LIKE ''%' + t2 + '%''';
 426     end;
 427   finally
 428     s.Free;
 429   end;
 430   FDTable1.Filter := t3;
 431   FDTable1.Filtered := true;
 432   PageProducer1.HTMLFile := path + 'search.htm';
 433   Response.ContentType := 'text/html; charset=utf-8;';
 434   Response.Content := PageProducer1.ContentFromString(PageProducer1.Content);
 435 end;
 436
 437 procedure TWebModule1.WebModule1setupAction(Sender: TObject;
 438   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 439 var
 440   i: integer;
 441   s: string;
 442 begin
 443   for i := 0 to Request.ContentFields.count - 1 do
 444   begin
 445     s := Request.ContentFields.Names[i];
 446     if s <> 'home' then
 447       FDTable2.FieldByName(s).AsString :=
 448         Request.ContentFields.ValueFromIndex[i];
 449   end;
 450   Handled := false;
 451 end;
 452
 453 procedure TWebModule1.WebModule1userdelAction(Sender: TObject;
 454   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 455 var
 456   s: string;
 457   i: integer;
 458 begin
 459   i := StrToIntDef(Request.ContentFields.Values['number'], 0);
 460   if (i > 0) and (FDTable1.Locate('no', i, []) = true) then
 461   begin
 462     s := FDTable1.FieldByName('pass').AsString;
 463     if (s <> '') and (s = Request.ContentFields.Values['password']) then
 464       FDTable1.Delete;
 465   end;
 466   Handled := false;
 467 end;
 468
 469 procedure TWebModule1.WebModuleBeforeDispatch(Sender: TObject;
 470   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 471 var
 472   s: string;
 473 begin
 474   if FDTable1.Exists = false then
 475     FDTable1.CreateTable(false, [tpTable]);
 476   if FDTable2.Exists = false then
 477   begin
 478     FDTable2.CreateTable(false, [tpTable]);
 479     FDTable2.Active := true;
 480     if Request.ServerPort = 80 then
 481     begin
 482       s := 'http://' + String(Request.Host);
 483     end
 484     else
 485     begin
 486       s := 'http://' + String(Request.Host) + ':' +
 487         IntToStr(Request.ServerPort);
 488     end;
 489     if Request.ScriptName <> '' then
 490     begin
 491       s := s + String(Request.ScriptName) + '/';
 492     end
 493     else
 494     begin
 495       s := s + '/';
 496     end;
 497     FDTable2.AppendRecord([s, 'pbbs clone',
 498       '<center><font size=5 face=Verdana color=gray><b>P-BBS CLONE</b></font></center>',
 499       'admin', '\82 \82Ù,\82Î\82©,\8e\80\82Ë']);
 500     PageProducer1.HTMLFile := path + 'setup.htm';
 501     Response.ContentType := 'text/html; charset=utf-8;';
 502     Response.Content := PageProducer1.Content;
 503     Handled := true;
 504   end
 505   else
 506   begin
 507     FDTable2.Active := true;
 508   end;
 509   if FDTable3.Exists = false then
 510   begin
 511     FDTable3.CreateTable(false, [tpTable]);
 512     FDTable3.Active := true;
 513     FDTable3.AppendRecord([5, 20]);
 514   end
 515   else
 516   begin
 517     FDTable3.Active := true;
 518   end;
 519   words.DelimitedText := FDTable2.FieldByName('ngwords').AsString;
 520   FDTable1.Active := true;
 521   if FileExists(path + 'maintenance.htm') = true then
 522   begin
 523     PageProducer1.HTMLFile := path + 'maintenance.htm';
 524     Response.ContentType := 'text/html; charset=utf-8;';
 525     Response.Content := PageProducer1.Content;
 526     Handled := true;
 527   end;
 528 end;
 529
 530 procedure TWebModule1.WebModuleCreate(Sender: TObject);
 531 begin
 532   time := 1;
 533   words := TStringList.Create;
 534 end;
 535
 536 procedure TWebModule1.WebModuleDestroy(Sender: TObject);
 537 begin
 538   words.Free;
 539 end;
 540
 541 end.