Common.pas

   1 {
   2    Copyright (C) 2010-2014 MegaBrutal
   3
   4    This unit is free software: you can redistribute it and/or modify
   5    it under the terms of the GNU Lesser General Public License as published by
   6    the Free Software Foundation, either version 3 of the License, or
   7    (at your option) any later version.
   8
   9    This unit is distributed in the hope that it will be useful,
  10    but WITHOUT ANY WARRANTY; without even the implied warranty of
  11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12    GNU Lesser General Public License for more details.
  13
  14    You should have received a copy of the GNU Lesser General Public License
  15    along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16 }
  17
  18 {
  19    Unit: Common
  20    It holds some common definitions for MgSMTP, and some helper functions.
  21 }
  22
  23
  24 {$MODE DELPHI}
  25
  26 unit Common;
  27
  28 interface
  29 uses Windows, SysUtils, DateUtils, Classes, INIFiles;
  30
  31 type
  32
  33    TStringArray = array of string;
  34    TUnixTimeStamp = longint;
  35
  36
  37    TArgument = record
  38       Option, Value: string;
  39    end;
  40
  41
  42    TArgumentParser = class
  43       constructor Create(RawArguments: TStringArray; AllowedPrefixes: TStringArray = []);
  44       destructor Destroy; override;
  45    private
  46       Arguments: array of TArgument;
  47       procedure ParseArgument(Arg: string; const AllowedPrefixes: TStringArray);
  48    public
  49       function GetArgument(ID: integer): TArgument;
  50       function IsPresent(ArgumentName: string): boolean;
  51       function GetValue(ArgumentName: string; DefValue: string = ''): string;
  52       function ValidateArguments(ValidArguments: TStringArray): integer;
  53    end;
  54
  55
  56    TNamedObject = class
  57       constructor Create(const Name: string; Config: TINIFile; const Section: string);
  58    private
  59       FName: string;
  60       FAliases: TStrings;
  61    public
  62       property Name: string read FName;
  63       property Aliases: TStrings read FAliases;
  64       function IsItYourName(const Name: string): boolean; virtual;
  65    end;
  66
  67
  68    TMainServerConfig = class(TNamedObject)
  69       constructor Create(Config: TINIFile);
  70    private
  71       FPolicies, FMailbox, FRelay, FLog: boolean;
  72       FDatabytes: longint;
  73       {FTimeCorrection: integer;}
  74       FTimeOffset: integer;
  75       FTimeOffsetStr: string;
  76       FListenPorts: TStrings;
  77    public
  78       function GetVersionStr: string;
  79       property ListenPorts: TStrings read FListenPorts;
  80       property Databytes: longint read FDatabytes;
  81       {property TimeCorrection: integer read FTimeCorrection;}
  82       property TimeOffset: integer read FTimeOffset;
  83       property TimeOffsetStr: string read FTimeOffsetStr;
  84       property Policies: boolean read FPolicies;
  85       property Mailbox: boolean read FMailbox;
  86       property Relay: boolean read FRelay;
  87       property Log: boolean read FLog;
  88       property VersionStr: string read GetVersionStr;
  89    end;
  90
  91
  92    TEMailFlags = word;
  93
  94    TEMailProperties = class
  95       constructor Create;
  96    protected
  97       FSize: longint;
  98       FFlags: TEMailFlags;
  99    public
 100       procedure SetSize(Value: longint);
 101       procedure WriteFlags(Value: TEMailFlags);
 102       procedure SetFlag(Flag: TEMailFlags);
 103       function HasFlag(Flag: TEMailFlags): boolean;
 104       property Size: longint read FSize write SetSize;
 105       property Flags: TEMailFlags read FFlags write WriteFlags;
 106    end;
 107
 108
 109    TRecipient = record
 110       Address, RMsg: string;
 111       Data: integer;
 112    end;
 113
 114
 115    TIPNamePair = class
 116       constructor Create(const Name, IP: string);
 117    protected
 118       FName, FIP: string;
 119    public
 120       property Name: string read FName;
 121       property IP: string read FIP;
 122       function Copy: TIPNamePair;
 123    end;
 124
 125
 126    TEnvelope = class
 127       constructor Create;
 128       destructor Destroy; override;
 129    private
 130       FReturnPath, FRelayHost: string;
 131       FReturnPathSpecified: boolean;
 132       FRecipients: array of TRecipient;
 133    public
 134       function GetNumberOfRecipients: integer;
 135       function GetRecipient(Index: integer): TRecipient;
 136       function IsComplete: boolean;
 137       procedure AddRecipient(Address: string; Data: integer = 0; RMsg: string = ''); overload;
 138       procedure AddRecipient(Recipient: TRecipient); overload;
 139       procedure SetReturnPath(Address: string);
 140       procedure SetRecipientData(Index, Data: integer; RMsg: string = '');
 141       procedure SetRelayHost(HostName: string);
 142       property ReturnPath: string read FReturnPath write SetReturnPath;
 143       property RelayHost: string read FRelayHost write SetRelayHost;
 144    end;
 145
 146
 147    TEnvelopeArray = array of TEnvelope;
 148
 149
 150    function EMailUserName(EMail: string): string;
 151    function EMailHost(EMail: string): string;
 152    function CleanEMailAddress(EMail: string): string;
 153    function IsValidEMailAddress(EMail: string): boolean;
 154    function EMailTimeStamp(DateTime: TDateTime): string;
 155    function EMailTimeStampCorrected(DateTime: TDateTime): string;
 156    function StatusToStr(Status: integer): string;
 157    procedure AssignDeliveryStatusToSMTPCodes(Envelope: TEnvelope);
 158
 159    function CleanEOLN(S: string): string;
 160    function GenerateRandomString(Length: integer): string;
 161    function GetAlphabetStr: string;
 162    function GetServiceCodeStr(Ctrl: dword): string;
 163    function GetWinMajorVersion: longword;
 164    function IsPrintableString(S: string): boolean;
 165    function UnixTimeStamp(DateTime: TDateTime): TUnixTimeStamp;
 166    function CmdlineToStringArray: TStringArray;
 167    procedure SplitParameters(S: string; var FirstPrm, Remainder: string; Separator: char = #32);
 168
 169    function ReadLineFromStream(Stream: TStream): string;
 170    function WriteLineToStream(Stream: TStream; Line: string): boolean;
 171
 172
 173 const
 174
 175    { MgSMTP version: }
 176    VERSION_STR       = '0.9s';
 177
 178    { Architecture: }
 179 {$IFDEF CPU64}
 180    PLATFORM_BITS     =  64;
 181 {$ELSE}
 182 {$IFDEF CPU32}
 183    PLATFORM_BITS     =  32;
 184 {$ENDIF}
 185 {$ENDIF}
 186
 187    { Delivery statuses: }
 188    DS_DELIVERED      = 1 shl 10;
 189    DS_DELAYED        = 1 shl 11;
 190    DS_PERMANENT      = 1 shl 12;
 191    DS_INTERNALFAIL   = 1 shl 13;
 192    DS_CONNECTIONFAIL = 1 shl 14;
 193    DS_UNEXPECTEDFAIL = 1 shl 15;
 194    DS_SMTPFAIL       = 1 shl 16;
 195    DS_SMTPREPLYMASK  = $000003FF;
 196    DS_ALLFLAGS       = $FFFFFFFF;
 197
 198    { E-mail property flags: }
 199    EF_8BITMIME       =   1;
 200
 201    DayNames: array[1..7] of shortstring = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
 202    MonthNames: array[1..12] of shortstring = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
 203       'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
 204
 205    { Support for PRESHUTDOWN is not yet present in the Free Pascal library,
 206      therefore I define the necessary constants here. It's a temporary
 207      solution, I hope I won't need it for the next release of FPC. }
 208    SERVICE_ACCEPT_PRESHUTDOWN  = $00000100;
 209    SERVICE_CONTROL_PRESHUTDOWN = $0000000F;
 210
 211
 212 var
 213
 214    MainServerConfig: TMainServerConfig;
 215
 216
 217 implementation
 218
 219
 220 { Unit-private functions/prodecures: }
 221
 222 function MakeTimeOffsetStr(TimeOffset: integer): string;
 223 var CorrS: string; CorrI: integer;
 224 begin
 225    CorrI:= TimeOffset;
 226    CorrS:= IntToStr(Abs(CorrI));
 227    while Length(CorrS) < 4 do CorrS:= '0' + CorrS;
 228    if CorrI >= 0 then CorrS:= '+' + CorrS else CorrS:= '-' + CorrS;
 229    Result:= CorrS;
 230 end;
 231
 232
 233 { Unit-public functions/procedures: }
 234
 235 function EMailUserName(EMail: string): string;
 236 var p: integer;
 237 begin
 238    p:= Length(EMail);
 239    while (p > 0) and (EMail[p] <> '@') do Dec(p);
 240    if p <> 0 then begin
 241       Result:= Copy(EMail, 1, p - 1);
 242    end
 243    else Result:= EMail;
 244 end;
 245
 246 function EMailHost(EMail: string): string;
 247 var p: integer;
 248 begin
 249    p:= Length(EMail);
 250    while (p > 0) and (EMail[p] <> '@') do Dec(p);
 251    if (p <> 0) and (p < Length(EMail)) then begin
 252       Result:= Copy(EMail, p + 1, Length(EMail) - p);
 253    end
 254    else Result:= '';
 255 end;
 256
 257 function CleanEMailAddress(EMail: string): string;
 258 var po, pc, p: integer;
 259 begin
 260    po:= Pos('<', EMail);
 261    pc:= Pos('>', EMail);
 262    if (po <> 0) and (pc <> 0) and (po < pc) then begin
 263       Result:= Copy(EMail, po + 1, pc - po - 1);
 264       p:= Pos(':', Result);
 265       if p <> 0 then
 266          Result:= Copy(Result, p + 1, Length(Result) - p);
 267    end
 268    else
 269       Result:= EMail;
 270 end;
 271
 272 function IsValidEMailAddress(EMail: string): boolean;
 273 begin
 274    { !!! TODO: Implement more strict checking later !!! }
 275    Result:= Pos('@', EMail) <> 0;
 276 end;
 277
 278 function EMailTimeStamp(DateTime: TDateTime): string;
 279 var Year, Month, Day: word;
 280 begin
 281    DecodeDate(DateTime, Year, Month, Day);
 282    Result:= DayNames[DayOfWeek(DateTime)] + ' ' + MonthNames[Month] + ' '
 283       + FormatDateTime('dd hh:nn:ss', DateTime) + ' ' + IntToStr(Year);
 284 end;
 285
 286 function EMailTimeStampCorrected(DateTime: TDateTime): string;
 287 begin
 288    Result:= EMailTimeStamp(DateTime) + ' ' + MainServerConfig.TimeOffsetStr;
 289 end;
 290
 291 function StatusToStr(Status: integer): string;
 292 { Returns the delivery status code in human-readable format. }
 293 begin
 294    Result:= IntToStr(Status and (DS_ALLFLAGS - DS_SMTPREPLYMASK - DS_SMTPFAIL))
 295       + '+' + IntToStr(Status and DS_SMTPREPLYMASK);
 296 end;
 297
 298 procedure AssignDeliveryStatusToSMTPCodes(Envelope: TEnvelope);
 299 var i, code, cond, status: integer; Recipient: TRecipient;
 300 begin
 301    for i:= 0 to Envelope.GetNumberOfRecipients - 1 do begin
 302       Recipient:= Envelope.GetRecipient(i);
 303       code:= Recipient.Data and DS_SMTPREPLYMASK;
 304       cond:= code div 100;
 305       case cond of
 306          0: status:= DS_DELAYED or DS_UNEXPECTEDFAIL;
 307          2: status:= DS_DELIVERED;
 308          4: status:= DS_DELAYED;
 309          5: status:= DS_PERMANENT;
 310          else status:= DS_PERMANENT or DS_UNEXPECTEDFAIL;
 311       end;
 312       if code <> 0 then status:= status or DS_SMTPFAIL;
 313       Envelope.SetRecipientData(i, code or status, Recipient.RMsg);
 314    end;
 315 end;
 316
 317
 318 function CleanEOLN(S: string): string;
 319 begin
 320    while (Length(S) <> 0) and (S[Length(S)] in [#13, #10]) do Delete(S, Length(S), 1);
 321    Result:= S;
 322 end;
 323
 324 function GenerateRandomString(Length: integer): string;
 325 var What, Chrn, i: integer; Value: string;
 326 begin
 327    Value:= '';
 328    for i:= 1 to Length do begin
 329      What:= Random(3);
 330      case What of
 331      0: begin Chrn:= Random(10)+48; Value:= Value + Chr(Chrn); end;
 332      1: begin Chrn:= Random(26)+65; Value:= Value + Chr(Chrn); end;
 333      2: begin Chrn:= Random(26)+97; Value:= Value + Chr(Chrn); end;
 334      end;
 335    end;
 336    Result:= Value;
 337 end;
 338
 339 function GetAlphabetStr: string;
 340 var i: byte;
 341 begin
 342    Result:= '';
 343    for i:= Ord('0') to Ord('9') do Result:= Result + Chr(i);
 344    for i:= Ord('A') to Ord('Z') do Result:= Result + Chr(i);
 345 end;
 346
 347 function GetServiceCodeStr(Ctrl: dword): string;
 348 begin
 349    case Ctrl of
 350    SERVICE_CONTROL_STOP:         Result:= 'STOP';
 351    SERVICE_CONTROL_SHUTDOWN:     Result:= 'SHUTDOWN';
 352    SERVICE_CONTROL_PRESHUTDOWN:  Result:= 'PRESHUTDOWN';
 353    else                          Result:= IntToStr(Ctrl);
 354    end;
 355 end;
 356
 357 function GetWinMajorVersion: longword;
 358 var OSVersionInfo: TOSVersionInfo;
 359 begin
 360    { Get OS version info. }
 361    OSVersionInfo.dwOSVersionInfoSize:= SizeOf(TOSVersionInfo);
 362    GetVersionEx(OSVersionInfo);
 363    Result:= OSVersionInfo.dwMajorVersion;
 364 end;
 365
 366 function IsPrintableString(S: string): boolean;
 367 { Check if string contains only printable ASCII characters. }
 368 var i: integer;
 369 begin
 370    i:= 1;
 371    Result:= true;
 372    while Result and (i <= Length(S)) do begin
 373       Result:= (Ord(S[i]) > 31) and (Ord(S[i]) < 127);
 374       Inc(i);
 375    end;
 376 end;
 377
 378 procedure SplitParameters(S: string; var FirstPrm, Remainder: string; Separator: char = #32);
 379 var i: integer;
 380 begin
 381    i:= pos(Separator, S);
 382    if i > 0 then begin
 383       FirstPrm:= Copy(S, 1, i - 1);
 384       Remainder:= Copy(S, i + 1, Length(S) - i);
 385    end
 386    else begin
 387       FirstPrm:= S;
 388       Remainder:= '';
 389    end;
 390 end;
 391
 392 function UnixTimeStamp(DateTime: TDateTime): TUnixTimeStamp;
 393 begin
 394    {Result:= Trunc((DateTime - EncodeDate(1970, 1 ,1)) * 24 * 60 * 60);}
 395    Result:= DateTimeToUnix(DateTime);
 396 end;
 397
 398
 399 function ReadLineFromStream(Stream: TStream): string;
 400 var S: string; B: char;
 401 begin
 402    S:= '';
 403    try
 404       repeat
 405          B:= Char(Stream.ReadByte);
 406          if not (B in [#10, #13]) then S:= S + B;
 407       until (B = #10);
 408    finally
 409       Result:= S;
 410    end;
 411 end;
 412
 413 function WriteLineToStream(Stream: TStream; Line: string): boolean;
 414 const EOLN = #13#10;
 415 begin
 416    Result:= true;
 417    Line:= Line + EOLN;
 418    try
 419       Stream.WriteBuffer(PChar(Line)^, Length(Line));
 420    except
 421       Result:= false;
 422    end;
 423 end;
 424
 425
 426 { Object constructors/destructors: }
 427
 428 constructor TArgumentParser.Create(RawArguments: TStringArray; AllowedPrefixes: TStringArray = []);
 429 var i: integer;
 430 begin
 431    for i:= 0 to Length(RawArguments) - 1 do
 432       ParseArgument(RawArguments[i], AllowedPrefixes);
 433 end;
 434
 435 destructor TArgumentParser.Destroy;
 436 begin
 437    SetLength(Arguments, 0);
 438 end;
 439
 440 constructor TNamedObject.Create(const Name: string; Config: TINIFile; const Section: string);
 441 begin
 442    inherited Create;
 443    FName:= Name;
 444    FAliases:= TStringList.Create;
 445    FAliases.Delimiter:= ',';
 446    FAliases.DelimitedText:= FName + ',' + Config.ReadString(Section, 'Alias', '');
 447 end;
 448
 449 constructor TMainServerConfig.Create(Config: TINIFile);
 450 begin
 451    inherited Create(Config.ReadString('Server', 'Name', ''), Config, 'Server');
 452    FListenPorts:= TStringList.Create;
 453    FListenPorts.Delimiter:= ',';
 454    FListenPorts.DelimitedText:= Config.ReadString('Server', 'ListenPort', '25');
 455
 456    FDatabytes:=      Config.ReadInteger('Server', 'Databytes', 1024 * 1024 * 1024);
 457    {FTimeCorrection:= Config.ReadInteger('Server', 'TimeCorrection', 0);}
 458    FTimeOffset:=     Config.ReadInteger('Server', 'TimeOffset', Config.ReadInteger('Server', 'TimeCorrection', 0) * 100);
 459    FTimeOffsetStr:=  MakeTimeOffsetStr(FTimeOffset);
 460
 461    FPolicies:=  Config.ReadBool('Server', 'Policies',  false);
 462    FMailbox:=   Config.ReadBool('Server', 'Mailbox',   false);
 463    FRelay:=     Config.ReadBool('Server', 'Relay',     false);
 464    FLog:=       Config.ReadBool('Server', 'Log',       false);
 465 end;
 466
 467 constructor TEMailProperties.Create;
 468 begin
 469    inherited Create;
 470    SetSize(0);
 471    WriteFlags(0);
 472 end;
 473
 474 constructor TIPNamePair.Create(const Name, IP: string);
 475 begin
 476    FName:= Name;
 477    FIP:= IP;
 478 end;
 479
 480 constructor TEnvelope.Create;
 481 begin
 482    inherited Create;
 483    FReturnPath:= '';
 484    FReturnPathSpecified:= false;
 485    FRelayHost:= '';
 486    SetLength(FRecipients, 0);
 487 end;
 488
 489 destructor TEnvelope.Destroy;
 490 begin
 491    SetLength(FRecipients, 0);
 492    inherited Destroy;
 493 end;
 494
 495
 496 { Object methods: }
 497
 498 procedure TArgumentParser.ParseArgument(Arg: string; const AllowedPrefixes: TStringArray);
 499 var i, n: integer; found: boolean;
 500 begin
 501    { Strip prefix if present. }
 502    i:= 0; found:= false;
 503    while ((i < Length(AllowedPrefixes)) and (not found)) do begin
 504       if pos(AllowedPrefixes[i], Arg) = 1 then
 505       begin
 506          Delete(Arg, 1, Length(AllowedPrefixes[i]));
 507          found:= true;
 508       end;
 509       Inc(i);
 510    end;
 511
 512    n:= Length(Arguments);
 513    SetLength(Arguments, n + 1);
 514    SplitParameters(Arg, Arguments[n].Option, Arguments[n].Value, '=');
 515    { To be case-insensitive: }
 516    Arguments[n].Option:= UpCase(Arguments[n].Option);
 517 end;
 518
 519 function TArgumentParser.GetArgument(ID: integer): TArgument;
 520 begin
 521    { No index checking... you'd better use it return value of ValidateArguments. }
 522    Result:= Arguments[ID];
 523 end;
 524
 525 function TArgumentParser.IsPresent(ArgumentName: string): boolean;
 526 var i: integer;
 527 begin
 528    i:= 0;
 529    while (i < Length(Arguments)) and (Arguments[i].Option <> UpCase(ArgumentName)) do
 530       Inc(i);
 531    Result:= i < Length(Arguments);
 532 end;
 533
 534 function TArgumentParser.GetValue(ArgumentName: string; DefValue: string = ''): string;
 535 var i: integer;
 536 begin
 537    i:= 0;
 538    while (i < Length(Arguments)) and (Arguments[i].Option <> UpCase(ArgumentName)) do
 539       Inc(i);
 540
 541    if i < Length(Arguments) then begin
 542       if Arguments[i].Value <> '' then
 543          Result:= Arguments[i].Value
 544       else
 545          Result:= DefValue;
 546    end
 547    else
 548       Result:= DefValue;
 549 end;
 550
 551 function TArgumentParser.ValidateArguments(ValidArguments: TStringArray): integer;
 552 { Returns -1 if all arguments are valid. Otherwise, returns the ID of the first
 553   invalid parameter. }
 554 var i: integer;
 555 begin
 556    i:= 0;
 557    while (i < Length(Arguments)) and (Arguments[i] in ValidArguments) do
 558       Inc(i);
 559
 560    if i < Length(Arguments) then
 561       Result:= -1
 562    else
 563       Result:= i;
 564 end;
 565
 566
 567 function TNamedObject.IsItYourName(const Name: string): boolean;
 568 begin
 569    Result:= FAliases.IndexOf(Name) <> -1;
 570 end;
 571
 572
 573 function TMainServerConfig.GetVersionStr: string;
 574 begin
 575    Result:= VERSION_STR;
 576 end;
 577
 578
 579 function TIPNamePair.Copy: TIPNamePair;
 580 begin
 581    Result:= TIPNamePair.Create(Name, IP);
 582 end;
 583
 584
 585 procedure TEMailProperties.SetSize(Value: longint);
 586 begin
 587    FSize:= Value;
 588 end;
 589
 590 procedure TEMailProperties.WriteFlags(Value: TEMailFlags);
 591 begin
 592    FFlags:= Value;
 593 end;
 594
 595 procedure TEMailProperties.SetFlag(Flag: TEMailFlags);
 596 begin
 597    FFlags:= FFlags or Flag;
 598 end;
 599
 600 function TEMailProperties.HasFlag(Flag: TEMailFlags): boolean;
 601 begin
 602    Result:= (FFlags and Flag) = Flag;
 603 end;
 604
 605
 606 function TEnvelope.GetNumberOfRecipients: integer;
 607 begin
 608    Result:= Length(FRecipients);
 609 end;
 610
 611 function TEnvelope.GetRecipient(Index: integer): TRecipient;
 612 begin
 613    Result:= FRecipients[Index];
 614 end;
 615
 616 function TEnvelope.IsComplete: boolean;
 617 begin
 618    Result:= FReturnPathSpecified and (Length(FRecipients) > 0);
 619 end;
 620
 621 procedure TEnvelope.AddRecipient(Address: string; Data: integer = 0; RMsg: string = '');
 622 var i: integer;
 623 begin
 624    i:= Length(FRecipients);
 625    SetLength(FRecipients, i + 1);
 626    FRecipients[i].Address:= Address;
 627    FRecipients[i].RMsg:= RMsg;
 628    FRecipients[i].Data:= Data;
 629 end;
 630
 631 procedure TEnvelope.AddRecipient(Recipient: TRecipient);
 632 var i: integer;
 633 begin
 634    i:= Length(FRecipients);
 635    SetLength(FRecipients, i + 1);
 636    FRecipients[i]:= Recipient;
 637 end;
 638
 639 procedure TEnvelope.SetRecipientData(Index, Data: integer; RMsg: string = '');
 640 begin
 641    FRecipients[Index].RMsg:= RMsg;
 642    FRecipients[Index].Data:= Data;
 643 end;
 644
 645 procedure TEnvelope.SetReturnPath(Address: string);
 646 begin
 647    FReturnPath:= Address;
 648    FReturnPathSpecified:= true;
 649 end;
 650
 651 procedure TEnvelope.SetRelayHost(HostName: string);
 652 begin
 653    FRelayHost:= HostName;
 654 end;
 655
 656
 657 end.