unit WebModuleUnit1;

interface

uses System.SysUtils, System.Classes, Web.HTTPApp, FireDAC.Stan.Intf,
  FireDAC.Stan.Option, FireDAC.Stan.Param, FireDAC.Stan.Error, FireDAC.DatS,
  FireDAC.Phys.Intf, FireDAC.DApt.Intf, FireDAC.Stan.Async, FireDAC.DApt,
  FireDAC.UI.Intf, FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Phys,
  FireDAC.Phys.SQLite, FireDAC.Phys.SQLiteDef, FireDAC.Stan.ExprFuncs, Data.DB,
  FireDAC.Comp.Client, FireDAC.Comp.DataSet, Web.HTTPProd, Web.DSProd,
  AnsiStrings, System.DateUtils;

type
  TWebModule1 = class(TWebModule)
    FDTable1: TFDTable;
    FDConnection1: TFDConnection;
    FDTable2: TFDTable;
    FDTable2home: TWideMemoField;
    FDTable2title: TWideMemoField;
    FDTable2title2: TWideMemoField;
    FDTable2pass: TWideMemoField;
    PageProducer1: TPageProducer;
    DataSetPageProducer2: TDataSetPageProducer;
    FDTable1name: TWideMemoField;
    FDTable1no: TIntegerField;
    FDTable1date: TWideMemoField;
    FDTable1sub: TWideMemoField;
    FDTable1com: TWideMemoField;
    FDTable1pass: TWideMemoField;
    adminDS: TDataSetPageProducer;
    FDTable2ngwords: TWideMemoField;
    procedure WebModule1DefaultHandlerAction(Sender: TObject;
      Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
    procedure PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
      const TagString: string; TagParams: TStrings; var ReplaceText: string);
    procedure WebModule1registAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure DataSetPageProducer2HTMLTag(Sender: TObject; Tag: TTag;
      const TagString: string; TagParams: TStrings; var ReplaceText: string);
    procedure WebModule1userdelAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure WebModule1adminAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure WebModule1admindelAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure WebModule1loginAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure WebModuleBeforeDispatch(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure WebModule1setupAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure WebModule1searchAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure WebModuleCreate(Sender: TObject);
    procedure WebModuleDestroy(Sender: TObject);
  private
    { private 宣言 }
  public
    { public 宣言 }
    user: string;
    time: Int64;
    count: integer;
    words: TStringList;
    pos: integer;
    link: integer;
    foo: string;
    function footer(const path: string): string;
  end;

var
  WebModuleClass: TComponentClass = TWebModule1;

implementation

{ %CLASSGROUP 'Vcl.Controls.TControl' }

{$R *.dfm}

const
  path = '';// 'C:\Users\fuke masasi\Documents\Embarcadero\Studio\Projects\pbbs\';

procedure TWebModule1.DataSetPageProducer2HTMLTag(Sender: TObject; Tag: TTag;
  const TagString: string; TagParams: TStrings; var ReplaceText: string);
begin
  if TagString = 'home' then
  begin
    ReplaceText := FDTable2.FieldByName('home').AsString;
  end
  else
  begin
    ReplaceText := FDTable1.FieldByName(TagString).AsString;
  end;
end;

function TWebModule1.footer(const path: string): string;
var
  s1, s2, t1, t2: string;
  i, k: integer;
  function linkcontent: string;
  var
    j: integer;
  begin
    result := '';
    if pos > link div 2 then
    begin
      i := -(link div 2);
    end
    else
    begin
      i := -pos;
    end;
    for j := 0 to link - 1 do
    begin
      if FDTable1.RecordCount <= (pos + i + j) * count then
        break;
      if i + j = 0 then
      begin
        result := result + '  ' + IntToStr(pos) + '  ';
      end
      else
      begin
        result := result + Format('  <a href="' + FDTable2.FieldByName('home')
          .AsString + path + '?pos=%d">%d</a>  ', [pos + i + j, pos + i + j]);
      end;
    end;
  end;

begin
  if pos <= -1 then
  begin
    s1 := '最新%d件の記事を表示<br><center>Pages : [<b>';
    s2 := '<<' + linkcontent + '>>]  最新</b><br></center>';
    result := Format(s1, [count]) + s2;
  end
  else
  begin
    if pos = 0 then
    begin
      t1 := '?pos=0';
    end
    else
    begin
      t1 := '?pos=' + IntToStr(pos - 1);
    end;
    i := FDTable1.RecordCount div count;
    if pos > i then
      pos := i;
    if pos = i then
    begin
      t2 := '?pos=' + IntToStr(pos);
      k := FDTable1.RecordCount;
    end
    else
    begin
      t2 := '?pos=' + IntToStr(pos + 1);
      k := (pos + 1) * count;
    end;
    s1 := '%d 件中 %d 件から %d 件まで表示<br><center>Page : [<b>';
    s2 := '<a href="' + FDTable2.FieldByName('home').AsString + path + t1 +
      '"><<</a>' + linkcontent + '<a href="' + FDTable2.FieldByName('home')
      .AsString + path + t2 + '">>></a>]  <a href="' +
      FDTable2.FieldByName('home').AsString + path + '">最新</a></b></center>';
    result := Format(s1, [FDTable1.RecordCount, pos * count + 1, k]) + s2;
  end;
end;

procedure TWebModule1.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  const TagString: string; TagParams: TStrings; var ReplaceText: string);
var
  i, j: integer;
  s: TDataSetPageProducer;
  t: string;
begin
  if (TagString = 'home') or (TagString = 'title') or (TagString = 'title2')
  then
    ReplaceText := FDTable2.FieldByName(TagString).AsString;
  if TagString = 'username' then
    ReplaceText := user;
  if TagString = 'main' then
  begin
    t := ExtractFileName(PageProducer1.HTMLFile);
    if FDTable1.RecordCount = 0 then
    begin
      if t = 'index.htm' then
        ReplaceText := 'まだ投稿がありません.';
    end
    else
    begin
      if t = 'admin.htm' then
      begin
        s := adminDS;
      end
      else
      begin
        s := DataSetPageProducer2;
      end;
      if pos < -1 then
        pos := -1;
      if (pos + 1) * count > FDTable1.RecordCount then
        pos := (FDTable1.RecordCount - 1) div count;
      if pos = -1 then
      begin
        if FDTable1.RecordCount < count then
        begin
          j := FDTable1.RecordCount mod count;
        end
        else
        begin
          j := count;
        end;
      end
      else if FDTable1.RecordCount < (pos + 1) * count then
      begin
        j := FDTable1.RecordCount - pos * count;
      end
      else
      begin
        j := count;
      end;
      if pos = -1 then
      begin
        FDTable1.Last;
      end
      else
      begin
        FDTable1.RecNo := (pos + 1) * count;
      end;
      for i := 1 to j do
      begin
        ReplaceText := ReplaceText + s.Content;
        FDTable1.Prior;
      end;
    end;
  end;
  if TagString = 'footer' then
    if TagParams.Values['refer'] = 'true' then
    begin
      ReplaceText := foo;
    end
    else
    begin
      t := ExtractFileName(PageProducer1.HTMLFile);
      foo := footer(ChangeFileExt(t, ''));
      ReplaceText := foo;
    end;
  if TagString = 'text' then
    if FDTable1.Filter = '' then
    begin
      ReplaceText := '検索します';
    end
    else
    begin
      ReplaceText := '該当結果 ' + IntToStr(FDTable1.RecordCount) + ' 件' +
        '<br><#main>';
    end;
end;

procedure TWebModule1.WebModule1adminAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: string;
  x: Boolean;
  procedure something;
  begin
    x := false;
    FDTable1.Filtered := false;
    PageProducer1.HTMLFile := path + 'admin.htm';
    Response.ContentType := 'text/html; charset=utf-8;';
    Response.Content := PageProducer1.Content;
  end;

begin
  x := true;
  s := Request.ContentFields.Values['password'];
  pos := StrToIntDef(Request.QueryFields.Values['pos'], -1);
  if s <> '' then
  begin
    with Response.Cookies.Add do
    begin
      path := FDTable2.FieldByName('home').AsAnsiString + 'admin';
      Expires := Now + 1;
      Name := 'psw';
      Value := AnsiString(s);
      // Secure := true;
    end;
    if s = FDTable2.FieldByName('pass').AsString then
      something;
  end
  else if Request.CookieFields.Values['psw'] = FDTable2.FieldByName('pass').AsString
  then
    something;
  if x = true then
    Response.SendRedirect(FDTable2.FieldByName('home').AsAnsiString + 'login');
end;

procedure TWebModule1.WebModule1admindelAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  i: integer;
begin
  for i := 0 to Request.ContentFields.count - 1 do
    if FDTable1.Locate('no', Request.ContentFields.ValueFromIndex[i], []) = true
    then
      FDTable1.Delete;
  Response.SendRedirect(FDTable2.FieldByName('home').AsAnsiString + 'admin');
end;

procedure TWebModule1.WebModule1DefaultHandlerAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  pos := StrToIntDef(Request.QueryFields.Values['pos'], -1);
  FDTable1.Filtered := false;
  user := Request.CookieFields.Values['UID'];
  PageProducer1.HTMLFile := path + 'index.htm';
  Response.ContentType := 'text/html; charset=utf-8;';
  Response.Content := PageProducer1.Content;
end;

procedure TWebModule1.WebModule1loginAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  PageProducer1.HTMLFile := path + 'login.htm';
  Response.ContentType := 'text/html; charset=utf-8;';
  Response.Content := PageProducer1.Content;
end;

procedure TWebModule1.WebModule1registAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  na, sub, com, pass: string;
  no: integer;
  s: AnsiString;
  i: integer;
begin
  with Request.ContentFields do
  begin
    na := Values['name'];
    sub := Values['title'];
    com := Values['comment'];
    pass := Values['password'];
  end;
  if na = '' then
    na := '誰かさん';
  if sub = '' then
    sub := 'タイトルなし';
  if com = '' then
  begin
    Response.Content := '本文がありません.'#$D#$A;
  end
  else
  begin
    s := ReplaceText(AnsiString(com), #$D#$A, '<br>');
  end;
  for i := 0 to words.count - 1 do
    if ContainsText(s, AnsiString(words[i])) = true then
    begin
      Response.Content := Response.Content + '禁止語句が含まれます.';
      break;
    end;
  if FDTable1.RecordCount = 0 then
  begin
    no := 1;
  end
  else
  begin
    FDTable1.Last;
    no := FDTable1.FieldByName('no').AsInteger + 1;
    if SecondsBetween(Now, StrToDateTime(FDTable1.FieldByName('date').AsString))
      < time then
      Response.Content := '混み合っています.';
  end;
  if Response.Content <> '' then
  begin
    Response.ContentType := 'text/plain;';
    Exit;
  end;
  FDTable1.AppendRecord([na, no, DateTimeToStr(Now), sub, s, pass]);
  with Response.Cookies.Add do
  begin
    path := FDTable2.FieldByName('home').AsAnsiString;
    Name := 'UID';
    Value := AnsiString(na);
    Expires := Now + 1;
  end;
  Response.SendRedirect(FDTable2.FieldByName('home').AsAnsiString);
end;

procedure TWebModule1.WebModule1searchAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: TStringList;
  t1, t2, t3: string;
  i: integer;
begin
  t1 := Request.ContentFields.Values['filter'];
  t3 := '';
  s := TStringList.Create;
  try
    s.DelimitedText := Request.ContentFields.Values['word1'];
    for i := 0 to s.count - 1 do
    begin
      t2 := Trim(s[i]);
      if t2 = '' then
        continue;
      if t3 <> '' then
        t3 := t3 + ' and ';
      t3 := t3 + t1 + ' LIKE ''%' + t2 + '%''';
    end;
  finally
    s.Free;
  end;
  FDTable1.Filter := t3;
  FDTable1.Filtered := true;
  PageProducer1.HTMLFile := path + 'search.htm';
  Response.ContentType := 'text/html; charset=utf-8;';
  Response.Content := PageProducer1.ContentFromString(PageProducer1.Content);
end;

procedure TWebModule1.WebModule1setupAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  i: integer;
  s: string;
begin
  for i := 0 to Request.ContentFields.count - 1 do
  begin
    s := Request.ContentFields.Names[i];
    if s <> 'home' then
      FDTable2.FieldByName(s).AsString :=
        Request.ContentFields.ValueFromIndex[i];
  end;
  Handled := false;
end;

procedure TWebModule1.WebModule1userdelAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: string;
  i: integer;
begin
  i := StrToIntDef(Request.ContentFields.Values['number'], 0);
  if (i > 0) and (FDTable1.Locate('no', i, []) = true) then
  begin
    s := FDTable1.FieldByName('pass').AsString;
    if (s <> '') and (s = Request.ContentFields.Values['password']) then
      FDTable1.Delete;
  end;
  Handled := false;
end;

procedure TWebModule1.WebModuleBeforeDispatch(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: string;
begin
  if FDTable1.Exists = false then
    FDTable1.CreateTable(false, [tpTable]);
  if FDTable2.Exists = false then
  begin
    FDTable2.CreateTable(false, [tpTable]);
    FDTable2.Active := true;
    if Request.ServerPort = 80 then
    begin
      s := 'http://' + Request.Host;
    end
    else
    begin
      s := 'http://' + Request.Host + ':' + IntToStr(Request.ServerPort);
    end;
    if Request.ScriptName <> '' then
    begin
      s := s + Request.ScriptName + '/';
    end
    else
    begin
      s := s + '/';
    end;
    FDTable2.AppendRecord([s, 'pbbs clone',
      '<center><font size=5 face=Verdana color=gray><b>P-BBS CLONE</b></font></center>',
      'admin', 'あほ,ばか,死ね']);
    PageProducer1.HTMLFile := path + 'setup.htm';
    Response.ContentType := 'text/html; charset=utf-8;';
    Response.Content := PageProducer1.Content;
    Handled := true;
  end
  else
  begin
    FDTable2.Active := true;
  end;
  words.DelimitedText := FDTable2.FieldByName('ngwords').AsString;
  FDTable1.Active := true;
end;

procedure TWebModule1.WebModuleCreate(Sender: TObject);
begin
  time := 1;
  count := 20;
  link := 5;
  words := TStringList.Create;
end;

procedure TWebModule1.WebModuleDestroy(Sender: TObject);
begin
  words.Free;
end;

end.
