svn/view/WebModuleUnit1.pas

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, System.Types, Vcl.AppEvnts;

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;
    FDTable3: TFDTable;
    FDTable3link: TIntegerField;
    FDTable3count: TIntegerField;
    FDTable1line: TIntegerField;
    FDTable3line: TIntegerField;
    FDTable2mente: TBooleanField;
    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);
    procedure WebModule1adminsetAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
  private
    { private ���� }
  public
    { public ���� }
    user: string;
    time: Int64;
    words: TStringList;
    position: integer;
    uri: string;
    er: string;
    foo: string;
    function footer(const path: string): string;
    function regist(var com: string): integer;
  end;

var
  WebModuleClass: TComponentClass = TWebModule1;

implementation

{ %CLASSGROUP 'Vcl.Controls.TControl' }

{$R *.dfm}

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

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

begin
  count := FDTable3.FieldByName('count').AsInteger;
  home := 'http://' + FDTable2.FieldByName('home').AsString;
  if position <= -1 then
  begin
    s1 := '���V%d�����L�����\��<br><center>Pages : [<b>';
    s2 := '<<' + linkcontent + '>>]  ���V</b><br></center>';
    result := Format(s1, [count]) + s2;
  end
  else
  begin
    if position = 0 then
      t1 := '?pos=0'
    else
      t1 := '?pos=' + IntToStr(position - 1);
    i := (FDTable1.RecordCount - 1) div count;
    if position > i then
      position := i;
    if position = i then
    begin
      t2 := '?pos=' + position.ToString + '#article';
      k := FDTable1.RecordCount;
    end
    else
    begin
      t2 := '?pos=' + IntToStr(position + 1) + '#article';
      k := (position + 1) * count;
    end;
    s1 := '%d ���� %d ������ %d �������\��<br><center>Page : [<b>';
    s2 := '<a href="' + home + path + t1 + '#article"><<</a>' + linkcontent +
      '<a href="' + home + path + t2 + '">>></a>]  <a href="' + home + path +
      '#article">���V</a></b></center>';
    result := Format(s1, [FDTable1.RecordCount, position * count + 1, k]) + s2;
  end;
end;

procedure TWebModule1.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  const TagString: string; TagParams: TStrings; var ReplaceText: string);
var
  i, j, count: integer;
  s: TDataSetPageProducer;
begin
  if TagString = 'home' then
      ReplaceText := 'http://' + FDTable2.FieldByName('home').AsString;
  if (TagString = 'title') or (TagString = 'title2') then
    ReplaceText := FDTable2.FieldByName(TagString).AsString;
  if TagString = 'username' then
    ReplaceText := user;
  if TagString = 'main' then
  begin
    if FDTable1.RecordCount = 0 then
    begin
      if uri = 'index' then
        ReplaceText := '<hr>�������e������������.<hr>';
    end
    else
    begin
      count := FDTable3.FieldByName('count').AsInteger;
      if uri = 'admin' then
        s := adminDS
      else
        s := DataSetPageProducer2;
      if position < -1 then
        position := -1;
      if (position + 1) * count > FDTable1.RecordCount then
        position := (FDTable1.RecordCount - 1) div count;
      if position = -1 then
      begin
        if FDTable1.RecordCount < count then
          j := FDTable1.RecordCount mod count
        else
          j := count;
      end
      else if FDTable1.RecordCount < (position + 1) * count then
        j := FDTable1.RecordCount - position * count
      else
        j := count;
      if position = -1 then
        FDTable1.Last
      else
        FDTable1.RecNo := (position + 1) * count;
      for i := 1 to j do
      begin
        ReplaceText := ReplaceText + s.Content;
        FDTable1.Prior;
      end;
      ReplaceText := ReplaceText + '<hr>';
    end;
  end;
  if TagString = 'footer' then
    if TagParams.Values['refer'] = 'true' then
      ReplaceText := foo
    else
    begin
      foo := footer(uri);
      ReplaceText := foo;
    end;
  if TagString = 'text' then
    if FDTable1.Filtered = false then
      ReplaceText := '����������'
    else
      ReplaceText := '�Y������ ' + IntToStr(FDTable1.RecordCount) + ' ��' +
        '<br><#main>';
  if TagString = 'pass' then
    ReplaceText := FDTable2.FieldByName('pass').AsString;
  if TagString = 'content' then
    ReplaceText := er;
  if (TagString = 'mente') and (FDTable2.FieldByName('mente').AsBoolean = True)
  then
    ReplaceText := 'checked="checked"';
end;

function TWebModule1.regist(var com: string): integer;
var
  i: integer;
begin
  result := 1;
  i := 1;
  while True do
  begin
    i := Pos(#$D#$A, com, i);
    if i = 0 then
      break;
    Delete(com, i, Length(#$D#$A));
    Insert('<br>', com, i);
    inc(i, 4);
    inc(result);
  end;
end;

procedure TWebModule1.WebModule1adminAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  t: string;
  x: Boolean;
  procedure something;
  var
    s: TResourceStream;
  begin
    x := false;
    s := TResourceStream.Create(HInstance, 'admin', RT_RCDATA);
    try
      uri := 'admin';
      Response.ContentType := 'text/html; charset=utf-8;';
      Response.Content := PageProducer1.ContentFromStream(s)
    finally
      s.Free;
    end;
  end;
  procedure addcookie(day: integer; pass: string);
  begin
    with Response.Cookies.Add do
    begin
      path := AnsiString('/admin');
      Expires := Now + day;
      Name := 'psw';
      Value := AnsiString(pass);
    end;
  end;

begin
  if Request.Query = 'del' then
  begin
    addcookie(-3, '');
    Response.SendRedirect('/index');
    Exit;
  end;
  x := True;
  t := Request.ContentFields.Values['password'];
  position := StrToIntDef(Request.QueryFields.Values['pos'], -1);
  if t <> '' then
  begin
    addcookie(14, t);
    if t = 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('/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('/admin');
end;

procedure TWebModule1.WebModule1adminsetAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: string;
  x: Boolean;
begin
  s := Request.ContentFields.Values['pass'];
  if FDTable2.FieldByName('pass').AsString <> s then
  begin
    FDTable2.Edit;
    FDTable2.FieldByName('pass').AsString := s;
    FDTable2.Post;
    with Response.Cookies.Add do
    begin
      path := AnsiString('/admin');
      Expires := Now + 14;
      Name := 'psw';
      Value := AnsiString(s);
    end;
  end;
  x := Request.ContentFields.Values['mente'] = 'on';
  if FDTable2.FieldByName('mente').AsBoolean <> x then
  begin
    FDTable2.Edit;
    FDTable2.FieldByName('mente').AsBoolean := x;
    FDTable2.Post;
  end;
  Response.SendRedirect('/admin');
end;

procedure TWebModule1.WebModule1DefaultHandlerAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: TResourceStream;
begin
  if FDTable2.FieldByName('mente').AsBoolean = True then
  begin
    s := TResourceStream.Create(HInstance, 'mente', RT_RCDATA);
    try
      uri := 'mente';
      Response.ContentType := 'text/html; charset=utf-8;';
      Response.Content := PageProducer1.ContentFromStream(s);
    finally
      s.Free;
    end;
    Exit;
  end;
  position := StrToIntDef(Request.QueryFields.Values['pos'], -1);
  user := Request.CookieFields.Values['UID'];
  s := TResourceStream.Create(HInstance, 'index', RT_RCDATA);
  try
    uri := 'index';
    Response.ContentType := 'text/html; charset=utf-8;';
    Response.Content := PageProducer1.ContentFromStream(s);
  finally
    s.Free;
  end;
end;

procedure TWebModule1.WebModule1loginAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: TResourceStream;
begin
  s := TResourceStream.Create(HInstance, 'login', RT_RCDATA);
  try
    uri := 'login';
    Response.ContentType := 'text/html; charset=utf-8;';
    Response.Content := PageProducer1.ContentFromStream(s);
  finally
    s.Free;
  end;
end;

procedure TWebModule1.WebModule1registAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  na, sub, com, pass: string;
  no, line: integer;
  i: integer;
  s: TResourceStream;
begin
  with Request.ContentFields do
  begin
    na := Values['name'];
    sub := Values['title'];
    com := Values['comment'];
    pass := Values['password'];
  end;
  er := '';
  line := 0;
  if na = '' then
    na := '�N������';
  if sub = '' then
    sub := '�^�C�g������';
  if com = '' then
    er := '�{��������������.'#$D#$A
  else
    line := regist(com);
  for i := 0 to words.count - 1 do
    if ContainsText(AnsiString(com), AnsiString(words[i])) = True then
    begin
      er := er + '���~����������������.';
      break;
    end;
  if FDTable1.RecordCount = 0 then
    no := 1
  else
  begin
    FDTable1.Last;
    no := FDTable1.FieldByName('no').AsInteger + 1;
    if SecondsBetween(Now, StrToDateTime(FDTable1.FieldByName('date').AsString))
      < time then
      er := '����������������.';
  end;
  if er <> '' then
  begin
    Response.ContentType := 'text/html; charset=utf-8;';
    s := TResourceStream.Create(HInstance, 'regist', RT_RCDATA);
    try
      Response.Content := PageProducer1.ContentFromStream(s);
    finally
      s.Free;
    end;
    Exit;
  end;
  FDTable1.AppendRecord([na, no, DateTimeToStr(Now), sub, com, pass, line]);
  with Response.Cookies.Add do
  begin
    path := FDTable2.FieldByName('home').AsAnsiString;
    Name := 'UID';
    Value := AnsiString(na);
    Expires := Now + 1;
  end;
  Response.SendRedirect('/index#article');
end;

procedure TWebModule1.WebModule1searchAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: TStringList;
  t1, t2, t3: string;
  i, j: integer;
  m: TResourceStream;
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;
  if t3 = '' then
  begin
    m := TResourceStream.Create(HInstance, 'search', RT_RCDATA);
    try
      Response.ContentType := 'text/html; charset=utf-8;';
      Response.Content := PageProducer1.ContentFromStream(m);
    finally
      m.Free;
    end;
    Exit;
  end;
  FDTable1.Filter := t3;
  FDTable1.Filtered := True;
  m := TResourceStream.Create(HInstance, 'search', RT_RCDATA);
  try
    j := 0;
    for i := 1 to FDTable1.RecordCount - 1 do
    begin
      inc(j, FDTable1.FieldByName('line').AsInteger);
      FDTable1.Next;
    end;
    PageProducer1.HTMLDoc.LoadFromStream(m);
    Response.ContentType := 'text/html; charset=utf-8;';
    if (t3 <> '') and (j > FDTable3.FieldByName('line').AsInteger) then
    begin
      t1 := PageProducer1.Content;
      i := Pos('<#main>', t1);
      Delete(t1, i, Length('<#main>'));
      Response.Content := t1 + Format('�\���s����%d�s��������������.',
        [FDTable3.FieldByName('line').AsInteger]);
    end
    else
      Response.Content := PageProducer1.ContentFromString
        (PageProducer1.Content);
  finally
    FDTable1.Filtered := false;
    m.Free;
  end;
end;

procedure TWebModule1.WebModule1setupAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  i: integer;
  s: string;
begin
  FDTable2.Edit;
  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]
    else
      FDTable2.FieldByName(s).AsString := Request.ContentFields.Values[s];
  end;
  FDTable2.Post;
  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: AnsiString;
  m: TResourceStream;
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) or (Request.ServerPort = 443) then
      s := 'http://' + String(Request.Host)
      else
      s := 'http://' + String(Request.Host) + ':' +
      IntToStr(Request.ServerPort);
    }
    if Request.ScriptName <> '' then
      s := Request.Host + Request.ScriptName + '/'
    else
      s := Request.Host + '/';
    FDTable2.AppendRecord([s, 'pbbs clone',
      '<center><font size=5 face=Verdana color=gray><b>P-BBS CLONE</b></font></center>',
      'admin', '����,����,����', false]);
    m := TResourceStream.Create(HInstance, 'setup', RT_RCDATA);
    try
      uri := 'setup';
      Response.ContentType := 'text/html; charset=utf-8;';
      Response.Content := PageProducer1.ContentFromStream(m);
    finally
      m.Free;
    end;
    Handled := True;
  end
  else
    FDTable2.Active := True;
  if FDTable3.Exists = false then
  begin
    FDTable3.CreateTable(false, [tpTable]);
    FDTable3.Active := True;
    FDTable3.AppendRecord([5, 20, 500]);
  end
  else
    FDTable3.Active := True;
  words.DelimitedText := FDTable2.FieldByName('ngwords').AsString;
  FDTable1.Active := True;
  {
    t:='';
    ssl:=TStringList.Create;
    try
    ssl.Add('/login');
    ssl.Add('/admin');
    if (ssl.IndexOf(Request.PathInfo) > -1)and(StartsText('https',FDTable2.FieldByName('home').AsString) = false) then
    begin
    s:=FDTable2.FieldByName('home').AsAnsiString;
    Delete(s,Length(s),1);
    t:='https'+Copy(s,5,Length(s))+Request.PathInfo;
    end;
    finally
    ssl.Free;
    end;
    if t <> '' then
    begin
    Response.SendRedirect(t);
    Exit;
    end;
  }
end;

procedure TWebModule1.WebModuleCreate(Sender: TObject);
begin
  FDConnection1.Open('Database=data.sdb;LockingMode=Normal;DriverID=SQLite');
  time := 1;
  words := TStringList.Create;
end;

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

end.
