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, System.NetEncoding;

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;
    procedure regist(var com: string);
  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);
var
  s: TURLEncoding;
begin
  ReplaceText := FDTable1.FieldByName(TagString).AsString;
  if TagString = 'com' then
    regist(ReplaceText);
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 := 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 := 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;

procedure TWebModule1.regist(var com: string);
var
  i: integer;
begin
  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);
  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 := '/';
      Expires := Now + day;
      Name := 'psw';
      Value := AnsiString(pass);
    end;
  end;

begin
  if Request.Query = 'del' then
  begin
    addcookie(-3, '');
    Response.SendRedirect(FDTable2.FieldByName('home').AsAnsiString + '/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(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.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(FDTable2.FieldByName('home').AsAnsiString + '/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(FDTable2.FieldByName('home').AsAnsiString + '/admin');
end;

procedure TWebModule1.WebModule1DefaultHandlerAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  s: TResourceStream;
  t: TURLEncoding;
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);
  s := TResourceStream.Create(HInstance, 'index', RT_RCDATA);
  t := TURLEncoding.Create;
  try
    user := t.Decode(Request.CookieFields.Values['UID']);
    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;
  t: TURLEncoding;
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
    for i := 1 to Length(com) do
      if Copy(com, i, i + 2) = #$D#$A then
        inc(line);
  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;
  t := TURLEncoding.Create;
  try
    FDTable1.AppendRecord([na, no, DateTimeToStr(Now), sub,
      ReplaceText(ReplaceText(com, '<', t.Encode('<')), '>', t.Encode('>')),
      pass, line]);
  finally
    t.Free;
  end;
  with Response.Cookies.Add do
  begin
    path := '/';
    Name := 'UID';
    Value := AnsiString(na);
    Expires := Now + 1;
  end;
  Response.SendRedirect(FDTable2.FieldByName('home').AsAnsiString +
    '/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
  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);
    }
    FDTable2.AppendRecord([Request.ScriptName, '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.
