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;

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;
    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);
  private
    { private 宣言 }
  public
    { public 宣言 }
    user: 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;

procedure TWebModule1.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  const TagString: string; TagParams: TStrings; var ReplaceText: string);
var
  i: 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;
      FDTable1.Last;
      for i := 1 to FDTable1.RecordCount do
      begin
        ReplaceText := ReplaceText + s.Content;
        FDTable1.Prior;
      end;
    end;
  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'];
  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
  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;
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.ContentType := 'text/plain; charset=utf-8;';
    Response.Content := '本文がありません.';
    Exit;
  end
  else
  begin
    s := ReplaceText(AnsiString(com), #$D#$A, '<br>');
  end;
  if FDTable1.RecordCount = 0 then
  begin
    no := 1;
  end
  else
  begin
    FDTable1.Last;
    no := FDTable1.FieldByName('no').AsInteger + 1;
  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;
  FDTable1.Active := true;
end;

end.
