(* Rev 1.30 20/12/04 C Wilson - Re-written, based on previous Indy 8, 9 & 10 code Note to users: When using this component you must handle at least the following events: OnArticleByNo OnBodyByNo OnCheckMsgId OnCheckMsgNo OnHeadByNo OnListGroups OnNextArticle OnPrevArticle OnSelectGroup Unless your server is some sort of dumb message repository you will also need to handle 'OnPost' to support posts. RFC 977 implies that you can retrieve a message by id - even if no group is selected. To support this, handle the following: OnArticleById OnBodyById OnHeadById For full RFC 977 compliance, handle the following: OnListNewGroups OnNewNews It is highly recommended that you handle the XOVER command described in RFC 2980 and nntpext. If you don't everyone will laugh at your server! OnXOver Additionally, the TidNNTPServer component supports the following common extensions: LIST EXTENSIONS is automatically supported. XHDR is supported if you implement the OnXHdrByRange event. Additionally implement OnXHdrById to support XHDR by message ID when no group is selected. LISTGROUP is supported if you provid an OnListGroup handler. OVER is supported as an alias for XOVER HDR is supported as an alias for XHDR - except it returns a 225 success response instead of XHDRs 221 The new OnCheckMsgRange allows the TidNNTPServer comopnent to respond to XOVER and XHDR empty range with a 423 response, as suggested in nntpext. If you don't handle this, it's no big deal. Your server will simply respond with an empty list - which is what many servers do anyway. Support for HELP is provided automatically. However you can override the help text by filling in the Help property at design time. Default values for LIST Overview.fmt are provided. Note that RFC 2980 strongly recommends that you add XRef:full to the default list. The following have been fixed in this version: * Reinstated missing OnHeadById, OnBodyById & OnArticleById * Reinstated missing OnCheckMsgId * Added OnCheckMsgRange for XOVER and XHDR support * Removed OnCheckListGroup. ListGroup now relies on OnSelectGroup to check & select the group * Removed OnIHavePost. IHave now uses the regular 'OnPost' event * Removed OnStatMsgNo. Stat is now handled by OnCheckMsgNo and OnCheckMsgId * Fixed mixup where the LAST command called OnNextAtricle instead of OnPrevArticle * Added missing default 437 response for IHave * STAT, HEAD, ATICLE & BODY now return the correct specific 22x response * Corrected SLAVE response to 202 * Added new 'Reauthenticate' method to the TidNNTPContext class * Added new 'Posting Allowed' property to TidNNTPServer * Worked round bug in command handlers where the wrong text is displayed if the NumericCode value is set. * Corrected NEWNEWS default response * Fixed numerous glitches where the RFCs weren't implemented correctly Previous versions: Rev 1.29 5/16/04 5:22:54 PM RLebeau Added try...finally to CommandPost() Rev 1.28 3/1/2004 1:02:58 PM JPMugaas Fixed for new code. Rev 1.27 2004.02.03 5:44:10 PM czhower Name changes Rev 1.26 1/21/2004 3:26:58 PM JPMugaas InitComponent Rev 1.25 1/1/04 1:22:04 AM RLebeau Bug fix for parameter parsing in CommandNewNews() that was testing the ASender.Params.Count incorrectly. Rev 1.24 2003.10.21 9:13:12 PM czhower Now compiles. Rev 1.23 10/19/2003 5:39:52 PM DSiders Added localization comments. Rev 1.22 2003.10.18 9:42:10 PM czhower Boatload of bug fixes to command handlers. Rev 1.21 2003.10.12 4:04:02 PM czhower compile todos Rev 1.20 9/19/2003 03:30:10 PM JPMugaas Now should compile again. Rev 1.19 9/17/2003 10:41:56 PM PIonescu Fixed small mem leak in CommandPost Rev 1.18 8/6/2003 6:13:50 PM SPerry Message-ID Integer - > string Rev 1.17 8/2/2003 03:53:00 AM JPMugaas Unit needed to be added to uses clause. Rev 1.16 8/1/2003 8:21:38 PM SPerry Rev 1.13 5/26/2003 04:28:02 PM JPMugaas Rev 1.12 5/26/2003 12:23:48 PM JPMugaas Rev 1.11 5/25/2003 03:50:48 AM JPMugaas Rev 1.10 5/21/2003 2:25:04 PM BGooijen Rev 1.9 3/26/2003 04:18:26 PM JPMugaas Rev 1.7 3/17/2003 08:55:52 AM JPMugaas Rev 1.6 3/16/2003 08:30:24 AM JPMugaas Rev 1.5 1/20/2003 1:15:34 PM BGooijen Rev 1.4 1/17/2003 07:10:40 PM JPMugaas Rev 1.3 1/9/2003 06:09:28 AM JPMugaas Rev 1.2 1/8/2003 05:53:38 PM JPMugaas Rev 1.1 12/7/2002 06:43:14 PM JPMugaas Rev 1.0 11/13/2002 07:58:00 AM JPMugaas July 2002 -Kudzu - Fixes to Authorization and other parts Oct/Nov 2001 -Kudzu - Rebuild from scratch for proper use of command handlers and around new architecture. 2001-Jul-31 Jim Gunkel Reorganized for command handlers 2001-Jun-28 Pete Mee Begun transformation to TIdCommandHandler 2000-Apr-22 Mark L. Holmes Ported to Indy 2000-Mar-27 Final Version 2000-Jan-13 MTL Moved to new Palette Scheme (Winshoes Servers) Original Author: Ozz Nixon (Winshoes 7) *) unit IdNNTPServerX; interface (* For more information on NNTP visit http://www.faqs.org/rfcs/ NNTP Extensions charter (nntpext) - http://www.ietf.org/html.charters/nntpext-charter.html RFC 977 - A Proposed Standard for the Stream-Based Transmission of News RFC 2980 - Common NNTP Extensions RFC 1036 - Standard for Interchange of USENET Messages RFC 822 - Standard for the Format of ARPA Internet Text *) uses Classes, SysUtils, IdAssignedNumbers, IdException, IdSSL, IdServerIOHandler, IdTCPServer, IdYarn, IdContext, IdTCPConnection, IdCommandHandlers, IdExplicitTLSClientServerBase, IdReply; const DEF_NNTP_IMPLICIT_TLS = False; type EIdNNTPServerException = class(EIdException); EIdNNTPImplicitTLSRequiresSSL = class(EIdNNTPServerException); TIdNNTPContext = class(TIdContext) protected FCurrentArticle: Integer; FCurrentGroup: string; FUserName: string; FPassword: string; FAuthenticated : Boolean; FModeReader: Boolean; fReauthenticate : boolean; function GetUsingTLS:boolean; public constructor Create( AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil ); override; procedure Reauthenticate; property CurrentArticle: Integer read FCurrentArticle; property CurrentGroup: string read FCurrentGroup; property ModeReader: Boolean read FModeReader; property UserName: string read FUserName; property Password: string read FPassword; property Authenticated: Boolean read FAuthenticated; property UsingTLS : boolean read GetUsingTLS; end; TIdNNTPAuthType = (atUserPass, atSimple, atGeneric); TIdNNTPAuthTypes = set of TIdNNTPAuthType; TIdNNTPOnAuth = procedure(AThread: TIdNNTPContext; var VAccept: Boolean) of object; TIdNNTPOnNewGroupsList = procedure ( AThread: TIdNNTPContext; const ADateStamp : TDateTime; const ADistributions : String) of object; TIdNNTPOnNewNews = procedure ( AThread: TIdNNTPContext; const Newsgroups : String; const ADateStamp : TDateTime; const ADistributions : String) of object; TIdNNTPOnIHaveCheck = procedure(AThread: TIdNNTPContext; const AMsgID : String; VAccept : Boolean) of object; TIdNNTPOnArticleByNo = procedure(AThread: TIdNNTPContext; const AMsgNo: Integer) of object; TIdNNTPOnArticleByRange = procedure(AThread: TIdNNTPContext; const AMsgNoLo, AMsgNoHi: Integer) of object; TIdNNTPOnArticleByID = procedure(AThread: TIdNNTPContext; const AMsgID: string) of object; TIdNNTPOnXHdrByRange = procedure(AThread: TIdNNTPContext; const AHeader : string; const AMsgNoLo, AMsgNoHi: Integer) of object; TIdNNTPOnXHdrByID = procedure(AThread: TIdNNTPContext; const AHeader, AMsgID: string) of object; TIdNNTPOnCheckMsgNo = procedure(AThread: TIdNNTPContext; const AMsgNo: Integer; var VMsgID: string) of object; TIdNNTPOnCheckMsgRange = procedure(AThread: TIdNNTPContext; const AMsgNoLo, AMsgNoHi: Integer; var VHasMsgs : boolean) of object; TIdNNTPOnCheckMsgId = procedure(AThread: TIdNNTPContext; const VMsgID : string; var AMsgNo : Integer) of object; TIdNNTPOnMovePointer = procedure(AThread: TIdNNTPContext; var AMsgNo: Integer; var VMsgID: string) of object; TIdNNTPOnPost = procedure(AThread: TIdNNTPContext; var VPostOk: Boolean; var VErrorText: string) of object; TIdNNTPOnSelectGroup = procedure(AThread: TIdNNTPContext; const AGroup: string; var VMsgCount: Integer; var VMsgFirst: Integer; var VMsgLast: Integer; var VGroupExists: Boolean) of object; TIdNNTPOnAuthRequired = procedure(AThread: TIdNNTPContext; const ACommand, AParams : string; var VRequired: Boolean) of object; TidNNTPServerX = class(TIdExplicitTLSServer) private FOnAuthRequired: TIdNNTPOnAuthRequired; FOnHeadById: TIdNNTPOnArticleById; FOnBodyById: TIdNNTPOnArticleById; FOnArticleById: TIdNNTPOnArticleById; FOnCheckMsgId: TIdNNTPOnCheckMsgId; fPostingAllowed: boolean; FOnXHdrByRange: TIdNNTPOnXHdrByRange; FOnXHdrById: TIdNNTPOnXHdrById; FOnCheckMsgRange: TIdNNTPOnCheckMsgRange; fSupportedAuthTypes: TidNNTPAuthTypes; FImplicitTLS:boolean; FHelp: TStrings; FOverviewFormat: TStrings; FOnArticleByNo: TIdNNTPOnArticleByNo; FOnBodyByNo: TIdNNTPOnArticleByNo; FOnHeadByNo: TIdNNTPOnArticleByNo; FOnCheckMsgNo: TIdNNTPOnCheckMsgNo; FOnNextArticle : TIdNNTPOnMovePointer; FOnPrevArticle : TIdNNTPOnMovePointer; //LISTGROUP events - Gravity uses these FOnListGroup : TIdServerThreadEvent; FOnListGroups: TIdServerThreadEvent; FOnListNewGroups : TIdNNTPOnNewGroupsList; FOnPost: TIdNNTPOnPost; FOnSelectGroup: TIdNNTPOnSelectGroup; FOnXOver: TIdNNTPOnArticleByRange; FOnNewNews : TIdNNTPOnNewNews; FOnIHaveCheck : TIdNNTPOnIHaveCheck; FOnAuth: TIdNNTPOnAuth; function ParseRangeParams(ASender: TidCommand; var AMsgLo, AMsgHi: Integer): boolean; function CheckIsInGroup(ASender: TidCommand): boolean; procedure DoGetMessageCommand (ASender : TidCommand; responseNo : Integer; needsHandler : boolean; byNoHandler : TIdNNTPOnArticleByNo; byIdHandler : TIdNNTPOnArticleByID); procedure DoGetMessageById(ASender : TIdCommand; responseNo : Integer; msgId: string; needsHandler: Boolean; byNoHandler: TIdNNTPOnArticleByNo; byIdHandler: TIdNNTPOnArticleByID); procedure DoGetMessageByNo(ASender : TidCommand; responseNo : Integer; msgNo: Integer; needsHandler : boolean; byNoHandler: TIdNNTPOnArticleByNo); procedure DoGetMessageByRange (ASender: TidCommand; responseNo : Integer; msgNoLo, msgNoHi: Integer; needsHandler : boolean; byRangeHandler: TIdNNTPOnArticleByRange); procedure DoGetXHdrById(ASender : TIdCommand; responseNo : Integer; const header, msgId: string); procedure DoGetXHdrByRange (ASender: TidCommand; responseNo : Integer; const header : string; msgNoLo, msgNoHi: Integer); function CheckAuthRequisites (ASender : TIdCommand; needsHandler : boolean; handler : pointer) : boolean; function SecLayerOk(ASender : TIdCommand) : Boolean; function AuthOk(ASender: TIdCommand): Boolean; procedure SetHelp(AValue: TStrings); procedure SetOverviewFormat(AValue: TStrings); procedure CommandArticle(ASender: TIdCommand); procedure CommandAuthInfoUser(ASender: TIdCommand); procedure CommandAuthInfoPassword(ASender: TIdCommand); procedure CommandBody(ASender: TIdCommand); procedure CommandDate(ASender: TIdCommand); procedure CommandHead(ASender: TIdCommand); procedure CommandGroup(ASender: TIdCommand); procedure CommandIHave(ASender: TIdCommand); procedure CommandLast(ASender: TIdCommand); procedure CommandList(ASender: TIdCommand); procedure CommandListGroup(ASender: TIdCommand); procedure CommandListExtensions(ASender: TIdCommand); procedure CommandModeReader(ASender: TIdCommand); procedure CommandNewGroups(ASender: TIdCommand); procedure CommandNewNews(ASender: TIdCommand); procedure CommandNext(ASender: TIdCommand); procedure CommandPost(ASender: TIdCommand); procedure CommandSlave(ASender: TIdCommand); procedure CommandStat(ASender: TIdCommand); procedure CommandXHdr(ASender: TIdCommand); procedure CommandXOver(ASender: TIdCommand); procedure CommandSTARTTLS(ASender: TIdCommand); protected function CreateReplyUnknownCommand: TIdReply; override; procedure DoReplyUnknownCommand(AContext: TIdContext; ALine: string); override; procedure InitializeCommandHandlers; override; procedure SetIOHandler(const AValue: TIdServerIOHandler); override; procedure SetImplicitTLS(const AValue: Boolean); procedure InitComponent; override; public destructor Destroy; override; class function NNTPTimeToTime(const ATimeStamp : String): TDateTime; class function NNTPDateTimeToDateTime(const ATimeStamp: string): TDateTime; published property DefaultPort default IdPORT_NNTP; property Help: TStrings read FHelp write SetHelp; property SupportedAuthTypes : TidNNTPAuthTypes read fSupportedAuthTypes write fSupportedAuthTypes; property PostingAllowed : boolean read fPostingAllowed write fPostingAllowed default true; property OnArticleByNo: TIdNNTPOnArticleByNo read FOnArticleByNo write FOnArticleByNo; property OnArticleById: TIdNNTPOnArticleById read FOnArticleById write FOnArticleById; property OnAuth: TIdNNTPOnAuth read FOnAuth write FOnAuth; property OnAuthRequired : TIdNNTPOnAuthRequired read FOnAuthRequired write FOnAuthRequired; property OnBodyByNo: TIdNNTPOnArticleByNo read FOnBodyByNo write FOnBodyByNo; property OnBodyById: TIdNNTPOnArticleById read FOnBodyById write FOnBodyById; property OnHeadByNo: TIdNNTPOnArticleByNo read FOnHeadByNo write FOnHeadByNo; property OnHeadById: TIdNNTPOnArticleById read FOnHeadById write FOnHeadById; property OnCheckMsgNo: TIdNNTPOnCheckMsgNo read FOnCheckMsgNo write FOnCheckMsgNo; property OnCheckMsgRange: TIdNNTPOnCheckMsgRange read FOnCheckMsgRange write FOnCheckMsgRange; property OnCheckMsgId: TIdNNTPOnCheckMsgId read FOnCheckMsgId write FOnCheckMsgId; //You are responsible for writing event handlers for these instead of us incrementing //and decrimenting the pointer. This design permits you to implement article expirity, //cancels, and supersedes property OnNextArticle : TIdNNTPOnMovePointer read FOnNextArticle write FOnNextArticle; property OnPrevArticle : TIdNNTPOnMovePointer read FOnPrevArticle write FOnPrevArticle; property OnListGroups: TIdServerThreadEvent read FOnListGroups write FOnListGroups; property OnListGroup : TIdServerThreadEvent read FOnListGroup write FOnListGroup; property OnListNewGroups : TIdNNTPOnNewGroupsList read FOnListNewGroups write FOnListNewGroups; property OnSelectGroup: TIdNNTPOnSelectGroup read FOnSelectGroup write FOnSelectGroup; property OnPost: TIdNNTPOnPost read FOnPost write FOnPost; property OnXOver: TIdNNTPOnArticleByRange read FOnXOver write FOnXOver; property OverviewFormat: TStrings read FOverviewFormat write SetOverviewFormat; property OnXHdrByRange : TIdNNTPOnXHdrByRange read FOnXHdrByRange write FOnXHdrByRange; property OnXHdrById : TIdNNTPOnXHdrById read FOnXHdrById write FOnXHdrById; property OnNewNews : TIdNNTPOnNewNews read FOnNewNews write FOnNewNews; property OnIHaveCheck : TIdNNTPOnIHaveCheck read FOnIHaveCheck write FOnIHaveCheck; property ImplicitTLS : Boolean read FImplicitTLS write SetImplicitTLS default DEF_NNTP_IMPLICIT_TLS; end; implementation uses idResourceStringsProtocols, IdGlobalProtocols, IdGlobal, IdReplyRFC; resourcestring rstArticleHelpText = 'Return an article''s header and body'; rstBodyHelpText = 'Return an article''s body'; rstGroupHelpText = 'Select the specified group'; rstHeadHelpText = 'Return an article'' header'; rstListHelpText = 'List available newsgroups'; rstListExtensionsHelpText = 'List available extensions'; rstStatHelpText = 'Return an article''s availability'; rstXOVERHelpText = 'Return overview of available messages'; RSNNTPSvrImplicitTLSRequiresSSL='Implicit NNTP requires that IOHandler be set to a TIdSSLIOHandlerSocketBase.'; { TIdNNTPContext } {*----------------------------------------------------------------------* | constructor TIdNNTPContext.Create | | | | Constructor for TidNNTPContext | *----------------------------------------------------------------------*} constructor TIdNNTPContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList); begin inherited Create(AConnection, AYarn, AList); FCurrentArticle := 0; end; {*----------------------------------------------------------------------* | function TIdNNTPContext.GetUsingTLS | | | | 'Get' method for UsingTLS property | *----------------------------------------------------------------------*} function TIdNNTPContext.GetUsingTLS: boolean; begin Result:=Connection.IOHandler is TIdSSLIOHandlerSocketBase; if result then begin Result:=not TIdSSLIOHandlerSocketBase(Connection.IOHandler).PassThrough; end; end; {*----------------------------------------------------------------------* | procedure Reauthenticate | | | | The user code can call Reauthenticate to force a '480 Authorization | | required for this command' response after an OnCheckMsgByNo, | | OnCheckMsgById, OnSelectGroup, or OnPost event - even if | | authentication has already been accepted. | | | | This allows NNTP servers to be implemented where only particular | | users can access certain groups. | *----------------------------------------------------------------------*} procedure TIdNNTPContext.Reauthenticate; begin fReauthenticate := True; end; { TidNNTPServerX } {*----------------------------------------------------------------------* | function TidNNTPServerX.AuthOk | | | | Returns 'True' if an authenticated session already exists, or is | | not required. | | | | If an authenticated session is required, and doesn't already exist, | | the function sets the response to indicate that authentication is | | required, and returns false. | | | | It is called by all command handlers except HELP and QUIT | *----------------------------------------------------------------------*} function TidNNTPServerX.AuthOk(ASender: TIdCommand): Boolean; var context: TIdNNTPContext; authRequired : boolean; begin Result := True; context := TIdNNTPContext (ASender.Context); context.fReauthenticate := False; if (SupportedAuthTypes <> []) and Assigned(FOnAuth) and (not context.Authenticated) then begin authRequired := True; if Assigned(OnAuthRequired) then OnAuthRequired(context, ASender.CommandHandler.Command, ASender.UnparsedParams, authRequired); if authRequired then begin { RL - AUTHINFO SIMPLE is discouraged by RFC 2980, but it is not completely obsolete, so if the user really wants to use just it and no other, then do so here. If any other auth type is begin supported though, always use another one instead } result := False; if SupportedAuthTypes = [atSimple] then ASender.Reply.SetReply (450, '') else ASender.Reply.SetReply (480, '') end end end; {*----------------------------------------------------------------------* | function TidNNTPServerX.CheckIsInGroup | | | | Return True if the current session is 'in' a group | | | | If the current session is not 'in' a group, then the response is set | | to '412 - No newsgroup has been selected' | *----------------------------------------------------------------------*} function TidNNTPServerX.CheckIsInGroup (ASender : TidCommand) : boolean; begin if TidNNTPContext (ASender.Context).FCurrentGroup = '' then begin result := False; ASender.Reply.SetReply (412, '') end else result := True end; {*----------------------------------------------------------------------* | function TidNNTPServerX.CheckAuthRequisites | | | | Check the TLS layer, Authentication parameters, and if an event | | handler has been provided (in the user's code) if it's required. | | | | If the function returns 'True', everything is OK, and the handler | | can be called. | | | | If the function returns 'False', the correct 'failure' response is | | set: | | | | 500 - Command not supported Indicates that the user hasn't | | provided a required event handler | | | | 480 - Authentication required Authentication is required for this | | command | | | | 450 - SIMPLE authentication Authentication is required. Only | | SIMPLE authentication is supported | | | | 483 - Strong encryption layer TLS encryption is required | | is required | | | | Parameters: | | ASender : TIdCommand; The sender context | | needsHandler: boolean; True if a handler is required | | handler: pointer Address of the event handler. | *----------------------------------------------------------------------*} function TidNNTPServerX.CheckAuthRequisites(ASender : TIdCommand; needsHandler: boolean; handler: pointer): boolean; begin if needsHandler and (handler = Nil) then begin ASender.Reply.SetReply (500, ''); result := False end else result := SecLayerOk (ASender) and AuthOK (ASender) end; {*----------------------------------------------------------------------* | procedure TidNNTPServerX.CommandArticle | | | | Handler for ARTICLE command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandArticle(ASender: TIdCommand); begin DoGetMessageCommand (ASender, 220, true, OnArticleByNo, OnArticleById) end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandAuthInfoPassword | | | | Handler for 'AUTHINFO PASS ' command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandAuthInfoPassword(ASender: TIdCommand); var context : TidNNTPContext; begin if Assigned(FOnAuth) then begin if ASender.Params.Count = 1 then begin context := TIdNNTPContext (ASender.Context); context.FPassword := ASender.Params[0]; // Call OnAuth handler to validate the username/password. // If this sets 'FAuthenticated', return a '281 - Authentication accepted' // response. If not, return the '502 - access restriction or // permission denied' response OnAuth (context, context.FAuthenticated); if context.FAuthenticated then ASender.Reply.SetReply (281, '') else ASender.Reply.SetReply (502, '') end end end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandAuthInfoUser | | | | Handler for 'AUTHINFO USER ' command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandAuthInfoUser(ASender: TIdCommand); var context : TIdNNTPContext; begin if Assigned(OnAuth) then begin if ASender.Params.Count = 1 then begin context := TIdNNTPContext (ASender.Context); context.FUsername := ASender.Params[0]; // Call OnAuth handler to validate the username. // If this sets 'FAuthenticated', a password was not required. return a // '281 - Authentication accepted' response. If not, return a '381 - // more authorization info required response. The client is then expected // to supply AUTHINFO PASS OnAuth(context, context.FAuthenticated); if context.FAuthenticated then ASender.Reply.SetReply (281, '') else ASender.Reply.SetReply (381, '') end; end; end; {*----------------------------------------------------------------------* | procedure TidNNTPServerX.CommandBody | | | | Handler for BODY command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandBody(ASender: TIdCommand); begin DoGetMessageCommand (ASender, 222, true, OnBodyByNo, OnBodyById) end; {*----------------------------------------------------------------------* | procedure TidNNTPServerX.CommandDate | | | | Handler for DATE command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandDate(ASender: TIdCommand); begin if CheckAuthRequisites (ASender, false, nil) then ASender.Reply.SetReply(111,FormatDateTime('yyyymmddhhnnss', Now + TimeZoneBias)); {do not localize} end; {*----------------------------------------------------------------------* | procedure TidNNTPServerX.CommandGroup | | | | Handler for GROUP command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandGroup(ASender: TIdCommand); var group : string; groupExists : boolean; msgCount, msgFirst, msgLast : Integer; context : TidNNTPContext; begin group := Trim (ASender.UnparsedParams); if CheckAuthRequisites (ASender, true, @OnSelectGroup) then begin context := TidNNTPContext (ASender.Context); // Call the OnSelectGroup event handler OnSelectGroup (context, group, msgCount, msgFirst, msgLast, groupExists); if context.fReauthenticate then // re-authentication required ASender.Reply.SetReply (480, '') else if groupExists then begin ASender.Reply.SetReply(211, Format('%d %d %d %s', [msgCount, msgFirst, msgLast, group])); context.FCurrentGroup := group; // RFC 977 section 3.2.1. GROUP // When a valid group is selected by means of this command, the // internally maintained "current article pointer" is set to the first // article in the group. If an invalid group is specified, the // previously selected group and article remain selected. If an empty // newsgroup is selected, the "current article pointer" is in an // indeterminate state and should not be used. if msgCount > 0 then context.FCurrentArticle := msgFirst else context.FCurrentArticle := 0 end // else return the default 411 - no such group response end end; {*----------------------------------------------------------------------* | procedure TidNNTPServerX.CommandHead | | | | Handler for HEAD command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandHead(ASender: TIdCommand); begin DoGetMessageCommand (ASender, 221, true, OnHeadByNo, OnHeadById) end; {*----------------------------------------------------------------------* | procedure TidNNTPServerX.CommandIHave | | | | Handler for IHAVE command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandIHave(ASender: TIdCommand); var LThread : TIdNNTPContext; LMsgID : String; LAccept:Boolean; LErrorText : String; begin if CheckAuthRequisites (ASender, true, @FOnIHaveCheck) then begin if not Assigned (OnPost) then // IHave requires OnIHaveCheck AND OnPost ASender.Reply.SetReply (500, '') else begin LThread := TIdNNTPContext(ASender.Context); LMsgID := Trim(ASender.UnparsedParams); if (Copy(LMsgID, 1, 1) = '<') then begin FOnIHaveCheck(LThread,LMsgID,LAccept); if LThread.fReauthenticate then // re-authentication required? ASender.Reply.SetReply (480, '') else if LAccept then begin ASender.Reply.SetReply(335,''); ASender.SendReply; LErrorText := ''; OnPost(TIdNNTPContext(ASender.Context), LAccept, LErrorText); ASender.Reply.SetReply(iif(LAccept, 235, 436), LErrorText); end else ASender.Reply.NumericCode := 435 end // else return the default 437 - article rejected, do not try again. end end end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandLast | | | | Handler for LAST command. Remember that LAST sets the current | | article to the Previous article, not the very last one! | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandLast(ASender: TIdCommand); var context : TidNNTPContext; msgNo : Integer; msgId : string; begin if CheckIsInGroup (ASender) and CheckAuthRequisites (ASender, true, @OnPrevArticle) then begin context := TidNNTPContext (ASender.Context); msgNo := context.FCurrentArticle; if msgNo > 0 then begin OnPrevArticle (context, msgNo, msgID); if (msgNo > 0) and (msgNo <> context.FCurrentArticle) then begin ASender.Reply.SetReply(223, Format('%d %s article retrieved - request text separately', [msgNo, msgId])); { do not localize } context.FCurrentArticle := msgNo end // else return default '422 - No previous article in group' end else ASender.Reply.SetReply (420, ''); end end; {*----------------------------------------------------------------------* | TidNNTPServer.CommandList | | | | Handler for (plain) LIST command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandList(ASender: TIdCommand); begin // nb. LIST commands with parameters (eg. LIST EXTENSIONS) are handled // separately if Trim (ASender.UnparsedParams) = '' then begin if CheckAuthRequisites (ASender, true, @OnListGroups) then begin // Default reply is '215 - List of newsgroups follows' ASender.SendReply; OnListGroups (TidNNTPContext (ASender.Context)); ASender.Context.Connection.IOHandler.WriteLn('.') end end else ASender.Reply.SetReply (501, ''); // Command syntax error end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandListExtensions | | | | Handler for 'LIST EXTENSIONS' extension. Lists supported extensions | | | | For details See draft-ietf-nntpext | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandListExtensions(ASender: TIdCommand); begin ASender.Reply.SetReply( 202,'Extensions supported:'); {do not localize} ASender.SendReply; if (IOHandler is TIdServerIOHandlerSSLBase) and (ImplicitTLS=False) then ASender.Context.Connection.IOHandler.WriteLn('STARTTLS'); {do not localize} if Assigned(OnXover) then ASender.Context.Connection.IOHandler.WriteLn('OVER'); {do not localize} if Assigned(FOnListGroup) then ASender.Context.Connection.IOHandler.WriteLn('LISTGROUP'); {do not localize} ASender.Context.Connection.IOHandler.WriteLn('.'); end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandListGroup | | | | Handler for 'LISTGROUP' extension. Selects a group, and lists the | | article numbers the group contains. | | | | For details see draft-ietf-nntpext and RFC 2980 | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandListGroup(ASender: TIdCommand); var LThrd : TIdNNTPContext; LGroup : String; LFirstIdx, LCount, LLastIdx : Integer; LCanJoin : Boolean; ok : boolean; begin if CheckAuthRequisites (ASender, true, @FOnListGroup) then begin ok := True; LThrd := TIdNNTPContext ( ASender.Context ); if not Assigned (OnSelectGroup) then begin ok := False; ASender.Reply.SetReply (500, '') end; if ok then // If a group is specified, select it - otherwise // use the current group begin LGroup := Trim(ASender.UnparsedParams); if Length(LGroup)=0 then begin LGroup := LThrd.CurrentGroup; if Length (LGroup) = 0 then begin ok := False; ASender.Reply.SetReply(412,''); // No current group selected end end end; if ok then begin FOnSelectGroup (LThrd, LGroup, LCount, LFirstIdx, LLastIdx, LCanJoin); if LCount = 0 then LFirstIdx := 0; if LThrd.fReauthenticate then // re-authentication required begin ok := False; ASender.Reply.SetReply (480, '') end; end; if ok then if LCanJoin then begin LThrd.FCurrentGroup := LGroup; LThrd.FCurrentArticle := LFirstIdx; ASender.SendReply; FOnListGroup(LThrd); ASender.Context.Connection.IOHandler.WriteLn('.'); end else ASender.Reply.SetReply (411, ''); end end; {*----------------------------------------------------------------------* | TidNNTPServer.CommandModeReader | | | Handler for MODE READER commmand *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandModeReader(ASender: TIdCommand); begin if SecLayerOk(ASender) then TIdNNTPContext(ASender.Context).FModeReader := True; end; {*----------------------------------------------------------------------* | TidNNTPSenderX.CommandNewGroups | | | | Handler for NEWGROUPS command | | | | nb. The 'distributions' parameter has been removed from the draft | | ietf spec. We still support it. | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandNewGroups(ASender: TIdCommand); var LDate : TDateTime; LDist : String; ok : boolean; begin if CheckAuthRequisites (ASender, true, @FOnListNewGroups) then begin ok := ASender.Params.Count > 1; // Must have at least Date & Time params if not ok then ASender.Reply.SetReply (501, ''); if ok then begin LDist := ''; LDate := NNTPDateTimeToDateTime( ASender.Params[0] ); LDate := LDate + NNTPTimeToTime( ASender.Params[1] ); if ASender.Params.Count > 2 then if (UpperCase(ASender.Params[2]) = 'GMT') then {Do not localize} begin LDate := LDate + OffSetFromUTC; if (ASender.Params.Count > 3) then LDist := ASender.Params[3]; end else LDist := ASender.Params[2]; ASender.SendReply; // Default 231 response FOnListNewGroups(TIdNNTPContext(ASender.Context), LDate, LDist); ASender.Context.Connection.IOHandler.WriteLn('.'); end end end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandNewNews | | | | Handler for NEWNEWS command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandNewNews(ASender: TIdCommand); var LDate : TDateTime; LDist : String; ok : boolean; begin if CheckAuthRequisites (ASender, true, @FOnNewNews) then begin ok := ASender.Params.Count > 2; // Must have at least Newsgroup Date & Time params if not ok then ASender.Reply.SetReply (501, ''); if ok then begin //0 - newsgroup //1 - date //2 - time //3 - GMT or distributions //4 - distributions if 3 was GMT LDist := ''; LDate := NNTPDateTimeToDateTime( ASender.Params[1] ); LDate := LDate + NNTPTimeToTime( ASender.Params[2] ); if (ASender.Params.Count > 3) then if (UpperCase(ASender.Params[3]) = 'GMT') then {Do not localize} begin LDate := LDate + OffSetFromUTC; if (ASender.Params.Count > 4) then LDist := ASender.Params[4]; end else LDist := ASender.Params[3]; ASender.SendReply; // Default 230 response FOnNewNews( TIdNNTPContext(ASender.Context), ASender.Params[0], LDate, LDist ); ASender.Context.Connection.IOHandler.WriteLn('.'); end end end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandNext | | | | Handler for 'NEXT' command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandNext(ASender: TIdCommand); var context : TidNNTPContext; msgNo : Integer; msgId : string; begin if CheckIsInGroup (ASender) and CheckAuthRequisites (ASender, true, @OnNextArticle) then begin context := TidNNTPContext (ASender.Context); msgNo := context.FCurrentArticle; if msgNo > 0 then begin OnNextArticle (context, msgNo, msgID); if (msgNo > 0) and (msgNo <> context.FCurrentArticle) then begin ASender.Reply.SetReply(223, Format('%d %s article retrieved - request text separately', [msgNo, msgId])); { do not localize } context.FCurrentArticle := msgNo end // else default 421 'No previous message response end else ASender.Reply.SetReply (420, ''); // No current article selected end end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandPost | | | | Handler for 'POST' command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandPost(ASender: TIdCommand); var LErrorText: string; LPostOk: Boolean; context : TidNNTPContext; begin if CheckAuthRequisites (ASender, true, @FOnPost) then begin if not fPostingAllowed then ASender.Reply.SetReply (440, '') else begin ASender.Reply.SetReply (340, ''); ASender.SendReply; LPostOk := False; LErrorText := ''; context := TidNNTPContext (ASender.Context); OnPost(context, LPostOk, LErrorText); if context.fReauthenticate then ASender.Reply.SetReply (480, '') else ASender.Reply.SetReply(iif(LPostOk, 240, 441), LErrorText); ASender.PerformReply := True end end end; {*----------------------------------------------------------------------* | TidNNTPServer.CommandSlave | | | | Handler for SLAVE command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandSlave(ASender: TIdCommand); begin if SecLayerOk(ASender) then TIdNNTPContext(ASender.Context).FModeReader := False; end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandSTARTTLS | | | | Handler for STARTTLS Extension | | | | nb. I don't understand TLS, so who knows if this works! | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandSTARTTLS(ASender: TIdCommand); var LIO : TIdSSLIOHandlerSocketBase; LCxt : TIdNNTPContext; begin if (IOHandler is TIdServerIOHandlerSSLBase) and (ImplicitTLS=False) then begin if TIdNNTPContext(ASender.Context).UsingTLS then begin // we are already using TLS ASender.Reply.NumericCode:=500; // does someone know the response-code? Exit; end; if (ASender.Context as TIdNNTPContext).UsingTLS then begin ASender.Reply.NumericCode := 580; end else begin ASender.Reply.NumericCode := 382; ASender.SendReply; LIO := ASender.Context.Connection.IOHandler as TIdSSLIOHandlerSocketBase; LIO.Passthrough := False; LCxt := ASender.Context as TIdNNTPContext; //reset the connection state as required by http://www.ietf.org/internet-drafts/draft-ietf-nntpext-tls-nntp-00.txt LCxt.FUserName := ''; LCxt.FPassword := ''; LCxt.FAuthenticated := False; LCxt.FModeReader := False; ASender.Context.Connection.IOHandler.Write(ReplyUnknownCommand.FormattedReply); end; end else begin ASender.Reply.NumericCode:=500; end; end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandStat | | | | Handler for STAT command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandStat(ASender: TIdCommand); begin DoGetMessageCommand (ASender, 223, false, Nil, Nil) end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandXHdr | | | | Handler for XHDR command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandXHdr(ASender: TIdCommand); var msgId, header, s : string; msgNoLo, msgNoHi : Integer; begin s := Trim (ASender.UnparsedParams); header := Trim (Fetch (s, ' ')); msgId := Trim (s); if Copy (msgId, 1, 1) = '<' then DoGetXHdrById (ASender, ASender.Reply.NumericCode, header, msgId) else if CheckIsInGroup (ASender) and CheckAuthRequisites (ASender, true, @OnXHdrByRange) then if ParseRangeParams (ASender, msgNoLo, msgNoHi) then begin DoGetXHdrByRange (ASender, ASender.Reply.NumericCode, header, msgNoLo, msgNoHi); ASender.Context.Connection.IOHandler.WriteLn('.') end end; {*----------------------------------------------------------------------* | TidNNTPServerX.CommandXOver | | | | Handler for the XOVER command | *----------------------------------------------------------------------*} procedure TidNNTPServerX.CommandXOver(ASender: TIdCommand); var LFirstMsg: Integer; LLastMsg: Integer; begin if CheckIsInGroup (ASender) and CheckAuthRequisites (ASender, true, @OnXOver) then if ParseRangeParams (ASender, LFirstMsg, LLastMsg) then begin DoGetMessageByRange (ASender, 224, LFirstMsg, LLastMsg, true, OnXOver); ASender.Context.Connection.IOHandler.WriteLn('.') end end; {*----------------------------------------------------------------------* | CreateReplyUnknownCommand | | | | Override the standard CreateReplyUnknownCommand to return a 500 | | command not recognized' response. | *----------------------------------------------------------------------*} function TidNNTPServerX.CreateReplyUnknownCommand: TIdReply; begin Result := FReplyClass.Create(nil, ReplyTexts); Result.NumericCode := 500; end; {*----------------------------------------------------------------------* | TidNNTPServerX. Destroy | | | | Destructor for TidNNTPServer. Tidy up... | *----------------------------------------------------------------------*} destructor TidNNTPServerX.Destroy; begin FreeAndNil(FOverviewFormat); FreeAndNil(FHelp); inherited; end; {*----------------------------------------------------------------------* | TidNNTPServerX.DoReplyUnknownCommand | | | | Override this to fix non standard implementation that returns two | | lines(!) | *----------------------------------------------------------------------*} procedure TidNNTPServerX.DoReplyUnknownCommand(AContext: TIdContext; ALine: string); var LReply: TIdReply; begin LReply := FReplyClass.Create(nil, ReplyTexts); try LReply.Assign(ReplyUnknownCommand); AContext.Connection.IOHandler.Write(LReply.FormattedReply); finally FreeAndNil(LReply); end; end; {*----------------------------------------------------------------------* | TidNNTPServerX.DoGetMessageById | | | | Used for HEAD, ATICLE, BODY and STAT by Id. | | | | * OnCheckMsgByID is called to check that the message exists | | and return the message no. Note that if the session is not 'in' | | a group, message no 0 will be returned - which is valid. There | | has been some discussion in news.software.nntp about whether | | the message no should *always* be 0 - even if the session is 'in' | | a group. The consensus was that it doesn't do any harm, and may | | be helpful to return the correct message number in that case. | | | 'STAT' doesn't need any further processing. HEAD, ARTICLE and | | BODY need at least a byNoHandler. | | | | * If a 'byIdHandler' was provided, it will be called. | | | | * If a 'byIdHandler' was not provided, call byNoHandler instead. | | But of course, only if the session is 'in' a group. This allows | | simple servers to be implemented with only byNoHandlers. | | | | Parameters: | | ASender : TIdCommand // Session, etc. | | responseNo: Integer // 'Success' response no | | msgId: string; // The message ID | | needsHandler: Boolean // True if a handler is required to | | // return the requested message part. | | // False for STAT | | | | byNoHandler: TIdNNTPOnArticleByNo; // msgNo handler. Called only | | // if the msgId handler does | | // not exist. | | | | byIdHandler: TIdNNTPOnArticleByID // msgId handler | *----------------------------------------------------------------------*} procedure TidNNTPServerX.DoGetMessageById(ASender : TIdCommand; responseNo: Integer; msgId: string; needsHandler: Boolean; byNoHandler: TIdNNTPOnArticleByNo; byIdHandler: TIdNNTPOnArticleByID); var reply: TIdReply; result: Boolean; msgNo : Integer; context : TidNNTPContext; begin context := TidNNTPContext (ASender.Context); // Check authentication etc. and fail if there's no OnCheckMsgID Result := CheckAuthRequisites(ASender, true, @OnCheckMsgID); if result then begin OnCheckMsgId(context, msgId, msgNo); if context.fReauthenticate then begin result := False; ASender.Reply.SetReply (480, '') end else // If we're in a group, msgNo <= 0 indicates message not found. // if we're not in a gruop, msgNo < 0 indicates not found. msgNo = 0 is // valid - the message might have been crossposted to many groups and there's // no way to determine which group's message no to use. if (msgNo < 0) or ((context.CurrentGroup <> '') and (msgNo = 0)) then begin result := False; ASender.Reply.SetReply(430, ''); end; end; // If we're not in a group (and msgNo = 0 was therefore returned), there // must be a byIdHandler if result and needsHandler and not Assigned (byIdHandler) then begin if msgNo = 0 then begin result := False; ASender.Reply.SetReply(430, '') end end; // We're all OK. Format the correct response text from the response no and // send it. if result then begin reply := ReplyTexts.Find(IntToStr(responseNo)); if context.FCurrentGroup = '' then msgNo := 0; ASender.Reply.SetReply(responseNo, IntToStr(msgNo) + ' ' + msgID + ' ' + reply.Text[0]); ASender.SendReply; end; // Call the byIdHandler if it exists - otherwise call the byNoHandler. if result and needsHandler then if Assigned (byIdHandler) then byIdHandler (context, msgId) else byNoHandler (context, msgNo); // nb. You *Never* update the current article pointer when getting a message // by id - even with STAT. end; {*----------------------------------------------------------------------* | TidNNTPServerX.DoGetMessageByNo | | | | Used for HEAD, ATICLE, BODY and STAT by No. | | | | * OnCheckMsgByNo is called to check that the message exists | | and return the message id so that the correct response can be | | formatted. | | | | 'STAT' doesn't need any further processing. HEAD, ARTICLE and | | BODY need a byNoHandler. | | | | Parameters: | | ASender : TIdCommand // Session, etc. | | responseNo: Integer // 'Success' response no | | msgNo: string; // The message number (in the current | | group | | needsHandler: Boolean // True if a handler is required to | | // return thh requested message part. | | // False for STAT | | | | byNoHandler: TIdNNTPOnArticleByNo; // msgNo handler. | *----------------------------------------------------------------------*} procedure TidNNTPServerX.DoGetMessageByNo(ASender : TidCommand; responseNo : Integer; msgNo: Integer; needsHandler : boolean; byNoHandler: TIdNNTPOnArticleByNo); var reply: TIdReply; result: Boolean; msgId : string; context : TidNNTPContext; begin context := TidNNTPContext (ASender.Context); // Check that we're in a group, that the authorization stuff is correct and // that OnCheckMsgNo has been provided result := CheckIsInGroup(ASender) and CheckAuthRequisites(ASender, true, @OnCheckMsgNo); if Result then begin OnCheckMsgNo(context, msgNo, msgId); if context.fReauthenticate then begin result := False; ASender.Reply.SetReply (480, '') end else if msgId = '' then // Article number not found begin result := False; ASender.Reply.SetReply(423, ''); end; end; // If a handler is required and doesn't // exist, return 'command not recognized' if result and needsHandler and not Assigned (byNoHandler) then begin result := False; ASender.Reply.SetReply (500, '') end; // All OK. Format and send the response if Result then begin reply := ReplyTexts.Find(IntToStr(responseNo)); ASender.Reply.SetReply(responseNo, IntToStr(msgNo) + ' ' + msgID + ' ' + reply.Text[0]); ASender.SendReply; end; // Call the handler if there is one (eg. not STAT) if result and needsHandler then byNoHandler(context, msgNo); // Update the current article pointer. if result then context.fCurrentArticle := msgNo end; {*----------------------------------------------------------------------* | TidNNTPServerX.DoGetMessageByRange | | | | Similar to DoGetMessageByNo, but used where message no ranges are | | specified in (eg. in XOVER. | *----------------------------------------------------------------------*} procedure TidNNTPServerX.DoGetMessageByRange(ASender: TidCommand; responseNo, msgNoLo, msgNoHi: Integer; needsHandler: boolean; byRangeHandler: TIdNNTPOnArticleByRange); var result: Boolean; context : TidNNTPContext; begin context := TidNNTPContext (ASender.Context); // Check that we're in a group and that the authorization stuff is correct. // nb. The OnCheckMsgRange is optional, so don't check it. Instead, check that // the 'byRangeHandler' exists if it's required. result := CheckIsInGroup(ASender) and CheckAuthRequisites(ASender, needsHandler, @byRangeHandler); // If an OnCheckMsgRange handler has been specified, call it to check that // messages exist within the range - so that a 423 response can be sent. // // If not, a 'success' esponse followed by an empty list will be returned // which is perfectly acceptable in most cases. if Result and Assigned (OnCheckMsgRange) then begin result := False; OnCheckMsgRange(context, msgNoLo, msgNoHi, result); if context.fReauthenticate then begin result := False; ASender.Reply.SetReply (480, '') end else if not result then ASender.Reply.SetReply(423, ''); end; // All OK. Send the success response if Result then begin ASender.Reply.SetReply(responseNo, ''); ASender.SendReply; end; // Call the byRangeHandler if it's required. if result and needsHandler then byRangeHandler(context, msgNoLo, msgNoHi); end; {*----------------------------------------------------------------------* | procedure DoGetMessageCommand | | | | Initial point for HEAD, ARTICLE, BODY and STAT commands. Check | | everything's set up OK - then call DoGetMessageByNo or | | DoGetMessageById, depending on the parameter. | *----------------------------------------------------------------------*} procedure TidNNTPServerX.DoGetMessageCommand(ASender: TidCommand; responseNo : Integer; needsHandler : boolean; byNoHandler : TIdNNTPOnArticleByNo; byIdHandler : TIdNNTPOnArticleByID); var s : string; msgNo : Integer; msgId : string; ok : boolean; begin s := Trim (ASender.UnparsedParams); ok := True; if s <> '' then if s [1] = '<' then // Get message by ID begin msgID := s; msgNo := 0 end else // Get message by no msgNo := StrToIntDef (s, -1) else begin // No parameter, so get message by no on the // current article msgNo := TidNNTPContext (ASender.Context).CurrentArticle; if msgNo = 0 then begin ASender.Reply.SetReply (420, ''); ok := False end end; if msgNo = -1 then // Invalid message no specified. begin // Return 501 - Command syntax error ASender.Reply.SetReply (501, ''); ok := False end; if ok then if msgId <> '' then DoGetMessageById(ASender, responseNo, msgId, needsHandler, byNoHandler, byIdHandler) else DoGetMessageByNo(ASender, responseNo, msgNo, needsHandler, byNoHandler) end; {*----------------------------------------------------------------------* | TidNNTPServerX.DoGetXHdrById | | | | DoGetMessageById can't be called for XHDR because of the additional | | 'header' parameter in the handler. Effiectively duplicate it's | | functionality here. | *----------------------------------------------------------------------*} procedure TidNNTPServerX.DoGetXHdrById(ASender: TIdCommand; responseNo: Integer; const header, msgId: string); var reply: TIdReply; result: Boolean; msgNo : Integer; context : TidNNTPContext; begin context := TidNNTPContext (ASender.Context); Result := CheckAuthRequisites(ASender, true, @OnCheckMsgID); if result then begin OnCheckMsgId(context, msgId, msgNo); if context.fReauthenticate then begin result := False; ASender.Reply.SetReply (480, '') end else if (msgNo < 0) or ((context.CurrentGroup <> '') and (msgNo = 0)) then begin result := False; ASender.Reply.SetReply(430, ''); end; end; if result and not Assigned (OnXHdrById) then begin if msgNo <= 0 then begin result := False; ASender.Reply.SetReply(430, '') end end; if result then begin reply := ReplyTexts.Find(IntToStr(responseNo)); if context.FCurrentGroup = '' then msgNo := 0; ASender.Reply.SetReply(responseNo, IntToStr(msgNo) + ' ' + msgID + ' ' + reply.Text[0]); ASender.SendReply; end; if result then if Assigned (OnXHdrByID) then OnXHdrByID (context, header, msgId) else OnXHdrByRange (context, header, msgNo, msgNo) end; {*----------------------------------------------------------------------* | TidNNTPServerX.DoGetXHdrByRange | | | | DoGetMessageByRange can't be called for XHDR because of the | | additional 'header' parameter in the handler. Effiectively | | duplicate it's functionality here. | *----------------------------------------------------------------------*} procedure TidNNTPServerX.DoGetXHdrByRange(ASender: TidCommand; responseNo: Integer; const header: string; msgNoLo, msgNoHi: Integer); var result: Boolean; context : TidNNTPContext; begin context := TidNNTPContext (ASender.Context); result := CheckIsInGroup(ASender) and CheckAuthRequisites(ASender, true, @OnCheckMsgNo); if result and not Assigned (OnXHdrByRange) then begin result := False; ASender.Reply.SetReply (500, '') end; if Result then begin ASender.Reply.SetReply(responseNo, ''); ASender.SendReply; end; if result then OnXHdrByRange (context, header, msgNoLo, msgNoHi); end; {*----------------------------------------------------------------------* | TidNNTPServerX.InitComponent | | | | Override InitComponent to set up everything. This is called by the | | standard Indy constructor. | *----------------------------------------------------------------------*} procedure TidNNTPServerX.InitComponent; begin inherited; FHelp := TStringList.Create; FPostingAllowed := True; FOverviewFormat := TStringList.Create; with FOverviewFormat do begin Add('Subject:'); {do not localize} Add('From:'); {do not localize} Add('Date:'); {do not localize} Add('Message-ID:'); {do not localize} Add('References:'); {do not localize} Add('Bytes:'); {do not localize} Add('Lines:'); {do not localize} end; FContextClass := TIdNNTPContext; FRegularProtPort := IdPORT_NNTP; FImplicitTLSProtPort := IdPORT_SNEWS; DefaultPort := IdPORT_NNTP; (* In general, 1xx codes may be ignored or displayed as desired; code 200 or 201 is sent upon initial connection to the NNTP server depending upon posting permission; *) // TODO: Account for 201 as well. Right now the user can override this if they wish Greeting.NumericCode := 200; // ExceptionReply.NumericCode := 503; ExceptionReply.NumericCode := 500; ExceptionReply.Text.Text := RSNNTPServerNotRecognized; SupportedAuthTypes := [atUserPass]; end; {*----------------------------------------------------------------------* | TidNNTPServerX.InitializeCommandHandlers | | | | Set up the command handlers and response texts | *----------------------------------------------------------------------*} procedure TidNNTPServerX.InitializeCommandHandlers; begin inherited; with CommandHandlers.Add do begin Command := 'ARTICLE'; {do not localize} OnCommand := CommandArticle; ParseParams := False; Description.Text := rstArticleHelpText; end; with CommandHandlers.Add do begin Command := 'AUTHINFO USER'; {do not localize} OnCommand := CommandAuthInfoUser; NormalReply.NumericCode := 500; end; with CommandHandlers.Add do begin Command := 'AUTHINFO PASS'; {do not localize} OnCommand := CommandAuthInfoPassword; NormalReply.NumericCode := 500; end; (* // TODO: Add AUTHINFO SIMPLE and AUTHINFO GENERIC with CommandHandlers.Add do begin Command := 'AUTHINFO SIMPLE'; {do not localize} NormalReply.NumericCode := 452; end; with CommandHandlers.Add do begin Command := 'AUTHINFO GENERIC'; {do not localize} NormalReply.NumericCode := 501; end; *) with CommandHandlers.Add do begin Command := 'BODY'; {do not localize} OnCommand := CommandBody; ParseParams := False; Description.Text := rstBodyHelpText; end; with CommandHandlers.Add do begin Command := 'GROUP'; {do not localize} OnCommand := CommandGroup; NormalReply.NumericCode := 411; // No such group ParseParams := False; Description.Text := rstGroupHelpText; end; with CommandHandlers.Add do begin Command := 'DATE'; {do not localize} OnCommand := CommandDate; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'HEAD'; {do not localize} OnCommand := CommandHead; ParseParams := False; Description.Text := rstHeadHelpText; end; if FHelp.Count > 0 then with CommandHandlers.Add do begin Command := 'HELP'; {do not localize} NormalReply.NumericCode := 100; if FHelp.Count = 0 then begin Response.Add('No help available.'); {do not localize} end else begin Response.Assign(FHelp); end; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'IHAVE'; {do not localize} OnCommand := CommandIHave; ParseParams := False; NormalReply.NumericCode := 437; // Article rejected - do not try again. end; with CommandHandlers.Add do begin Command := 'LAST'; {do not localize} OnCommand := CommandLast; NormalReply.NumericCode := 422; // No previous message ParseParams := False; end; with CommandHandlers.Add do begin Command := 'LIST Overview.fmt'; {do not localize} if OverviewFormat.Count > 0 then begin NormalReply.NumericCode := 215; Response.Assign(OverviewFormat); end else NormalReply.NumericCode := 503; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'LIST EXTENSIONS'; {do not localize} OnCommand := CommandListExtensions; ParseParams := False; Description.Text := rstListExtensionsHelpText; end; with CommandHandlers.Add do begin Command := 'LISTGROUP'; {do not localize} NormalReply.SetReply (211, 'List of article numbers follow'); OnCommand := CommandListGroup; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'LIST'; {do not localize} OnCommand := CommandList; NormalReply.NumericCode := 215; ParseParams := False; Description.Text := rstListHelpText; end; with CommandHandlers.Add do begin Command := 'MODE READER'; {do not localize} OnCommand := CommandModeReader; NormalReply.NumericCode := 200; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'NEWGROUPS'; {do not localize} OnCommand := CommandNewGroups; NormalReply.NumericCode := 231; end; with CommandHandlers.Add do begin Command := 'NEWNEWS'; {do not localize} OnCommand := CommandNewNews; NormalReply.NumericCode := 231; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'NEXT'; {do not localize} OnCommand := CommandNext; NormalReply.NumericCode := 421; // No previous message ParseParams := False; end; with CommandHandlers.Add do begin Command := 'POST'; {do not localize} OnCommand := CommandPost; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'SLAVE'; {do not localize} OnCommand := CommandSlave; NormalReply.NumericCode := 202; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'STAT'; {do not localize} OnCommand := CommandStat; ParseParams := False; Description.Text := rstStatHelpText; end; with CommandHandlers.Add do begin Command := 'QUIT'; {do not localize} Disconnect := True; NormalReply.NumericCode := 205; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'XHDR'; {do not localize} OnCommand := CommandXHdr; ParseParams := True; NormalReply.NumericCode := 221; end; with CommandHandlers.Add do begin Command := 'HDR'; {do not localize} OnCommand := CommandXHdr; ParseParams := True; NormalReply.NumericCode := 225; end; with CommandHandlers.Add do begin Command := 'XOVER'; {do not localize} OnCommand := CommandXOver; ParseParams := False; end; //from http://www.ietf.org/internet-drafts/draft-ietf-nntpext-tls-nntp-00.txt with CommandHandlers.Add do begin Command := 'OVER'; {do not localize} OnCommand := CommandXOver; ParseParams := False; end; with CommandHandlers.Add do begin Command := 'STARTTLS'; {do not localize} OnCommand := CommandSTARTTLS; ParseParams := False; end; with ReplyTexts do begin // 100s Add(100, 'help text follows'); Add(199, 'debug output'); // 200s Add(200, 'server ready - posting allowed'); Add(201, 'server ready - no posting allowed'); Add(202, 'slave status noted'); Add(205, 'closing connection - goodbye!'); Add(215, 'list of newsgroups follows'); Add(220, 'article retrieved - head and body follow'); Add(221, 'article retrieved - head follows'); Add(222, 'article retrieved - body follows'); Add(223, 'article retrieved - request text separately'); Add(224, 'Overview information follows'); {do not localize} Add(225, 'Headers follow'); {do not localize} Add(230, 'list of new articles by message-id follows'); Add(231, 'list of new newsgroups follows'); Add(235, 'article transferred ok'); Add(240, 'article posted ok'); Add(281, 'authentication accepted'); // 300s Add(335, 'send article to be transferred. End with .'); Add(340, 'send article to be posted. End with .'); Add(381, 'more authentication information required'); Add(382,'Continue with TLS negotiation'); {do not localize} // 400s Add(400, 'service discontinued'); Add(403, 'TLS temporarily not available'); {do not localize} Add(411, 'no such news group'); Add(412, 'no newsgroup has been selected'); Add(420, 'no current article has been selected'); Add(421, 'no next article in this group'); Add(422, 'no previous article in this group'); Add(423, 'no such article number in this group'); Add(430, 'no such article found'); Add(435, 'article not wanted - do not send it'); Add(436, 'transfer failed - try again later'); Add(437, 'article rejected - do not try again.'); Add(440, 'posting not allowed'); Add(441, 'posting failed'); Add(480, 'Authorization required for this command'); Add(482, 'Authorization rejected'); Add(483, 'Strong encryption layer is required'); {do not localize} // 500s Add(500, 'command not recognized'); Add(501, 'command syntax error'); Add(502, 'access restriction or permission denied'); Add(503, 'program fault - command not performed') end end; {*----------------------------------------------------------------------* | TidNNTPServerX.NNTPDateTimeToDateTime | | | | Convert a NNTP Date/Time to a Delphi TDateTime. An NNTP date time | | can be 'YYMMDD HHMMSS' or 'YYYYMMDD HHMMSS' | *----------------------------------------------------------------------*} class function TidNNTPServerX.NNTPDateTimeToDateTime( const ATimeStamp: string): TDateTime; var LYr, LMo, LDay : Word; LTimeStr : String; LDateStr : String; begin Result := 0; if ATimeStamp <> '' then begin LTimeStr := ATimeStamp; LDateStr := Fetch(LTimeStr); if (Length(LDateStr) > 6) then begin //four digit year, good idea - IMAO LYr := StrToIntDef(Copy(LDateStr,1,4),1969); Delete(LDateStr,1,4); end else begin LYr := StrToIntDef(Copy(LDateStr,1,2),69); Delete(LDateStr,1,2); LYr := LYr + 2000; end; LMo := StrToIntDef(Copy(LDateStr,1,2),1); Delete(LDateStr,1,2); LDay := StrToIntDef(Copy(LDateStr,1,2),1); Delete(LDateStr,1,2); Result := EncodeDate(LYr, LMo, LDay) + NNTPTimeToTime(LTimeStr); end; end; {*----------------------------------------------------------------------* | TidNNTPServerX.NNTPTimeToTime | | | | Convert a NNTP Time to a Delphi TDateTime. An NNTP time is 'HHMMSS' | | can be 'YYMMDD HHMMSS' or 'YYYYMMDD HHMMSS' | *----------------------------------------------------------------------*} class function TidNNTPServerX.NNTPTimeToTime( const ATimeStamp: String): TDateTime; var LHr, LMn, LSec : Word; LTimeStr : String; begin LTimeStr := ATimeStamp; if LTimeStr <> '' then begin LHr := StrToIntDef(Copy(LTimeStr,1,2),1); Delete(LTimeStr,1,2); LMn := StrToIntDef(Copy(LTimeStr,1,2),1); Delete(LTimeStr,1,2); LSec := StrToIntDef(Copy(LTimeStr,1,2),1); Delete(LTimeStr,1,2); Result := EncodeTime(LHr, LMn, LSec,0); LTimeStr := Trim(LTimeStr); if UpperCase(LTimeStr)='GMT' then {do not localize} begin // Apply local offset Result := Result + OffSetFromUTC; end end else Result := 0; end; {*----------------------------------------------------------------------* | TidNNTPServerX.ParseRangeParams | | | | Parse an XOVER or XHDR 'range' parameter. | | | | * If the parameter is missing, set both AMsgLo and AMsgHi to the | | current article. If no current article exists, return a 420 | | error. | | | | * If the parameter contains a single integer, set both AMsgLo and | | AMsgHi to it. | | | | * If the parameter contains [Integer]-[Integer], set AMsgLo to the | | first integer, and AMsgHi to the second. | | | | * If the parameter contains [Integer]- , set AMsgLo to the integer | | and set AMsgHi to '0'. | | | | * If the parameter was not in one of these forms, set a 501 syntax | | error response. | *----------------------------------------------------------------------*} function TidNNTPServerX.ParseRangeParams (ASender : TidCommand; var AMsgLo, AMsgHi : Integer) : boolean; var s : string; begin s := ASender.UnparsedParams; result := True; if Pos ('-', s) = 0 then begin s := Trim (s); if s = '' then // No parameter. Return current article begin AMsgLo := TIdNNTPContext(ASender.Context).CurrentArticle; if AMsgLo = 0 then begin result := False; ASender.Reply.SetReply (420, '') // No current article end end else begin // Single integer expected AMsgLo := StrToIntDef (Trim (s), -1); if AMsgLo < 0 then begin result := False; ASender.Reply.SetReply (501, '') end else if AmsgLo = 0 then // '0' is invalid. Return article begin // number not found result := False; ASender.Reply.SetReply (430, '') end end; AMsgHi := AMsgLo end // Range expected else begin AMsgLo := StrToIntDef(Trim(Fetch(s, '-')), -1); if AMsgLo < 0 then // Syntax error in first integer begin result := False; ASender.Reply.SetReply (501, '') end; s := Trim (s); if s = '' then AMsgHi := 0 // [Integer]- form. Return 0 for else // the range's high value indicating all // subsequent messages begin AMsgHi := StrToIntDef(Trim(s), -1); if AMsgHi = -1 then // Syntax error in second integer begin result := False; ASender.Reply.SetReply (501, '') end end end end; {*----------------------------------------------------------------------* | TidNNTPServerX.SecLayerOk | *----------------------------------------------------------------------*} function TidNNTPServerX.SecLayerOk(ASender: TIdCommand): Boolean; begin Result := (FUseTLS = utUseRequireTLS) and (ASender.Context.Connection.IOHandler as TIdSSLIOHandlerSocketBase).PassThrough = True; result := not result; if not result then ASender.Reply.SetReply (483, '') end; {*----------------------------------------------------------------------* | TidNNTPServerX.SetHelp | | | | Set method for Help property. Note that if this is empty, the | | default help messages wil be returned by 'HELP' | *----------------------------------------------------------------------*} procedure TidNNTPServerX.SetHelp(AValue: TStrings); begin FHelp.Assign(AValue); end; {*----------------------------------------------------------------------* | TidNNTPServerX.SetImplicitTLS | | | | Set method for ImplcitTLS property | *----------------------------------------------------------------------*} procedure TidNNTPServerX.SetImplicitTLS(const AValue: Boolean); begin if (AValue = FImplicitTLS) then begin Exit; end; if (IOHandler is TIdServerIOHandlerSSLBase) then begin FImplicitTLS := AValue; if AValue then begin if DefaultPort = IdPORT_NNTP then begin DefaultPort := IdPORT_SNEWS; end; end else begin if DefaultPort = IdPORT_SNEWS then begin DefaultPort := IdPORT_NNTP; end; end; end else begin if AValue then begin raise EIdNNTPImplicitTLSRequiresSSL.Create( RSNNTPSvrImplicitTLSRequiresSSL ); end else begin FImplicitTLS := AValue; end; end; end; {*----------------------------------------------------------------------* | TidNNTPServerX.SetIOHandler | | | | Override SetIOHandler (TLS support) | *----------------------------------------------------------------------*} procedure TidNNTPServerX.SetIOHandler(const AValue: TIdServerIOHandler); begin inherited; if IOHandler is TIdServerIOHandlerSSLBase then begin // LIO := AValue as TIdSSLIOHandlerSocketBase; // LIO.PeerPassthrough := True; end else begin ImplicitTLS := False; end; end; {*----------------------------------------------------------------------* | TidNNTPServerX.SetOverviewFormat | | | | Set method for OverviewFormat property | *----------------------------------------------------------------------*} procedure TidNNTPServerX.SetOverviewFormat(AValue: TStrings); begin FOverviewFormat.Assign(AValue); end; end.