program post_commit;

{$APPTYPE CONSOLE}

uses
    SysUtils,
    Windows, Messages,
    Classes,
    Contnrs,
    IniFiles,
    Iphelper,
    OverbyteIcsWndControl,
    OverbyteIcsWSocket,
    OverbyteIcsSmtpProt,
    OverbyteIcsDnsQuery;

const
    WM_NEXT_MAIL      = WM_USER + 1;
    WM_RESOLVE_NEXT   = WM_USER + 2;
var
    CurRepoPath : String = '';
    CurRev      : String = '';
type
    TCurState = (csGetMx, csSmtp);
    TMailer = class(TIcsWndControl)
    public
        DnsServers  : TStringList;
        RcptList    : TStringList;
        UseRelay    : Boolean;
        DoneFlag    : Boolean;
        Dns         : TDnsQuery;
        Smtp        : TSmtpCli;
        CurRepoPath : String;
        CurRev      : String;
        Host        : String;
        Port        : String;
        User        : String;
        Password    : String;
        Subject     : String;
        FromEmail   : String;
        LocalAddr   : String;
        HdrReturnPath : String;
        CurrentID   : Integer;
        CurCount    : Integer;
        CurRcpt     : Integer;
        Timer       : TIcsTimer;
        LastError   : String;
        SendFlag    : Boolean;
        CurState    : TCurState;
        Changelog   : TStringList;
        PathToSvnBin: String;
        HeloMsg     : String;
        CurThreadID : Cardinal;
        constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
        procedure   OnTimer(Sender: TObject);
        procedure   PumpMessages;
        function    ReadIni: Boolean;
        procedure   ResolveNext;
        procedure   SendNextMail;
        function    GetChangeLog: Boolean;
        procedure   DirectRequestDone(Sender : TObject; RqType: TSmtpRequest; ErrCode : Word);
        procedure   RelayRequestDone(Sender : TObject; RqType: TSmtpRequest; ErrCode : Word);
        procedure   SmtpSessionClosed(Sender : TObject; ErrCode : Word);
        procedure   DnsQueryRequestDone(Sender: TObject; ErrCode: Word);
        procedure   Run;
    end;


////////////////////////////////////////////////////////////////////////////////
function ExtractDomain(const Email: String): String;
var
    At   : Integer;
begin
    At := Pos('@', Email);
    if At = -1 then
        Exit;
    Result := Copy(EMail, At + 1, MaxInt);
    if (Result = '') or (Pos('.', Result) = -1) then
    begin
        Result := '';
        Exit;
    end;
end;


////////////////////////////////////////////////////////////////////////////////
var
  LogStream : TFileStream = nil;

procedure LogLine(const Msg: String);
var
    FileName : String;
    DateStr  : String;
begin
    try
        if not Assigned(LogStream) then
        begin
            FileName := ChangeFileExt(ParamStr(0), '.log');
            if not FileExists(FileName) then
                LogStream := TFileStream.Create(FileName, fmCreate or fmShareDenyWrite)
            else begin
                LogStream := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite);
                LogStream.Seek(0, sofromEnd);
            end;
        end;
        DateTimeToString(DateStr, 'yyyy:mm:dd hh:nn:ss ', Now);
        LogStream.Write(Pointer(DateStr)^, Length(DateStr));
        LogStream.Write(Pointer(Msg)^, Length(Msg));
        LogStream.Write(PChar(#13#10)^, 2);
    except
    end;
end;


////////////////////////////////////////////////////////////////////////////////
function TMailer.ReadIni : Boolean;
const
    Section = 'SETTINGS';
var
    Ini   : TIniFile;
    S     : String;
    I, J, Len  : Integer;
begin
    Result := FALSE;
    Ini := TIniFile.Create(ChangeFileExt(ParamStr(0), '.ini'));
    try
        UseRelay := Ini.ReadBool(Section, 'UseRelay', FALSE);
        if UseRelay then
        begin
            Host      := Ini.ReadString(Section, 'Host',      'localhost');
            if Host = '' then Host := 'localhost';
            Port      := Ini.ReadString(Section, 'Port',      'smtp');
            if Port = '' then Port := 'smtp';
            User      := Ini.ReadString(Section, 'UserName',  'foo');
            Password  := Ini.ReadString(Section, 'Password',  'bar');
        end
        else begin
            Port := 'smtp';
        end;
        HeloMsg := Ini.ReadString(Section, 'HeloMsg', '79.99.69.242');
        HdrReturnPath := Ini.ReadString(Section, 'HdrReturnPath', 'admin@localhost');
        LocalAddr := Ini.ReadString(Section, 'LocalAddr', '0.0.0.0');
        if LocalAddr = '' then LocalAddr := '0.0.0.0';
        PathToSvnBin := Ini.ReadString(Section, 'PathToSvnBin', 'c:\program files\subversion\bin');
        if PathToSvnBin = '' then PathToSvnBin := 'c:\program files\subversion\bin';
        FromEmail    := Ini.ReadString(Section, 'FromEmail',    'admin@localhost');
        if FromEmail = '' then FromEmail := 'admin@localhost';
        Subject      := Ini.ReadString(Section, 'Subject',      '[ICS SVN] Updated to revision #%s');

        S := Ini.ReadString(Section, 'RcptList', 'admin@localhost');
        I := 1;
        J := 1;
        Len := Length(S);
        while I <= Len do
        begin
            if I = Len then
                RcptList.Add(Copy(S, J, MaxInt))
            else
            if (S[I] in [',', ';']) then
            begin
                RcptList.Add(Copy(S, J, I - J));
                J := I + 1;
            end;
            Inc(I);
        end;
        Result := TRUE;
        FreeAndNil(Ini);
    except
        FreeAndNil(Ini);
    end;
end;


////////////////////////////////////////////////////////////////////////////////
procedure RunProc(const ConsoleApp: String; AStrings: TStrings);
var
   SAttr : TSecurityAttributes;
   SInfo : TStartUpInfo;
   PInfo : TProcessInformation;
   ReadPipe,WritePipe : THandle;
   BytesRead : DWord;
   WaitRes : DWord;
   ReadBuffer : array [0..255] of Char;
   LineBuf : array [0..1024] of Char;
   LineBufPtr: Integer;
   I : Integer;
   NewLine : Boolean;
begin
  with SAttr do
  begin
    nlength := SizeOf(TSecurityAttributes);
    binherithandle := True;
    lpsecuritydescriptor := nil;
  end;
  if not CreatePipe(ReadPipe, WritePipe, @SAttr, 0) then
    RaiseLastOSError;
  try
    FillChar(SInfo, Sizeof(SInfo), #0);
    SInfo.cb := SizeOf(SInfo);
    SInfo.hStdOutput := WritePipe;
    SInfo.hStdError  := WritePipe;
    SInfo.hStdInput  := GetStdHandle(STD_INPUT_HANDLE);
    SInfo.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
    SInfo.wShowWindow := SW_HIDE;

    if CreateProcess(nil,
           PChar(ConsoleApp),
           @SAttr,
           @SAttr,
           True,
           NORMAL_PRIORITY_CLASS,
           nil,
           nil,
           SInfo,
           PInfo) then
    begin
      try
        if WaitForInputIdle(PInfo.hProcess, 100) <> $FFFFFFFF then
            raise Exception.Create('Not a console app.');
        LineBufPtr := 0;
        Newline := True;
        CloseHandle(WritePipe);
        WritePipe := 0;
        while ReadFile(ReadPipe, ReadBuffer[0], SizeOf(ReadBuffer), BytesRead, nil) do
        begin
          for  I := 0 to BytesRead - 1 do
          begin
            if (ReadBuffer[I] = #10) then
              Newline := True
            else if (ReadBuffer[I] = #13) then
            begin
              LineBuf[LineBufPtr]:= #0;
              OemToChar(LineBuf, LineBuf);
              if Assigned(AStrings) then
              begin
                if Newline then
                  AStrings.Add(String(LineBuf))
                else
                  AStrings[AStrings.Count -1] := LineBuf;
              end;
              Newline := False;
              LineBufPtr := 0;
            end
            else begin
              LineBuf[LineBufPtr] := ReadBuffer[I];
              Inc(LineBufPtr);
              if LineBufPtr >= (SizeOf(LineBuf) - 1) then
              begin
                Newline := True;
                LineBuf[LineBufPtr]:= #0;
                OemToChar(LineBuf, LineBuf);
                if Assigned(AStrings) then
                begin
                  if Newline then
                    AStrings.Add(LineBuf)
                  else
                    AStrings[AStrings.Count -1] := LineBuf;
                end;
                Newline := False;
                LineBufPtr := 0;
              end;
            end;
          end;
        end;
        WaitRes := WaitForSingleObject(PInfo.hProcess, 1000);
        if WaitRes <> 0 then
          TerminateProcess(PInfo.hProcess, BytesRead);
      finally
        CloseHandle(PInfo.hProcess);
        CloseHandle(PInfo.hThread);
      end;
    end
    else
      RaiseLastOSError;
  finally
    CloseHandle(ReadPipe);
    if WritePipe <> 0 then
      CloseHandle(WritePipe);
  end;
end;


////////////////////////////////////////////////////////////////////////////////
constructor TMailer.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    GetHandle;
    CurThreadID := GetCurrentThreadID;
    RcptList   := TStringList.Create;
    DnsServers := TStringList.Create;
end;


////////////////////////////////////////////////////////////////////////////////
destructor TMailer.Destroy;
begin
    FreeAndNil(Timer);
    FreeAndNil(ChangeLog);
    FreeAndNil(RcptList);
    FreeAndNil(DnsServers);
    inherited;
end;


////////////////////////////////////////////////////////////////////////////////
procedure TMailer.DirectRequestDone(Sender: TObject; RqType: TSmtpRequest; ErrCode: Word);
var
    Cli : TSmtpCli;
begin
    CurCount := 0;
    Cli := TSmtpCli(Sender);
    try
        if (ErrCode <> 0) or ((RqType <> smtpQuit) and (not Cli.Connected)) then
        begin
            if ErrCode > 10000 then
                LogLine(Cli.Host + ' ' + Cli.HdrTo + ' Rq=' + IntToStr(Ord(Cli.RequestType)) + ' ' + GetWinsockErr(ErrCode))
            else
                LogLine(Cli.Host + ' ' + Cli.HdrTo + ' Rq=' + IntToStr(Ord(Cli.RequestType)) + ' ' + Cli.LastResponse);

            if Cli.Connected then
                Cli.Quit
            else
                Timer.Enabled := False;
            Exit;
        end;
        case RqType of
            smtpConnect   : Cli.Ehlo;
            smtpEhlo      : Cli.MailFrom;
            smtpMailFrom  : Cli.RcptTo;
            smtpRcptTo    : Cli.Data;
            smtpData      : Cli.Quit;
            smtpQuit      : Timer.Enabled := False;
        else
            Timer.Enabled := False;
            LastError := 'Unknown requesttype';
            Cli.Quit;
        end;
    except
        on E: Exception do
        begin
            Timer.Enabled := False;
            LogLine(E.ClassName + ' ' + E.Message);
            Cli.Abort;
            PostThreadMessage(CurThreadID, WM_RESOLVE_NEXT, 0, 0);
        end;
    end;
end;


////////////////////////////////////////////////////////////////////////////////
procedure TMailer.RelayRequestDone(Sender: TObject; RqType: TSmtpRequest; ErrCode: Word);
var
    Cli : TSmtpCli;
begin
    try
        CurCount := 0;
        Cli := TSmtpCli(Sender);
        if (ErrCode <> 0) and Cli.Connected then
        begin
            if RqType = smtpRcptTo then
            begin
                if CurRcpt > 0 then
                begin
                    Smtp.RcptName.Text := RcptList[CurRcpt - 1];
                    Dec(CurRcpt);
                    Cli.RcptTo;
                end
                else if SendFlag then
                    Cli.Data
                else
                    Cli.Quit;
                Exit;
            end;
            CurRcpt   := 0;
            LastError := Cli.HdrTo + ' Rq=' + IntToStr(Ord(Cli.RequestType)) + ' ' + Cli.LastResponse;
            Cli.Quit;
            Exit;
        end
        else if ((RqType <> smtpQuit) and (not Cli.Connected)) then
        begin
            if ErrCode > 10000 then
                LastError := Cli.HdrTo + ' Rq=' + IntToStr(Ord(Cli.RequestType)) + ' ' + GetWinsockErr(ErrCode)
            else
                LastError := Cli.HdrTo + ' Rq=' + IntToStr(Ord(Cli.RequestType)) + ' ' + Cli.LastResponse;
            CurRcpt   := 0;
            Timer.Enabled := False;
            PostThreadMessage(CurThreadID, WM_QUIT, 0, 0);
            Exit;
        end;

        case RqType of
            smtpConnect   : Cli.Ehlo;
            smtpEhlo      : Cli.Auth;
            smtpAuth      : Cli.MailFrom;
            smtpMailFrom  : if CurRcpt > 0 then
                            begin
                                Cli.RcptName.Text := RcptList[CurRcpt - 1];
                                Cli.RcptTo;
                            end;
            smtpRcptTo    : begin
                                if Cli.HdrTo <> '' then
                                    Cli.HdrTo := Cli.HdrTo + ';' + RcptList[CurRcpt - 1]
                                else
                                    Cli.HdrTo := RcptList[CurRcpt - 1];
                                Dec(CurRcpt);
                                SendFlag := TRUE;
                                if CurRcpt > 0 then
                                begin
                                    Cli.RcptName.Text := RcptList[CurRcpt - 1];
                                    Cli.RcptTo;
                                end
                                else
                                    Cli.Data;
                            end;
            smtpData      : Cli.Quit;
            smtpQuit      : Timer.Enabled := False;
        else
            Timer.Enabled := False;
            CurRcpt       := 0;
            LastError     := 'Unknown request type';
            Cli.Quit;
        end;
    except
        on E: Exception do
        begin
            LogLine(E.ClassName + ' ' + E.Message);
            PostThreadMessage(CurThreadID, WM_QUIT, 0, 0);
        end;
    end;
end;


////////////////////////////////////////////////////////////////////////////////
procedure TMailer.SmtpSessionClosed(Sender: TObject; ErrCode: Word);
begin
    Timer.Enabled := False;
    if not UseRelay then
        PostThreadMessage(CurThreadID, WM_RESOLVE_NEXT, 0, 0)
    else
        PostThreadMessage(CurThreadID, WM_QUIT, 0, 0);
end;


////////////////////////////////////////////////////////////////////////////////
procedure TMailer.SendNextMail;
begin
    CurState := csSmtp;
    if not Assigned(Smtp) then
        Smtp := TSmtpCli.Create(Self);
    if Host = '' then
        raise Exception.Create('Host name empty');
    Smtp.Host             := Host;
    Smtp.LocalAddr        := LocalAddr;
    Smtp.FromName         := FromEmail;
    Smtp.HdrFrom          := '<' + Smtp.FromName + '>';
    Smtp.HdrSubject       := Format(Subject, [CurRev]);
    Smtp.HdrReturnPath    := '<' + HdrReturnPath + '>';
    Smtp.SignOn           := HeloMsg;
    Smtp.Allow8bitChars   := FALSE;
    Smtp.WrapMessageText  := TRUE;
    Smtp.FoldHeaders      := TRUE;
    Smtp.MailMessage.Assign(ChangeLog);
    if UseRelay then
    begin
        Smtp.AuthType := smtpauthAutoSelect;
        Smtp.Port     := Port;
        Smtp.Username := User;
        Smtp.Password := Password;
    end
    else begin
        //Smtp.Port     := 'smtp';
        Smtp.AuthType := smtpauthNone;
        Smtp.HdrTo    := RcptList[CurRcpt - 1];
        Smtp.RcptName.Text := RcptList[CurRcpt -1];
        Dec(CurRcpt);
    end;
    Smtp.OnSessionClosed := SmtpSessionClosed;
    if not UseRelay then
        Smtp.OnRequestDone := DirectRequestDone
    else
        Smtp.OnRequestDone := RelayRequestDone;
    SendFlag := FALSE;

    if not Assigned(Timer) then
        Timer := TIcsTimer.Create(Self);
    Timer.OnTimer  := OnTimer;
    Timer.Interval := 2000;
    CurCount := 0;

    Smtp.Connect;

    Timer.Enabled := TRUE;
end;


////////////////////////////////////////////////////////////////////////////////
procedure TMailer.OnTimer(Sender: TObject);
begin
    Inc(CurCount);
    if CurState = csSmtp then
    begin
        if CurCount * Integer(Timer.Interval) >= 30 * 1000 then
        begin
            Timer.Enabled := False;
            CurCount := 0;
            LogLine('Smtp timeout');
            if not UseRelay then
            begin
                if Assigned(Smtp) then
                begin
                    Smtp.OnRequestDone := nil;
                    Smtp.Abort;
                end;
                PostThreadMessage(CurThreadID, WM_RESOLVE_NEXT, 0, 0);
            end
            else
                PostThreadMessage(CurThreadID, WM_QUIT, 0, 0);
        end;
    end
    else begin
        if CurCount * Integer(Timer.Interval) >= 10 * 1000 then
        begin
            Timer.Enabled := False;
            CurCount := 0;

            if CurRcpt > 0 then
                LogLine('Timeout getting MX ' + RcptList[CurRcpt - 1])
            else
                LogLine('Timeout getting MX');
            Dec(CurRcpt);
            if Assigned(Dns) then
                Dns.OnRequestDone := nil;
            PostThreadMessage(CurThreadID, WM_RESOLVE_NEXT, 0, 0);
        end;
    end;
end;


////////////////////////////////////////////////////////////////////////////////
procedure TMailer.DnsQueryRequestDone(Sender: TObject; ErrCode: Word);
var
    QDns   : TDnsQuery;
    nIndex : Integer;
begin
    QDns := TDnsQuery(Sender);
    // Ignore old request
    if QDns.ResponseID <> CurrentID then
        Exit;
    // Ignore empty reply
    if QDns.ResponseANCount < 1 then
        Exit;
    Timer.Enabled := FALSE;
    CurCount := 0;
    nIndex := QDns.AnswerTag[0];
    Host := QDns.MXExchange[nIndex];
    QDns.OnRequestDone := nil;
    if Host = '' then
    begin
        Dec(CurRcpt);
        PostThreadMessage(CurThreadID, WM_RESOLVE_NEXT, 0, 0);
    end
    else
        PostThreadMessage(CurThreadID, WM_NEXT_MAIL, 0, 0);
end;


////////////////////////////////////////////////////////////////////////////////
procedure TMailer.ResolveNext;
var
    Domain : String;
begin
    CurState := csGetMx;
    if CurRcpt <= 0 then
    begin
        PostThreadMessage(CurThreadID, WM_QUIT, 0, 0);
        Exit;
    end;
    Domain := ExtractDomain(RcptList[CurRcpt -1]);
    if Domain = '' then
    begin
        Dec(CurRcpt);
        PostThreadMessage(CurThreadID, WM_RESOLVE_NEXT, 0, 0);
        Exit;
    end;
    if not Assigned(Dns) then
        Dns := TDnsQuery.Create(Self);

    Dns.OnRequestDone := DnsQueryRequestDone;

    if not Assigned(Timer) then
        Timer := TIcsTimer.Create(Self);
    Timer.OnTimer  := OnTimer;
    Timer.Interval := 2000;

    Host     := '';
    CurCount := 0;
    Dns.Addr := DnsServers[0];
    CurrentID := Dns.MXLookup(Domain);
    Timer.Enabled := TRUE;
end;


////////////////////////////////////////////////////////////////////////////////
function TMailer.GetChangeLog: Boolean;
var
    S1, S2 : String;
begin
    Result := FALSE;
    if not Assigned(ChangeLog) then
        ChangeLog := TStringList.Create;
    S1 := '"' + IncludeTrailingPathDelimiter(PathToSvnBin) + 'svnlook.exe" ';
    S2 := S1 + 'author -r ' + CurRev + ' "' + CurRepoPath + '"';
    RunProc(S2, ChangeLog);
    if ChangeLog.Count > 0 then
        ChangeLog[0] := 'Author: ' + ChangeLog[0]
    else
        Exit;
    S2 := S1 + 'log "' + CurRepoPath + '" -r ' + CurRev;
    RunProc(S2, ChangeLog);
    if ChangeLog.Count > 1 then
        ChangeLog[1] := 'Log: ' + ChangeLog[1];

    ChangeLog.Add(#13#10 + 'Files:');
    S2 := S1 + 'changed "' + CurRepoPath + '" -r ' + CurRev;
    RunProc(S2, ChangeLog);
    Result := ChangeLog.Count > 2;
end;


////////////////////////////////////////////////////////////////////////////////
procedure TMailer.PumpMessages;
var
    Msg : TMsg;
begin
    while GetMessage(Msg, 0, 0, 0) do
    begin
        if Msg.hwnd = 0 then
        begin
            case Msg.message of
                WM_RESOLVE_NEXT : ResolveNext;
                WM_NEXT_MAIL    : SendNextMail;
            else
                TranslateMessage(Msg);
                DispatchMessage(Msg);
            end;
        end
        else begin
            TranslateMessage(Msg);
            DispatchMessage(Msg);
        end;
    end;
end;


////////////////////////////////////////////////////////////////////////////////
procedure TMailer.Run;
begin
    if not ReadIni then
    begin
        LastError := 'Could not read INI';
        Exit;
    end;
    if RcptList.Count = 0 then
    begin
        LastError := 'No recipients';
        Exit;
    end;
    if not GetChangeLog then
    begin
        LastError := 'Could not get change log';
        Exit;
    end;
    CurRcpt := RcptList.Count;
    if not UseRelay then
    begin
        Get_DNS_Servers(DnsServers);
        if DnsServers.Count = 0 then
        begin
            LastError := 'DNS server not found';
            Exit;
        end;
        ResolveNext;
        PumpMessages;
    end
    else begin
        SendNextMail;
        PumpMessages;
    end;
end;


////////////////////////////////////////////////////////////////////////////////
var
    Mailer : TMailer;
begin
    if ParamCount > 1 then
    begin
        Mailer := TMailer.Create(nil);
        try
            Mailer.CurRepoPath := ParamStr(1);
            Mailer.CurRev := ParamStr(2);
            try
                Mailer.Run;
            except
                on E : Exception do
                begin
                    LogLine(E.ClassName + ' ' + E.Message);
                    Exit;
                end;
            end;
            if Mailer.LastError <> '' then
                LogLine(Mailer.LastError);
        finally
            FreeAndNil(LogStream);
            FreeAndNil(Mailer);
        end;
    end;
end.