// *************************************************************************** // // Delphi MVC Framework // // Copyright (c) 2010-2016 Daniele Teti and the DMVCFramework Team // // https://github.com/danieleteti/delphimvcframework // // *************************************************************************** // // Licensed under the Apache License, Version 2.0 (the "License"); // you may not use this file except in compliance with the License. // You may obtain a copy of the License at // // http://www.apache.org/licenses/LICENSE-2.0 // // Unless required by applicable law or agreed to in writing, software // distributed under the License is distributed on an "AS IS" BASIS, // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. // See the License for the specific language governing permissions and // limitations under the License. // // *************************************************************************** } unit MVCFramework; {$RTTI EXPLICIT METHODS([vcPublic, vcPublished, vcProtected]) FIELDS(DefaultFieldRttiVisibility) PROPERTIES(DefaultPropertyRttiVisibility)} {$WARNINGS OFF} interface uses System.Generics.Collections, MVCFramework.Logger, Web.HTTPApp, System.RTTI, System.Classes, Data.DB, System.SysUtils, MVCFramework.Commons, MVCFramework.View.Cache, IdHeaderList, MVCFramework.ApplicationSession, MVCFramework.Session, StompTypes, ObjectsMappers {$IF CompilerVersion < 27} , Data.DBXJSON {$ELSE} , System.JSON {$ENDIF} {$IF CompilerVersion >= 27} , Web.ApacheHTTP // Apache Support since XE6 http://docwiki.embarcadero.com/Libraries/XE6/de/Web.ApacheHTTP {$ENDIF} , ReqMulti {Delphi XE4 (all update) and XE5 (with no update) dont contains this unit. Look for the bug in QC} , LoggerPro, MVCFramework.DuckTyping; type TMVCHTTPMethodType = (httpGET, httpPOST, httpPUT, httpDELETE, httpHEAD, httpOPTIONS, httpPATCH, httpTRACE); TMVCHTTPMethods = set of TMVCHTTPMethodType; TDMVCSerializationType = TSerializationType; TSessionData = TDictionary; // RTTI ATTRIBUTES MVCHTTPMethodAttribute = class(TCustomAttribute) private FMVCHTTPMethods: TMVCHTTPMethods; function GetMVCHTTPMethodsAsString: string; public constructor Create(AMVCHTTPMethods: TMVCHTTPMethods); property MVCHTTPMethods: TMVCHTTPMethods read FMVCHTTPMethods; property MVCHTTPMethodsAsString: string read GetMVCHTTPMethodsAsString; end; MVCHTTPMethodsAttribute = MVCHTTPMethodAttribute; // just an alias MVCBaseAttribute = class(TCustomAttribute) end; MVCStringAttribute = class(MVCBaseAttribute) private FValue: string; public constructor Create(const Value: string); property Value: string read FValue; end; MVCConsumesAttribute = class(MVCStringAttribute) end; MVCDocAttribute = class(MVCStringAttribute) end; MVCProducesAttribute = class(MVCStringAttribute) private FProduceEncoding: string; procedure SetProduceEncoding(const Value: string); public constructor Create(const Value: string); overload; constructor Create(const Value: string; const ProduceEncoding: string); overload; property ProduceEncoding: string read FProduceEncoding write SetProduceEncoding; end; MVCPathAttribute = class(MVCBaseAttribute) private FPath: string; public constructor Create(const Value: string); overload; constructor Create; overload; property Path: string read FPath; end; TMVCWebRequest = class public constructor Create(AWebRequest: TWebRequest); virtual; private FBody: string; FWebRequest: TWebRequest; FParamsTable: TMVCRequestParamsTable; FContentType: string; FCharset: string; FContentCharset: string; function GetHeader(const Name: string): string; // function GetHeaderValue(const Name: string): string; function GetPathInfo: string; function GetParamAll(const ParamName: string): string; function GetSegmentParam(const ParamName: string; out Value: string): Boolean; function GetSegmentParamsCount: Integer; function GetIsAjax: Boolean; function GetHTTPMethod: TMVCHTTPMethodType; function GetHTTPMethodAsString: string; function GetParamAllAsInteger(const ParamName: string): Integer; function GetParamAllAsInt64(const ParamName: string): Int64; function GetClientPreferHTML: Boolean; function GetFiles: TAbstractWebRequestFiles; strict protected FBodyAsJSONValue: TJSONValue; FParamNames: TArray; public destructor Destroy; override; procedure SetParamsTable(AParamsTable: TMVCRequestParamsTable); function GetParamNames: TArray; function ClientIP: string; virtual; function ClientPrefer(MimeType: string): Boolean; function ThereIsRequestBody: Boolean; function Accept: string; function QueryStringParam(Name: string): string; virtual; function QueryStringParamExists(Name: string): Boolean; virtual; function QueryStringParams: TStrings; procedure EnsureQueryParamExists(const Name: string); function ContentParam(Name: string): string; virtual; function Cookie(Name: string): string; virtual; property PathInfo: string read GetPathInfo; function Body: string; function BodyAs(const RootProperty: string = ''): T; function BodyAsListOf(const RootProperty : string = ''): TObjectList; function BodyAsJSONObject: TJSONObject; function BodyAsJSONValue: TJSONValue; property Headers[const HeaderName: string]: string read GetHeader; property ParamsAsInteger[const ParamName: string]: Integer read GetParamAllAsInteger; property ParamsAsInt64[const ParamName: string]: Int64 read GetParamAllAsInt64; property Params[const ParamName: string]: string read GetParamAll; property IsAjax: Boolean read GetIsAjax; property HTTPMethod: TMVCHTTPMethodType read GetHTTPMethod; property HTTPMethodAsString: string read GetHTTPMethodAsString; property RawWebRequest: TWebRequest read FWebRequest; property ClientPreferHTML: Boolean read GetClientPreferHTML; property Files: TAbstractWebRequestFiles read GetFiles; property ContentType: string read FContentType; property ContentCharset: string read FContentCharset; property Charset: string read FCharset; end; {$IF CompilerVersion >= 27} TMVCApacheWebRequest = class(TMVCWebRequest) public constructor Create(AWebRequest: TWebRequest); override; end; {$ENDIF} TMVCISAPIWebRequest = class(TMVCWebRequest) public constructor Create(AWebRequest: TWebRequest); override; end; TMVCINDYWebRequest = class(TMVCWebRequest) public constructor Create(AWebRequest: TWebRequest); override; end; TMVCWebResponse = class strict private function GetCustomHeaders: TStrings; private FStreamOutputDone: Boolean; FFlushOnDestroy: Boolean; // tristan procedure SetStatusCode(const Value: Integer); function GetStatusCode: Integer; procedure SetReasonString(const Value: string); function GetCookies: TCookieCollection; procedure SetContentType(const Value: string); function GetContentType: string; procedure SetContent(const Value: string); function GetContent: string; function GetLocation: string; procedure SetLocation(const Value: string); function GetReasonString: string; property Content: string read GetContent write SetContent; protected // do not put this as "strict" FWebResponse: TWebResponse; public constructor Create(AWebResponse: TWebResponse); virtual; destructor Destroy; override; procedure Flush; procedure SetCustomHeader(const Name, Value: string); procedure SetContentStream(AStream: TStream; AContentType: string); procedure SendHeaders; property CustomHeaders: TStrings read GetCustomHeaders; property StatusCode: Integer read GetStatusCode write SetStatusCode; property ReasonString: string read GetReasonString write SetReasonString; property Cookies: TCookieCollection read GetCookies; property ContentType: string read GetContentType write SetContentType; property Location: string read GetLocation write SetLocation; property RawWebResponse: TWebResponse read FWebResponse; property FlushOnDestroy: Boolean read FFlushOnDestroy write FFlushOnDestroy; // tristan end; TMVCEngine = class; TUser = class private FRoles: TList; FUserName: string; FLoggedSince: TDateTime; FRealm: string; procedure SetUserName(const Value: string); procedure SetLoggedSince(const Value: TDateTime); function GetIsValidLoggedUser: Boolean; procedure SetRealm(const Value: string); public procedure SaveToSession(AWebSession: TWebSession); function LoadFromSession(AWebSession: TWebSession): Boolean; procedure Clear; property Roles: TList read FRoles; property UserName: string read FUserName write SetUserName; property LoggedSince: TDateTime read FLoggedSince write SetLoggedSince; property IsValid: Boolean read GetIsValidLoggedUser; property Realm: string read FRealm write SetRealm; constructor Create; virtual; destructor Destroy; override; end; TWebContext = class private FRequest: TMVCWebRequest; FResponse: TMVCWebResponse; FConfig: TMVCConfig; FParamsTable: TMVCRequestParamsTable; FData: TDictionary; FLoggedUser: TUser; FWebSession: TWebSession; FIsSessionStarted: Boolean; FSessionMustBeClose: Boolean; function GetData: TDictionary; function GetWebSession: TWebSession; protected function SessionMustBeClose: Boolean; constructor Create(ARequest: TWebRequest; AResponse: TWebResponse; AConfig: TMVCConfig); virtual; procedure SetParams(AParamsTable: TMVCRequestParamsTable); procedure Flush; function GetLoggedUser: TUser; // Session function IsSessionStarted: Boolean; procedure SessionStart; virtual; procedure BindToSession(SessionID: string); function SendSessionCookie(AContext: TWebContext): string; public destructor Destroy; override; procedure SessionStop(ARaiseExceptionIfExpired: Boolean = true); virtual; function SessionStarted: Boolean; function SessionID: string; property LoggedUser: TUser read GetLoggedUser; property Request: TMVCWebRequest read FRequest; property Response: TMVCWebResponse read FResponse; property Session: TWebSession read GetWebSession; property Config: TMVCConfig read FConfig; property Data: TDictionary read GetData; end; TMVCActionProc = reference to procedure(Context: TWebContext); TMVCBase = class(TObject) private FMVCEngine: TMVCEngine; FMVCConfig: TMVCConfig; FApplicationSession: TWebApplicationSession; protected class function GetApplicationFileName: string; class function GetApplicationFileNamePath: string; procedure SetApplicationSession(const Value: TWebApplicationSession); public procedure SetMVCConfig(const Value: TMVCConfig); function GetMVCConfig: TMVCConfig; procedure SetMVCEngine(const Value: TMVCEngine); function GetMVCEngine: TMVCEngine; property ApplicationSession: TWebApplicationSession read FApplicationSession write SetApplicationSession; end; TMVCController = class(TMVCBase) private FViewModel: TMVCDataObjects; FViewDataSets: TObjectDictionary; FContext: TWebContext; FResponseStream: TStringBuilder; FContentCharset: string; procedure SetContext(const Value: TWebContext); procedure SetWebSession(const Value: TWebSession); procedure SetContentType(const Value: string); function GetContentType: string; function GetWebSession: TWebSession; function GetContentCharset: string; procedure SetContentCharset(const Value: string); // procedure Render(ACollection: TObjectList; AInstanceOwner: boolean; // AJSONObjectActionProc: TJSONObjectActionProc; ASerializationType: TSerializationType); overload; // procedure Render(ACollection: TObjectList; AInstanceOwner: boolean; // AJSONObjectActionProc: TJSONObjectActionProc; ASerializationType: TSerializationType); protected const CLIENTID_KEY = '__clientid'; protected function GetClientID: string; procedure RaiseSessionExpired; virtual; function GetCurrentWebModule: TWebModule; function ResponseStream: TStringBuilder; function GetNewStompClient(ClientID: string = ''): IStompClient; /// /// Load mustache view located in TMVCConfigKey.ViewsPath /// returns the rendered views and generates output using /// models pushed using Push* methods /// function LoadView(const ViewNames: TArray): string; virtual; /// /// Load a view fragment in the output render stream. The view fragment is appended to the /// ResponseStream verbatim. No processing happens. /// Useful when used with cache. /// It is equivalent to ResponseStream.Append(ViewFragment); /// procedure LoadViewFragment(const ViewFragment: string); /// /// Load mustache view located in TMVCConfigKey.ViewsPath and /// returns output using models pushed using Push* methods /// function GetRenderedView(const ViewNames: TArray): string; virtual; property Context: TWebContext read FContext write SetContext; property Session: TWebSession read GetWebSession write SetWebSession; procedure MVCControllerAfterCreate; virtual; procedure MVCControllerBeforeDestroy; virtual; property ContentType: string read GetContentType write SetContentType; property ContentCharset: string read GetContentCharset write SetContentCharset; // Renderers procedure Render(const Content: string); overload; virtual; procedure Render; overload; virtual; deprecated 'Use RenderResponseStream()'; procedure RenderResponseStream; virtual; procedure RenderWrappedList(aList: IWrappedList; aJSONObjectActionProc: TJSONObjectActionProc = nil; aSerializationType: TDMVCSerializationType = TDMVCSerializationType. Properties); procedure Render(aCollection: TObjectList; aInstanceOwner: Boolean = true; aJSONObjectActionProc: TJSONObjectActionProc = nil; aSerializationType: TDMVCSerializationType = TDMVCSerializationType. Properties); overload; procedure Render(aObject: TObject; aInstanceOwner: Boolean = true; aSerializationType: TDMVCSerializationType = TDMVCSerializationType. Properties); overload; virtual; procedure Render(aDataSet: TDataSet; aInstanceOwner: Boolean = false; aOnlySingleRecord: Boolean = false; aJSONObjectActionProc: TJSONObjectActionProc = nil); overload; virtual; procedure Render(aJSONValue: TJSONValue; aInstanceOwner: Boolean = true); overload; virtual; procedure Render(aTextWriter: TTextWriter; aInstanceOwner: Boolean = true); overload; procedure RenderListAsProperty(const aPropertyName: string; aObjectList: TObjectList; aOwnsInstance: Boolean = true; aJSONObjectActionProc: TJSONObjectActionProc = nil); procedure RenderJSONArrayAsProperty(const aPropertyName: string; AJSONArray: TJSONArray); procedure Render(E: Exception; ErrorItems: TList = nil); overload; virtual; procedure Render(const aErrorCode: UInt16; const aErrorMessage: string; const AErrorClassName: string = ''); overload; procedure Render(const aErrorCode: UInt16; aJSONValue: TJSONValue; aInstanceOwner: Boolean = true); overload; procedure Render(const aErrorCode: UInt16; aObject: TObject; aInstanceOwner: Boolean = true); overload; procedure RenderStreamAndFree(const AStream: TStream); deprecated 'Use Render(TStream,Boolean)'; procedure Render(const AStream: TStream; aInstanceOwner: Boolean = true); overload; // messaging procedure EnqueueMessageOnTopicOrQueue(const IsQueue: Boolean; const ATopic: string; AJSONObject: TJSONObject; aOwnsInstance: Boolean = true); function ReceiveMessageFromTopic(const ATopic: string; ATimeout: Int64; var JSONObject: TJSONObject): Boolean; // redirects procedure Redirect(const URL: string); // http return code procedure ResponseStatusCode(const AStatusCode: UInt16; AStatusText: string = ''); // streams and files procedure SendStream(AStream: TStream; AOwnStream: Boolean = true); virtual; procedure SendFile(AFileName: string); virtual; // filters before, after procedure OnBeforeAction(Context: TWebContext; const aActionName: string; var Handled: Boolean); virtual; procedure OnAfterAction(Context: TWebContext; const aActionName: string); virtual; property Config: TMVCConfig read GetMVCConfig; public // property ViewCache: TViewCache read FViewCache write SetViewCache; procedure PushJSONToView(const AModelName: string; AModel: TJSONValue); procedure PushObjectToView(const AModelName: string; AModel: TObject); procedure PushDataSetToView(const AModelName: string; aDataSet: TDataSet); constructor Create; destructor Destroy; override; end; TMVCControllerClass = class of TMVCController; TMVCControllerDelegate = reference to function: TMVCController; TMVCControllerRoutable = class strict private FClass: TMVCControllerClass; FDelegate: TMVCControllerDelegate; public constructor Create(AClass: TMVCControllerClass; ADelegate: TMVCControllerDelegate); property &Class: TMVCControllerClass read FClass; property Delegate: TMVCControllerDelegate read FDelegate; end; /// /// Basis Interface for DMVC Middleware. /// IMVCMiddleware = interface ['{3278183A-124A-4214-AB4E-94CA4C22450D}'] /// /// Procedure is called before the MVCEngine routes the request to a specific controller/method. /// /// Webcontext which contains the complete request and response of the actual call. /// If set to True the Request would finished. Response must be set by the implementor. Default value is False. procedure OnBeforeRouting(Context: TWebContext; var Handled: Boolean); /// /// Procedure is called before the specific controller method is called. /// /// Webcontext which contains the complete request and response of the actual call. /// Qualified classname of the matching controller. /// Method name of the matching controller method. /// If set to True the Request would finished. Response must be set by the implementor. Default value is False. procedure OnBeforeControllerAction(Context: TWebContext; const AControllerQualifiedClassName: string; const aActionName: string; var Handled: Boolean); /// /// Procedure is called after the specific controller method was called. /// It is still possible to cancel or to completly modifiy the request. /// /// Webcontext which contains the complete request and response of the actual call. /// Method name of the matching controller method. /// If set to True the Request would finished. Response must be set by the implementor. Default value is False. procedure OnAfterControllerAction(Context: TWebContext; const aActionName: string; const Handled: Boolean); end; TMVCEngine = class(TComponent) strict private FApplicationSession: TWebApplicationSession; private FWebModule: TWebModule; FSavedOnBeforeDispatch: THTTPMethodEvent; FMVCConfig: TMVCConfig; // FViewCache : TViewCache; FMimeTypes: TDictionary; procedure SetApplicationSession(const Value: TWebApplicationSession); procedure SetDefaultReponseHeaders(AContext: TWebContext); protected FConfiguredSessionTimeout: Int64; FControllers: TObjectList; FMiddleware: TList; procedure ExecuteBeforeRoutingMiddleware(Context: TWebContext; var Handled: Boolean); procedure ExecuteBeforeControllerActionMiddleware(MVCEngine: TMVCEngine; Context: TWebContext; const AControllerQualifiedClassName: string; const aActionName: string; var Handled: Boolean); procedure ExecuteAfterControllerActionMiddleware(Context: TWebContext; const aActionName: string; const Handled: Boolean); procedure ConfigDefaultValues; virtual; procedure FixUpWebModule; procedure OnBeforeDispatch(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); virtual; function ExecuteAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse): Boolean; virtual; procedure LoadSystemControllers; virtual; procedure ResponseErrorPage(E: Exception; Request: TWebRequest; Response: TWebResponse); virtual; class procedure ClearSessionCookiesAlreadySet(aCookies: TCookieCollection); public class function GetCurrentSession(ASessionTimeout: UInt64; const ASessionID: string; ARaiseExceptionIfExpired: Boolean = true) : TWebSession; class function ExtractSessionIDFromWebRequest (AWebRequest: TWebRequest): string; constructor Create(WebModule: TWebModule; ConfigProc: TProc = nil; CustomLogger: ILogWriter = nil); reintroduce; destructor Destroy; override; class function SendSessionCookie(AContext: TWebContext): string; overload; class function SendSessionCookie(AContext: TWebContext; const ASessionID: string) : string; overload; class function AddSessionToTheSessionList(const ASessionID: string; ASessionTimeout: UInt64): TWebSession; function GetSessionBySessionID(const ASessionID: string): TWebSession; function AddController(AControllerClass: TMVCControllerClass) : TMVCEngine; overload; function AddController(AControllerClass: TMVCControllerClass; ADelegate: TMVCControllerDelegate): TMVCEngine; overload; function AddMiddleware(AMiddleware: IMVCMiddleware): TMVCEngine; // internal methods function RegisteredControllers: TObjectList; // http return codes procedure Http404(AWebContext: TWebContext); procedure Http500(AWebContext: TWebContext; const AReasonText: string = ''); property Config: TMVCConfig read FMVCConfig; // allow a simple client code property ApplicationSession: TWebApplicationSession read FApplicationSession write SetApplicationSession; end; TMVCStaticContents = class(TMVCController) public // [MVCPath('/static/($filename)')] class procedure SendFile(AFileName, AMimeType: string; Context: TWebContext); class function IsStaticFile(AViewPath, AWebRequestPath: string; out ARealFileName: string): Boolean; class function IsScriptableFile(StaticFileName: string; Config: TMVCConfig): Boolean; end; type TMVCConfigKey = class public const SessionTimeout = 'sessiontimeout'; DocumentRoot = 'document_root'; ViewPath = 'view_path'; DefaultContentType = 'default_content_type'; DefaultContentCharset = 'default_content_charset'; DefaultViewFileExtension = 'default_view_file_extension'; ISAPIPath = 'isapi_path'; StompServer = 'stompserver'; StompServerPort = 'stompserverport'; StompUsername = 'stompusername'; StompPassword = 'stomppassword'; Messaging = 'messaging'; AllowUnhandledAction = 'allow_unhandled_action'; // tristan ServerName = 'server_name'; // tristan ExposeServerSignature = 'server_signature'; IndexDocument = 'index_document'; end; function IsShuttingDown: Boolean; procedure EnterInShutdownState; procedure InternalRender(const Content: string; ContentType, ContentEncoding: string; Context: TWebContext); overload; procedure InternalRenderText(const AContent: string; ContentType, ContentEncoding: string; Context: TWebContext); procedure InternalRender(aJSONValue: TJSONValue; ContentType, ContentEncoding: string; Context: TWebContext; aInstanceOwner: Boolean = true); overload; implementation uses System.SyncObjs, idglobal, IdGlobalProtocols, System.DateUtils, System.RegularExpressions, WinApi.Windows, System.TypInfo, System.ioutils, System.StrUtils, Web.Win.IsapiHTTP, MVCFramework.Router, MVCFramework.View, IdURI, IdStack, IdHTTPWebBrokerBridge, MVCFramework.MessagingController, Web.WebReq, MVCFramework.SysControllers; const ALLOWED_TYPED_ACTION_PARAMETERS_TYPES = 'Integer, Int64, Single, Double, Extended, Boolean, TDate, TTime, TDateTime and String'; type TIdHTTPAppRequestHack = class(TIdHTTPAppRequest) end; threadvar ctx: TRTTIContext; var _IsShuttingDown: Int64 = 0; // this variable is used by TInterlocked functions to handlòe the "shuttingdown" mode { TMVCEngine } function TMVCEngine.AddController(AControllerClass: TMVCControllerClass) : TMVCEngine; begin Result := AddController(AControllerClass, nil); end; function TMVCEngine.AddController(AControllerClass: TMVCControllerClass; ADelegate: TMVCControllerDelegate): TMVCEngine; begin FControllers.Add(TMVCControllerRoutable.Create(AControllerClass, ADelegate)); Result := Self; end; function TMVCEngine.AddMiddleware(AMiddleware: IMVCMiddleware): TMVCEngine; begin FMiddleware.Add(AMiddleware); Result := Self; end; class function TMVCEngine.AddSessionToTheSessionList(const ASessionID: string; ASessionTimeout: UInt64): TWebSession; var LSess: TWebSession; begin TMonitor.Enter(SessionList); try LSess := TMVCSessionFactory.GetInstance.CreateNewByType('memory', ASessionID, ASessionTimeout); SessionList.Add(ASessionID, LSess); Result := LSess; LSess.MarkAsUsed; finally TMonitor.Exit(SessionList); end; end; class procedure TMVCEngine.ClearSessionCookiesAlreadySet( aCookies: TCookieCollection); var I: Integer; lSessCookieName: string; lCookie: TCookie; begin lSessCookieName := TMVCConstants.SESSION_TOKEN_NAME.ToLower; I := 0; while true do begin if I = aCookies.Count then Break; lCookie := aCookies[I]; if LowerCase(lCookie.Name) = lSessCookieName then begin aCookies.Delete(I); end else Inc(I); end; end; procedure TMVCEngine.ConfigDefaultValues; begin Log.Info('ENTER: Config default values', LOGGERPRO_TAG); Config[TMVCConfigKey.SessionTimeout] := '30'; // 30 minutes Config[TMVCConfigKey.DocumentRoot] := '.\www'; Config[TMVCConfigKey.DefaultContentType] := TMVCConstants.DEFAULT_CONTENT_TYPE; Config[TMVCConfigKey.DefaultContentCharset] := TMVCConstants.DEFAULT_CONTENT_CHARSET; Config[TMVCConfigKey.DefaultViewFileExtension] := 'html'; Config[TMVCConfigKey.ViewPath] := 'templates'; Config[TMVCConfigKey.ISAPIPath] := ''; Config[TMVCConfigKey.StompServer] := 'localhost'; Config[TMVCConfigKey.StompServerPort] := '61613'; Config[TMVCConfigKey.StompUsername] := 'guest'; Config[TMVCConfigKey.StompPassword] := 'guest'; Config[TMVCConfigKey.Messaging] := 'false'; Config[TMVCConfigKey.AllowUnhandledAction] := 'false'; // tristan Config[TMVCConfigKey.ServerName] := 'DelphiMVCFramework'; // tristan Config[TMVCConfigKey.ExposeServerSignature] := 'true'; Config[TMVCConfigKey.IndexDocument] := 'index.html'; FMimeTypes.Add('.html', TMVCMimeType.TEXT_HTML); FMimeTypes.Add('.htm', TMVCMimeType.TEXT_HTML); FMimeTypes.Add('.txt', TMVCMimeType.TEXT_PLAIN); FMimeTypes.Add('.css', TMVCMimeType.TEXT_CSS); FMimeTypes.Add('.js', TMVCMimeType.TEXT_JAVASCRIPT); FMimeTypes.Add('.jpg', TMVCMimeType.IMAGE_JPEG); FMimeTypes.Add('.jpeg', TMVCMimeType.IMAGE_JPEG); FMimeTypes.Add('.png', TMVCMimeType.IMAGE_PNG); FMimeTypes.Add('.appcache', TMVCMimeType.TEXT_CACHEMANIFEST); Log.Info('EXIT: Config default values', LOGGERPRO_TAG); end; constructor TMVCEngine.Create(WebModule: TWebModule; ConfigProc: TProc; CustomLogger: ILogWriter); begin inherited Create(WebModule); WebRequestHandler.CacheConnections := true; WebRequestHandler.MaxConnections := 4096; FMimeTypes := TDictionary.Create; FMVCConfig := TMVCConfig.Create; FWebModule := WebModule; FControllers := TObjectList.Create(true); FMiddleware := TList.Create; // FViewCache := TViewCache.Create; FixUpWebModule; MVCFramework.Logger.SetDefaultLogger(CustomLogger); // WARNING!! from now on, the logger subsystem is available ConfigDefaultValues; if Assigned(ConfigProc) then begin LogEnterMethod('Custom configuration proc'); ConfigProc(FMVCConfig); LogExitMethod('Custom configuration proc'); end; LoadSystemControllers; end; destructor TMVCEngine.Destroy; begin FMimeTypes.Free; FMVCConfig.Free; FControllers.Free; FMiddleware.Free; // FViewCache.Free; inherited; end; procedure TMVCEngine.SetDefaultReponseHeaders(AContext: TWebContext); begin if Config[TMVCConfigKey.ExposeServerSignature] = 'true' then begin AContext.Response.CustomHeaders.Values['Server'] := Config[TMVCConfigKey.ServerName]; end; AContext.Response.RawWebResponse.Date := Now; end; function TMVCEngine.ExecuteAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse): Boolean; var lSelectedController: TMVCController; lContext: TWebContext; lParamsTable: TMVCRequestParamsTable; lRouter: TMVCRouter; lStaticFileName: string; lContentType: string; lHandled: Boolean; lResponseContentType, lResponseContentCharset: string; lActionFormalParams: TArray; lActualParams: TArray; function SendDocumentIndexIfPresent: Boolean; begin lStaticFileName := TPath.Combine(Config[TMVCConfigKey.DocumentRoot], Config[TMVCConfigKey.IndexDocument]); if TFile.Exists(lStaticFileName) then begin if FMimeTypes.TryGetValue(LowerCase(ExtractFileExt(lStaticFileName)), lContentType) then begin lContentType := lContentType + ';charset=' + FMVCConfig [TMVCConfigKey.DefaultContentCharset]; end else begin lContentType := TMVCMimeType.APPLICATION_OCTETSTREAM; end; TMVCStaticContents.SendFile(lStaticFileName, lContentType, lContext); Result := true; end else Result := false; end; procedure FillActualParamsForAction(const AContext: TWebContext; const aActionFormalParams: TArray; const aActionName: string; var aActualParams: TArray); var lParamName: string; I: Integer; lStrValue: string; lFormatSettings: TFormatSettings; lWasDateTime: Boolean; begin if AContext.Request.GetSegmentParamsCount <> Length(aActionFormalParams) then raise EMVCException.CreateFmt ('Paramaters count mismatch (expected %d actual %d) for action "%s"', [Length(aActionFormalParams), AContext.Request.GetSegmentParamsCount, aActionName]); SetLength(aActualParams, Length(aActionFormalParams)); for I := 0 to Length(aActionFormalParams) - 1 do begin lParamName := aActionFormalParams[I].Name; if not AContext.Request.GetSegmentParam(lParamName, lStrValue) then raise EMVCException.CreateFmt ('Invalid paramater %s for action %s (Hint: Here parameters names are case-sensitive)', [lParamName, aActionName]); case aActionFormalParams[I].ParamType.TypeKind of tkInteger, tkInt64: begin aActualParams[I] := StrToInt(lStrValue); end; tkUString: begin aActualParams[I] := lStrValue; end; tkFloat: begin lWasDateTime := false; if aActionFormalParams[I].ParamType.QualifiedName = 'System.TDate' then begin try lWasDateTime := true; aActualParams[I] := ISOStrToDate(lStrValue); except raise EMVCException.CreateFmt('Invalid TDate value for param [%s]', [aActionFormalParams[I].Name]); end; end else if aActionFormalParams[I].ParamType.QualifiedName = 'System.TDateTime' then begin try lWasDateTime := true; aActualParams[I] := ISOStrToDateTime(lStrValue); except raise EMVCException.CreateFmt('Invalid TDateTime value for param [%s]', [aActionFormalParams[I].Name]); end; end else if aActionFormalParams[I].ParamType.QualifiedName = 'System.TTime' then begin try lWasDateTime := true; aActualParams[I] := ISOStrToTime(lStrValue); except raise EMVCException.CreateFmt('Invalid TTime value for param [%s]', [aActionFormalParams[I].Name]); end; end; if not lWasDateTime then begin lFormatSettings.DecimalSeparator := '.'; aActualParams[I] := StrToFloat(lStrValue, lFormatSettings); end; end; tkEnumeration: begin if aActionFormalParams[I].ParamType.QualifiedName = 'System.Boolean' then begin if SameText(lStrValue, 'true') or SameText(lStrValue, '1') then aActualParams[I] := true else if SameText(lStrValue, 'false') or SameText(lStrValue, '0') then aActualParams[I] := false else raise EMVCException.CreateFmt ('Invalid boolean value for parameter %s. Boolean parameters accepts only "true"/"false" or "1"/"0".', [lParamName]); end else raise EMVCException.CreateFmt ('Invalid type for parameter %s. Allowed types are ' + ALLOWED_TYPED_ACTION_PARAMETERS_TYPES, [lParamName]); end; else begin raise EMVCException.CreateFmt ('Invalid type for parameter %s. Allowed types are ' + ALLOWED_TYPED_ACTION_PARAMETERS_TYPES, [lParamName]); end; { tkChar, tkEnumeration, , tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, tkVariant, tkArray, tkRecord, tkInterface, , tkDynArray, tkUString, tkClassRef, tkPointer, tkProcedure } end; end; end; begin // LogEnterMethod(Request.PathInfo); // try Result := false; lParamsTable := TMVCRequestParamsTable.Create; try lContext := TWebContext.Create(Request, Response, FMVCConfig); try SetDefaultReponseHeaders(lContext); // tristan // Static file handling if TMVCStaticContents.IsStaticFile(TPath.Combine(AppPath, FMVCConfig[TMVCConfigKey.DocumentRoot]), Request.PathInfo, lStaticFileName) then begin // if TMVCStaticContents.IsScriptableFile(StaticFileName, FMVCConfig) then // // execute the file // begin // ExecuteFile(StaticFileName, Context); // end // else // serve the file // begin if FMimeTypes.TryGetValue(LowerCase(ExtractFileExt(lStaticFileName)), lContentType) then begin lContentType := lContentType + ';charset=' + FMVCConfig [TMVCConfigKey.DefaultContentCharset]; end else begin lContentType := TMVCMimeType.APPLICATION_OCTETSTREAM; end; TMVCStaticContents.SendFile(lStaticFileName, lContentType, lContext); Result := true; // end; end else begin lRouter := TMVCRouter.Create(Config); try ExecuteBeforeRoutingMiddleware(lContext, lHandled); if not lHandled then begin if lRouter.ExecuteRouting(Request.PathInfo, TMVCRouter.StringMethodToHTTPMetod(Request.Method), Request.ContentType, Request.Accept, FControllers, FMVCConfig[TMVCConfigKey.DefaultContentType], FMVCConfig[TMVCConfigKey.DefaultContentCharset], lParamsTable, lResponseContentType, lResponseContentCharset) then begin if Assigned(lRouter.MVCControllerDelegate) then lSelectedController := lRouter.MVCControllerDelegate() else lSelectedController := lRouter.MVCControllerClass.Create; try lSelectedController.SetMVCConfig(Config); lSelectedController.ApplicationSession := FApplicationSession; lContext.SetParams(lParamsTable); lSelectedController.SetContext(lContext); lSelectedController.SetMVCEngine(Self); // exception? try { middlewares before controller action } ExecuteBeforeControllerActionMiddleware(Self, lContext, lRouter.MVCControllerClass.QualifiedClassName, lRouter.MethodToCall.Name, lHandled); if lHandled then Exit(true); lSelectedController.MVCControllerAfterCreate; try lHandled := false; // gets response contentype from MVCProduces attribute lSelectedController.ContentType := lResponseContentType; lSelectedController.ContentCharset := lResponseContentCharset; if not lHandled then begin lActionFormalParams := lRouter.MethodToCall.GetParameters; // case1: check for parameterless action if Length(lActionFormalParams) = 0 then begin SetLength(lActualParams, 0); end // case2: check for action with only TWebContext else if (Length(lActionFormalParams) = 1) and (SameText(lActionFormalParams[0].ParamType.QualifiedName, 'MVCFramework.TWebContext')) then begin SetLength(lActualParams, 1); lActualParams[0] := lContext; end // case3: strongly typed declaration... injection parameters else begin FillActualParamsForAction(lContext, lActionFormalParams, lRouter.MethodToCall.Name, lActualParams); end; lSelectedController.OnBeforeAction(lContext, lRouter.MethodToCall.Name, lHandled); try lRouter.MethodToCall.Invoke(lSelectedController, lActualParams); finally lSelectedController.OnAfterAction(lContext, lRouter.MethodToCall.Name); end; end; if lContext.SessionMustBeClose then begin // SessionList.Remove(SelectedController.Session.SessionID); end else begin end; finally lSelectedController.MVCControllerBeforeDestroy; end; ExecuteAfterControllerActionMiddleware(lContext, lRouter.MethodToCall.Name, lHandled); except on E: EMVCSessionExpiredException do begin LogException(E, E.DetailedMessage); lContext.SessionStop(false); lSelectedController.ResponseStatusCode(E.HTTPErrorCode); lSelectedController.Render(E); end; on E: EMVCException do begin LogException(E, E.DetailedMessage); lSelectedController.ResponseStatusCode(E.HTTPErrorCode); lSelectedController.Render(E); end; on E: EInvalidOp do begin LogException(E, 'Invalid OP'); lSelectedController.Render(E); end; on E: Exception do begin LogException(E, 'Global Action Exception Handler'); lSelectedController.Render(E); end; end; lContext.Response.ContentType := lSelectedController.ContentType; Log(TLogLevel.levNormal, Request.Method + ':' + Request.RawPathInfo + ' -> ' + lRouter.MVCControllerClass.QualifiedClassName + ' - ' + IntToStr(Response.StatusCode) + ' ' + Response.ReasonString) finally lSelectedController.Free; end; end else begin if Config[TMVCConfigKey.AllowUnhandledAction] = 'false' then // tristan begin Result := true; if not SendDocumentIndexIfPresent then // danieleteti begin Http404(lContext); Log(TLogLevel.levNormal, Request.Method + ':' + Request.RawPathInfo + ' -> NO ACTION ' + ' - ' + IntToStr(Response.StatusCode) + ' ' + Response.ReasonString); end; end else begin Result := false; lContext.Response.FlushOnDestroy := false; // tristan end; end; end; finally lRouter.Free; end; end; // end if IS_STATIC finally lContext.Free; end; finally lParamsTable.Free; end; // finally // LogExitMethod(Request.PathInfo + ' [' + IntToStr(Response.StatusCode) + ' ' + // Response.ReasonString + ']'); // end; end; procedure TMVCEngine.ExecuteAfterControllerActionMiddleware (Context: TWebContext; const aActionName: string; const Handled: Boolean); var I: Integer; begin for I := FMiddleware.Count - 1 downto 0 do begin FMiddleware[I].OnAfterControllerAction(Context, aActionName, Handled); end; end; procedure TMVCEngine.ExecuteBeforeControllerActionMiddleware (MVCEngine: TMVCEngine; Context: TWebContext; const AControllerQualifiedClassName: string; const aActionName: string; var Handled: Boolean); var LMiddleware: IMVCMiddleware; begin if not Handled then for LMiddleware in FMiddleware do begin LMiddleware.OnBeforeControllerAction(Context, AControllerQualifiedClassName, aActionName, Handled); if Handled then Break; end; end; procedure TMVCEngine.ExecuteBeforeRoutingMiddleware(Context: TWebContext; var Handled: Boolean); var middleware: IMVCMiddleware; begin if not Handled then for middleware in FMiddleware do begin middleware.OnBeforeRouting(Context, Handled); if Handled then Break; end; end; class function TMVCEngine.ExtractSessionIDFromWebRequest (AWebRequest: TWebRequest): string; begin Result := AWebRequest.CookieFields.Values[TMVCConstants.SESSION_TOKEN_NAME]; if not Result.IsEmpty then Result := TIdURI.URLDecode(Result); end; procedure TMVCEngine.FixUpWebModule; begin FSavedOnBeforeDispatch := FWebModule.BeforeDispatch; FWebModule.BeforeDispatch := OnBeforeDispatch; end; class function TMVCEngine.GetCurrentSession(ASessionTimeout: UInt64; const ASessionID: string; ARaiseExceptionIfExpired: Boolean): TWebSession; var // SessionID: string; List: TObjectDictionary; IsExpired: Boolean; begin List := SessionList; TMonitor.Enter(List); try Result := nil; // if ASessionID.IsEmpty then // raise EMVCException.Create('Empty SessionID'); { SESSION IS NOT AUTOCREATED BY DEFAULT } if not ASessionID.IsEmpty then begin IsExpired := true; if List.TryGetValue(ASessionID, Result) then begin IsExpired := MinutesBetween(Now, Result.LastAccess) > ASessionTimeout; // StrToInt(Config.Value['sessiontimeout']); end; if Assigned(Result) then begin if IsExpired then begin List.Remove(ASessionID); // remove expired session from session list if ARaiseExceptionIfExpired then raise EMVCSessionExpiredException.Create('Session expired') else Result := nil; end else begin Result.MarkAsUsed; end; end; end; finally TMonitor.Exit(List); end; end; function TMVCEngine.GetSessionBySessionID(const ASessionID: string) : TWebSession; begin Result := TMVCEngine.GetCurrentSession (StrToInt64(Config[TMVCConfigKey.SessionTimeout]), ASessionID, false); if Assigned(Result) then begin Result.MarkAsUsed; // TMVCEngine.SendSessionCookie(FContext, SessionID); end; end; procedure TMVCEngine.Http404(AWebContext: TWebContext); begin AWebContext.Response.StatusCode := 404; AWebContext.Response.ReasonString := 'Not Found'; AWebContext.Response.Content := 'Not Found'; end; procedure TMVCEngine.Http500(AWebContext: TWebContext; const AReasonText: string); begin AWebContext.Response.StatusCode := 500; AWebContext.Response.ReasonString := 'Internal server error: ' + AReasonText; AWebContext.Response.Content := 'Internal server error: ' + AReasonText; end; procedure TMVCEngine.LoadSystemControllers; begin Log(TLogLevel.levNormal, 'ENTER: LoadSystemControllers'); AddController(TMVCSystemController); if Config[TMVCConfigKey.Messaging].ToLower.Equals('true') then begin AddController(TMVCBUSController); Log(TLogLevel.levNormal, 'Loaded system controller ' + TMVCBUSController.QualifiedClassName); end; Log(TLogLevel.levNormal, 'EXIT: LoadSystemControllers'); end; procedure TMVCEngine.OnBeforeDispatch(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); begin Handled := false; if Assigned(FSavedOnBeforeDispatch) then FSavedOnBeforeDispatch(Sender, Request, Response, Handled); // _Request := Request as TIdHTTPAppRequest; if not Handled then begin try // "X-Requested-With", "XMLHttpRequest" Handled := ExecuteAction(Sender, Request, Response); // tristan except on E: Exception do begin LogException(E); // Response.ContentStream.Size := 0; Response.Content := E.Message; Response.SendResponse; Handled := true; end; end; // Handled := true; end; end; function TMVCEngine.RegisteredControllers: TObjectList; begin Result := FControllers; end; procedure TMVCEngine.ResponseErrorPage(E: Exception; Request: TWebRequest; Response: TWebResponse); begin Response.SetCustomHeader('x-mvc-error', E.ClassName + ': ' + E.Message); Response.StatusCode := 200; // if Pos('text/html', LowerCase(Request.Accept)) = 1 then // begin // Response.ContentType := 'text/plain'; // Response.Content := Config[TMVCConfigKey.ServerName] + ' ERROR:' + // sLineBreak + 'Exception raised of class: ' + E.ClassName + sLineBreak + // '***********************************************' + sLineBreak + E.Message // + sLineBreak + '***********************************************'; // end // else // Same code in if and else section begin Response.ContentType := 'text/plain'; Response.Content := Config[TMVCConfigKey.ServerName] + ' ERROR:' + sLineBreak + 'Exception raised of class: ' + E.ClassName + sLineBreak + '***********************************************' + sLineBreak + E.Message + sLineBreak + '***********************************************'; end; end; class function TMVCEngine.SendSessionCookie(AContext: TWebContext): string; var LSessionID: string; begin LSessionID := StringReplace (StringReplace(StringReplace(GUIDToString(TGUID.NewGuid), '}', '', []), '{', '', []), '-', '', [rfReplaceAll]); Result := SendSessionCookie(AContext, LSessionID); end; class function TMVCEngine.SendSessionCookie(AContext: TWebContext; const ASessionID: string): string; var Cookie: TCookie; LSessTimeout: Integer; begin ClearSessionCookiesAlreadySet(AContext.Response.Cookies); Cookie := AContext.Response.Cookies.Add; Cookie.Name := TMVCConstants.SESSION_TOKEN_NAME; Cookie.Value := ASessionID; LSessTimeout := StrToIntDef(AContext.Config[TMVCConfigKey.SessionTimeout], 0); if LSessTimeout = 0 then Cookie.Expires := 0 else Cookie.Expires := Now + OneMinute * LSessTimeout; Cookie.Path := '/'; Result := ASessionID; end; procedure TMVCEngine.SetApplicationSession(const Value: TWebApplicationSession); begin FApplicationSession := Value; end; { TWebContext } constructor TWebContext.Create(ARequest: TWebRequest; AResponse: TWebResponse; AConfig: TMVCConfig); begin inherited Create; FIsSessionStarted := false; FSessionMustBeClose := false; if IsLibrary then begin {$IF CompilerVersion >= 27} if ARequest is TApacheRequest then FRequest := TMVCApacheWebRequest.Create(ARequest) else if ARequest is TISAPIRequest then FRequest := TMVCISAPIWebRequest.Create(ARequest) else raise EMVCException.Create('Unknown request type ' + ARequest.ClassName); {$ELSE} FRequest := TMVCISAPIWebRequest.Create(ARequest) {$ENDIF} end else begin FRequest := TMVCINDYWebRequest.Create(ARequest); end; FResponse := TMVCWebResponse.Create(AResponse); FConfig := AConfig; FData := TDictionary.Create; FLoggedUser := TUser.Create; end; destructor TWebContext.Destroy; begin FreeAndNil(FResponse); FreeAndNil(FRequest); FreeAndNil(FData); FreeAndNil(FLoggedUser); // do not destroy session here... it is stored in the session list inherited; end; procedure TWebContext.Flush; begin FResponse.Flush; end; function TWebContext.GetData: TDictionary; begin Result := FData; end; function TWebContext.GetLoggedUser: TUser; begin if not Assigned(FLoggedUser) then begin FLoggedUser := TUser.Create; end; Result := FLoggedUser; end; function TWebContext.GetWebSession: TWebSession; begin if not Assigned(FWebSession) then begin FWebSession := TMVCEngine.GetCurrentSession (StrToInt64(FConfig[TMVCConfigKey.SessionTimeout]), TMVCEngine.ExtractSessionIDFromWebRequest(FRequest.RawWebRequest), false); if not Assigned(FWebSession) then SessionStart else begin TMVCEngine.SendSessionCookie(Self, FWebSession.SessionID); // daniele end; end; Result := FWebSession; Result.MarkAsUsed; { LSessionIDFromWebRequest := TMVCEngine.ExtractSessionIDFromWebRequest (Context.Request.RawWebRequest); LWebSession := TMVCEngine.GetCurrentSession (Context.Config.AsInt64[TMVCConfigKey.SessionTimeout], LSessionIDFromWebRequest, False); } end; function TWebContext.IsSessionStarted: Boolean; begin Result := FIsSessionStarted; end; procedure TWebContext.SetParams(AParamsTable: TMVCRequestParamsTable); begin FParamsTable := AParamsTable; FRequest.FParamsTable := AParamsTable; end; { TMVCWebResponse } constructor TMVCWebResponse.Create(AWebResponse: TWebResponse); begin FStreamOutputDone := false; FFlushOnDestroy := true; inherited Create; FWebResponse := AWebResponse; end; destructor TMVCWebResponse.Destroy; begin if FFlushOnDestroy then // tristan Flush; inherited; end; procedure TMVCWebResponse.Flush; begin try FWebResponse.SendResponse; // daniele except end; end; function TMVCWebResponse.GetContent: string; begin Result := FWebResponse.Content; end; function TMVCWebResponse.GetContentType: string; begin Result := FWebResponse.ContentType; end; function TMVCWebResponse.GetCookies: TCookieCollection; begin Result := Self.FWebResponse.Cookies; end; function TMVCWebResponse.GetCustomHeaders: TStrings; begin Result := FWebResponse.CustomHeaders; end; function TMVCWebResponse.GetLocation: string; begin Result := CustomHeaders.Values['location']; end; function TMVCWebResponse.GetReasonString: string; begin Result := FWebResponse.ReasonString; end; function TMVCWebResponse.GetStatusCode: Integer; begin Result := FWebResponse.StatusCode; end; procedure TMVCWebResponse.SendHeaders; begin FWebResponse.SendResponse end; procedure TMVCWebResponse.SetContent(const Value: string); begin FWebResponse.Content := Value; end; procedure TMVCWebResponse.SetContentStream(AStream: TStream; AContentType: string); begin FWebResponse.ContentType := AContentType; FWebResponse.ContentStream := AStream; end; procedure TMVCWebResponse.SetContentType(const Value: string); begin FWebResponse.ContentType := Value; end; procedure TMVCWebResponse.SetCustomHeader(const Name, Value: string); begin Self.FWebResponse.SetCustomHeader(name, Value); end; procedure TMVCWebResponse.SetLocation(const Value: string); begin CustomHeaders.Values['location'] := Value; end; procedure TMVCWebResponse.SetReasonString(const Value: string); begin FWebResponse.ReasonString := Value; end; procedure TMVCWebResponse.SetStatusCode(const Value: Integer); begin FWebResponse.StatusCode := Value; end; { TMVCWebRequest } function TMVCWebRequest.Accept: string; begin Result := Self.FWebRequest.Accept; end; function TMVCWebRequest.Body: string; {$IF CompilerVersion <= 27 } var InEnc: TEncoding; Buffer: TArray; I: Integer; {$ENDIF } begin if FBody <> '' then Exit(FBody); {$IF CompilerVersion > 29 } FWebRequest.ReadTotalContent; Exit(FWebRequest.Content); {$ELSE } // Property FWebRequest.Content is broken. It doesn't correctly decode the response body // considering the content charser. So, here's the fix // check http://msdn.microsoft.com/en-us/library/dd317756(VS.85).aspx if FCharset.IsEmpty then begin SetLength(Buffer, 10); for I := 0 to 9 do begin Buffer[I] := Byte(FWebRequest.RawContent[I]); end; TEncoding.GetBufferEncoding(Buffer, InEnc, TEncoding.Default); SetLength(Buffer, 0); end else begin InEnc := TEncoding.GetEncoding(FCharset); end; try SetLength(Buffer, FWebRequest.ContentLength); FWebRequest.ReadClient(Buffer[0], FWebRequest.ContentLength); FBody := InEnc.GetString(Buffer); Result := FBody; finally InEnc.Free; end {$ENDIF } end; function TMVCWebRequest.BodyAs(const RootProperty: string): T; var S: string; JObj: TJSONObject; begin if ContentType.Equals(TMVCMimeType.APPLICATION_JSON) then begin if RootProperty = '' then begin JObj := BodyAsJSONObject; if not Assigned(JObj) then raise EMVCException.Create('Invalid or not present JSON body'); Result := Mapper.JSONObjectToObject(JObj); end else begin S := Mapper.GetStringDef(BodyAsJSONObject, RootProperty, ''); if not S.IsEmpty then Result := Mapper.JSONObjectToObject(BodyAsJSONObject.Get(S) .JsonValue as TJSONObject) else raise EMVCException.CreateFmt('Body property %s not valid', [RootProperty]); end; end else raise EMVCException.CreateFmt('Body ContentType %s not supported', [ContentType]); end; function TMVCWebRequest.BodyAsJSONObject: TJSONObject; begin Result := BodyAsJSONValue as TJSONObject; end; function TMVCWebRequest.BodyAsJSONValue: TJSONValue; begin if not Assigned(FBodyAsJSONValue) then try FBodyAsJSONValue := TJSONObject.ParseJSONValue(Body); except FBodyAsJSONValue := nil; end; Result := FBodyAsJSONValue; end; function TMVCWebRequest.BodyAsListOf(const RootProperty: string) : TObjectList; var S: string; begin if ContentType.Equals(TMVCMimeType.APPLICATION_JSON) then begin if RootProperty = '' then Result := Mapper.JSONArrayToObjectList((BodyAsJSONValue as TJSONArray), false, true) // Ezequiel J. Müller (bug fix) else begin S := Mapper.GetStringDef(BodyAsJSONObject, RootProperty, ''); if not S.IsEmpty then Result := Mapper.JSONArrayToObjectList(BodyAsJSONObject.Get(S) .JsonValue as TJSONArray, false, true) // thank you Ezequiel J. Müller else raise EMVCException.CreateFmt('Body property %s not valid', [RootProperty]); end; end else raise EMVCException.CreateFmt('Body ContentType %s not supported', [ContentType]); end; function TMVCWebRequest.ClientIP: string; { This code has been converted to Delphi from a PHP code http://www.grantburton.com/2008/11/30/fix-for-incorrect-ip-addresses-in-wordpress-comments/ } var S: string; begin if FWebRequest.GetFieldByName('HTTP_CLIENT_IP') <> '' then Exit(FWebRequest.GetFieldByName('HTTP_CLIENT_IP')); for S in string(FWebRequest.GetFieldByName('HTTP_X_FORWARDED_FOR')) .Split([',']) do begin if not S.trim.IsEmpty then Exit(S.trim); end; if FWebRequest.GetFieldByName('HTTP_X_FORWARDED') <> '' then Exit(FWebRequest.GetFieldByName('HTTP_X_FORWARDED')); if FWebRequest.GetFieldByName('HTTP_X_CLUSTER_CLIENT_IP') <> '' then Exit(FWebRequest.GetFieldByName('HTTP_X_CLUSTER_CLIENT_IP')); if FWebRequest.GetFieldByName('HTTP_FORWARDED_FOR') <> '' then Exit(FWebRequest.GetFieldByName('HTTP_FORWARDED_FOR')); if FWebRequest.GetFieldByName('HTTP_FORWARDED') <> '' then Exit(FWebRequest.GetFieldByName('HTTP_FORWARDED')); if FWebRequest.GetFieldByName('REMOTE_ADDR') <> '' then Exit(FWebRequest.GetFieldByName('REMOTE_ADDR')); if FWebRequest.RemoteIP <> '' then Exit(FWebRequest.RemoteIP); if FWebRequest.RemoteAddr <> '' then Exit(FWebRequest.RemoteAddr); if FWebRequest.RemoteHost <> '' then Exit(FWebRequest.RemoteHost); if FWebRequest.RemoteAddr <> '' then Exit(FWebRequest.RemoteAddr); if FWebRequest.RemoteIP <> '' then Exit(FWebRequest.RemoteIP); if FWebRequest.RemoteHost <> '' then Exit(FWebRequest.RemoteHost); Result := ''; end; function TMVCWebRequest.ClientPrefer(MimeType: string): Boolean; begin Result := AnsiPos(MimeType, LowerCase(RawWebRequest.Accept)) = 1; end; function TMVCWebRequest.ContentParam(Name: string): string; begin Result := FWebRequest.ContentFields.Values[name]; end; function TMVCWebRequest.Cookie(Name: string): string; begin Result := FWebRequest.CookieFields.Values[name]; end; constructor TMVCWebRequest.Create(AWebRequest: TWebRequest); var CT: TArray; c: string; begin inherited Create; FBody := ''; c := AWebRequest.GetFieldByName('Content-Type'); if not c.IsEmpty then begin CT := c.Split([';']); FContentType := trim(CT[0]); FCharset := TMVCConstants.DEFAULT_CONTENT_CHARSET; // default charset if Length(CT) > 1 then begin if CT[1].trim.StartsWith('charset', true) then begin FCharset := CT[1].trim.Split(['='])[1].trim; end; end; end; // c := GetHeaderValue('content-encoding'); // if c.IsEmpty then // FContentEncoding := c; end; destructor TMVCWebRequest.Destroy; begin FreeAndNil(FBodyAsJSONValue); inherited; end; { TMVCAction } procedure TWebContext.BindToSession(SessionID: string); begin if not Assigned(FWebSession) then begin FWebSession := TMVCEngine.GetCurrentSession (StrToInt64(FConfig[TMVCConfigKey.SessionTimeout]), SessionID, false); if not Assigned(FWebSession) then raise EMVCException.Create('Invalid SessionID'); FWebSession.MarkAsUsed; TMVCEngine.SendSessionCookie(Self, SessionID); end else raise EMVCException.Create('Session already bounded for this request'); end; constructor TMVCController.Create; begin inherited Create; FContentCharset := TMVCConstants.DEFAULT_CONTENT_CHARSET; end; destructor TMVCController.Destroy; begin FreeAndNil(FResponseStream); FreeAndNil(FViewDataSets); FreeAndNil(FViewModel); inherited; end; procedure TMVCController.EnqueueMessageOnTopicOrQueue(const IsQueue: Boolean; const ATopic: string; AJSONObject: TJSONObject; aOwnsInstance: Boolean); var Stomp: IStompClient; H: IStompHeaders; msg: TJSONObject; begin msg := TJSONObject.Create; try if aOwnsInstance then msg.AddPair('message', AJSONObject) else msg.AddPair('message', AJSONObject.Clone as TJSONObject); if IsQueue then msg.AddPair('_queue', ATopic) else msg.AddPair('_topic', ATopic); msg.AddPair('_username', GetClientID).AddPair('_timestamp', FormatDateTime('YYYY-MM-DD HH:NN:SS', Now)); Stomp := GetNewStompClient(GetClientID); H := StompUtils.NewHeaders.Add(TStompHeaders.NewPersistentHeader(true)); {$IF CompilerVersion >= 28} Stomp.Send(ATopic, msg.ToJSON); {$ELSE} Stomp.Send(ATopic, msg.ToString); {$ENDIF} TThread.Sleep(100); // single user cannot enqueue more than 10 message in noe second... // it is noot too much elegant, but it works as DoS protection finally msg.Free; end; end; function TMVCController.GetClientID: string; begin Result := Session[CLIENTID_KEY]; if Result.IsEmpty then // if Result.IsEmpty then raise EMVCException.Create('Invalid ClientID' + sLineBreak + 'Hint: Messaging extensions require a valid clientid. Did you call /messages/clients/YOUR_CLIENT_ID ?'); end; function TMVCController.GetContentCharset: string; begin Result := FContentCharset; end; function TMVCController.GetContentType: string; begin Result := FContext.Response.ContentType; end; function TMVCController.GetCurrentWebModule: TWebModule; begin Result := GetMVCEngine.Owner as TWebModule; end; function TMVCController.GetNewStompClient(ClientID: string): IStompClient; begin raise EMVCException.Create('Not Implemented'); // Result := StompUtils.NewStomp(Config[TMVCConfigKey.StompServer], // StrToInt(Config[TMVCConfigKey.StompServerPort]), GetClientID, // Config[TMVCConfigKey.StompUsername], Config[TMVCConfigKey.StompPassword]); end; function TMVCController.GetRenderedView(const ViewNames : TArray): string; var View: TMVCMustacheView; LViewName: string; LSBuilder: TStringBuilder; begin LSBuilder := TStringBuilder.Create; try try for LViewName in ViewNames do begin View := TMVCMustacheView.Create(LViewName, GetMVCEngine, FContext, FViewModel, FViewDataSets, ContentType); try View.SetMVCConfig(GetMVCConfig); View.Execute; LSBuilder.Append(View.GetOutput); finally View.Free; end; end; Result := LSBuilder.ToString; except on E: Exception do begin ContentType := 'text/plain'; Render(E); end; end; finally LSBuilder.Free; end; end; function TMVCController.GetWebSession: TWebSession; begin Result := FContext.Session; end; function TMVCController.LoadView(const ViewNames: TArray): string; begin try Result := GetRenderedView(ViewNames); ResponseStream.Append(Result); except on E: Exception do begin LogException(E); ContentType := 'text/plain'; Render(E); end; end; end; procedure TMVCController.LoadViewFragment(const ViewFragment: string); begin ResponseStream.Append(ViewFragment); end; procedure TMVCController.MVCControllerAfterCreate; begin inherited; end; procedure TMVCController.MVCControllerBeforeDestroy; begin inherited; end; procedure TMVCController.OnAfterAction(Context: TWebContext; const aActionName: string); begin // do nothing end; procedure TMVCController.OnBeforeAction(Context: TWebContext; const aActionName: string; var Handled: Boolean); begin Handled := false; if ContentType.IsEmpty then ContentType := GetMVCConfig[TMVCConfigKey.DefaultContentType]; end; procedure TMVCController.PushDataSetToView(const AModelName: string; aDataSet: TDataSet); var LJArr: TJSONArray; begin LJArr := TJSONArray.Create; try Mapper.DataSetToJSONArray(aDataSet, LJArr, true); except LJArr.Free; raise; end; PushJSONToView(AModelName, LJArr); end; procedure TMVCController.PushJSONToView(const AModelName: string; AModel: TJSONValue); begin if not Assigned(FViewModel) then FViewModel := TMVCDataObjects.Create; FViewModel.Add(AModelName, AModel); end; procedure TMVCController.PushObjectToView(const AModelName: string; AModel: TObject); begin PushJSONToView(AModelName, Mapper.ObjectToJSONObject(AModel)); end; procedure InternalRenderText(const AContent: string; ContentType, ContentEncoding: string; Context: TWebContext); var OutEncoding: TEncoding; begin Context.Response.RawWebResponse.ContentType := ContentType + '; charset=' + ContentEncoding; OutEncoding := TEncoding.GetEncoding(ContentEncoding); try // Context.Response.RawWebResponse.ContentStream := TStringStream.Create(UTF8Encode(AContent)); if SameText('UTF-8', ContentEncoding) then begin Context.Response.RawWebResponse.Content := ''; Context.Response.RawWebResponse.ContentStream := TStringStream.Create(UTF8Encode(AContent)); end else begin Context.Response.RawWebResponse.Content := OutEncoding.GetString(TEncoding.Convert(TEncoding.UTF8, OutEncoding, TEncoding.Default.GetBytes(AContent))); end; finally OutEncoding.Free; end; // Context.Response.RawWebResponse.ContentType := TMVCMimeType.APPLICATION_JSON; // Context.Response.RawWebResponse.ContentEncoding := ContentEncoding; // OutEncoding := TEncoding.GetEncoding(ContentEncoding); // InEncoding := TEncoding.Default; // GetEncoding(S); // Context.Response.Content := OutEncoding.GetString // (TEncoding.Convert(InEncoding, OutEncoding, InEncoding.GetBytes(AContent))); // OutEncoding.Free; end; procedure InternalRender(aJSONValue: TJSONValue; ContentType, ContentEncoding: string; Context: TWebContext; aInstanceOwner: Boolean); var OutEncoding: TEncoding; JString: string; begin {$IF CompilerVersion <= 27} JString := aJSONValue.ToString; // requires the patch {$ELSE} JString := aJSONValue.ToJSON; // since XE7 it works using ToJSON {$ENDIF} // first set the ContentType; because of this bug: // http://qc.embarcadero.com/wc/qcmain.aspx?d=67350 Context.Response.RawWebResponse.ContentType := ContentType + '; charset=' + ContentEncoding; OutEncoding := TEncoding.GetEncoding(ContentEncoding); try Context.Response.RawWebResponse.Content := OutEncoding.GetString(TEncoding.Convert(TEncoding.Default, OutEncoding, TEncoding.Default.GetBytes(JString))); finally OutEncoding.Free; end; if aInstanceOwner then FreeAndNil(aJSONValue) end; procedure InternalRender(const Content: string; ContentType, ContentEncoding: string; Context: TWebContext); begin if ContentType = TMVCMimeType.APPLICATION_JSON then begin InternalRender(TJSONString.Create(Content), ContentType, ContentEncoding, Context, true); end else if ContentType = TMVCMimeType.TEXT_XML then begin raise EMVCException.Create('Format still not supported - ' + ContentType); end else begin if ContentType.IsEmpty then InternalRenderText(Content, 'text/plain', ContentEncoding, Context) else InternalRenderText(Content, ContentType, ContentEncoding, Context); end; end; procedure TMVCController.RenderResponseStream; begin InternalRenderText(ResponseStream.ToString, ContentType, ContentCharset, Context); end; procedure TMVCController.Render(const Content: string); begin InternalRender(Content, ContentType, ContentCharset, Context); end; procedure TMVCController.Render(aObject: TObject; aInstanceOwner: Boolean; aSerializationType: TDMVCSerializationType); var JSON: TJSONObject; begin if aSerializationType = TDMVCSerializationType.Properties then JSON := Mapper.ObjectToJSONObject(aObject) else JSON := Mapper.ObjectToJSONObjectFields(aObject, []); Render(JSON, true); if aInstanceOwner then FreeAndNil(aObject); end; procedure TMVCController.SendFile(AFileName: string); begin TMVCStaticContents.SendFile(AFileName, ContentType, Context); end; function TWebContext.SendSessionCookie(AContext: TWebContext): string; begin Result := TMVCEngine.SendSessionCookie(Self); end; procedure TMVCController.SendStream(AStream: TStream; AOwnStream: Boolean); begin FContext.Response.FWebResponse.Content := ''; // FContext.Response.SetContentStream(AStream, ContentType); FContext.Response.FWebResponse.ContentType := ContentType; FContext.Response.FWebResponse.ContentStream := AStream; FContext.Response.FWebResponse.FreeContentStream := AOwnStream; end; function TWebContext.SessionID: string; begin if Assigned(FWebSession) then Exit(FWebSession.SessionID); Result := FRequest.Cookie(TMVCConstants.SESSION_TOKEN_NAME); end; function TWebContext.SessionMustBeClose: Boolean; begin Result := FSessionMustBeClose; end; procedure TWebContext.SessionStart; var LSessionID: string; begin if not Assigned(FWebSession) then begin LSessionID := TMVCEngine.SendSessionCookie(Self); FWebSession := TMVCEngine.AddSessionToTheSessionList(LSessionID, StrToInt64(Config[TMVCConfigKey.SessionTimeout])); FIsSessionStarted := true; FSessionMustBeClose := false; end; end; function TWebContext.SessionStarted: Boolean; var LSessionID: string; begin LSessionID := SessionID; if LSessionID.IsEmpty then Exit(false); TMonitor.Enter(SessionList); try Result := SessionList.ContainsKey(LSessionID); finally TMonitor.Exit(SessionList); end; end; procedure TWebContext.SessionStop(ARaiseExceptionIfExpired: Boolean); var Cookie: TCookie; LSessionID: string; begin // Set-Cookie: token=deleted; path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT FResponse.Cookies.Clear; // daniele ... remove all previous cookies Cookie := FResponse.Cookies.Add; Cookie.Name := TMVCConstants.SESSION_TOKEN_NAME; // rubbish... invalid the cookie value Cookie.Value := GUIDToString(TGUID.NewGuid) + 'invalid' + GUIDToString(TGUID.NewGuid); Cookie.Expires := EncodeDate(1970, 1, 1); Cookie.Path := '/'; TMonitor.Enter(SessionList); try LSessionID := TMVCEngine.ExtractSessionIDFromWebRequest (FRequest.RawWebRequest); // if not Assigned(FWebSession) then // FWebSession := TMVCEngine.GetCurrentSession // (StrToInt64(FConfig[TMVCConfigKey.SessionTimeout]), '', // ARaiseExceptionIfExpired); // if Assigned(FWebSession) then SessionList.Remove(LSessionID); finally TMonitor.Exit(SessionList); end; FIsSessionStarted := false; FSessionMustBeClose := true; end; procedure TMVCController.SetContentCharset(const Value: string); begin FContentCharset := Value; end; procedure TMVCController.SetContentType(const Value: string); begin FContext.Response.ContentType := Value; end; procedure TMVCController.SetContext(const Value: TWebContext); begin if FContext = nil then FContext := Value else raise EMVCException.Create('Context already set'); end; // procedure TMVCController.SetViewCache(const Value: TViewCache); // begin // FViewCache := Value; // end; procedure TMVCController.SetWebSession(const Value: TWebSession); begin raise Exception.Create('Qualcuno mi usa...'); // if Assigned(FContext.FWebSession) then // raise EMVCException.Create('Web Session already set for controller ' + // ClassName); // FContext.FWebSession := Value; // FIsSessionStarted := Assigned(FContext.FWebSession); end; { TMVCPathAttribute } constructor MVCPathAttribute.Create(const Value: string); begin inherited Create; FPath := Value; end; function TMVCWebRequest.QueryStringParams: TStrings; begin Result := FWebRequest.QueryFields; end; function TMVCWebRequest.QueryStringParam(Name: string): string; begin Result := FWebRequest.QueryFields.Values[name]; end; procedure TMVCWebRequest.EnsureQueryParamExists(const Name: string); begin if GetParamAll(name).IsEmpty then raise EMVCException.CreateFmt('Parameter "%s" required', [name]); end; function TMVCWebRequest.QueryStringParamExists(Name: string): Boolean; begin Result := not QueryStringParam(name).IsEmpty; end; function TMVCWebRequest.GetClientPreferHTML: Boolean; begin Result := ClientPrefer(TMVCMimeType.TEXT_HTML); end; function TMVCWebRequest.GetFiles: TAbstractWebRequestFiles; begin Result := FWebRequest.Files; end; function TMVCWebRequest.GetHeader(const Name: string): string; begin if Assigned(FWebRequest) then Result := FWebRequest.GetFieldByName(name) else Result := ''; end; // function TMVCWebRequest.GetHeaderValue(const Name: string): string; // var // S: string; // begin // S := GetHeader(name); // if S.IsEmpty then // Result := '' // else // Result := S.Split([':'])[1].trim; // end; // function TMVCWebRequest.GetHeaderAll(const HeaderName: string): string; // begin // Result := Self.FWebRequest.GetFieldByName(HeaderName); // end; function TMVCWebRequest.GetHTTPMethod: TMVCHTTPMethodType; begin Result := TMVCRouter.StringMethodToHTTPMetod(FWebRequest.Method); end; function TMVCWebRequest.GetHTTPMethodAsString: string; begin Result := FWebRequest.Method; end; function TMVCWebRequest.GetIsAjax: Boolean; begin Result := LowerCase(FWebRequest.GetFieldByName('X-Requested-With')) = 'xmlhttprequest'; end; function TMVCWebRequest.GetSegmentParam(const ParamName: string; out Value: string): Boolean; begin if (not Assigned(FParamsTable)) then Exit(false); Result := FParamsTable.TryGetValue(ParamName, Value); end; function TMVCWebRequest.GetSegmentParamsCount: Integer; begin if Assigned(FParamsTable) then Result := FParamsTable.Count else Result := 0; end; function TMVCWebRequest.GetParamAll(const ParamName: string): string; begin if (not Assigned(FParamsTable)) or (not FParamsTable.TryGetValue(ParamName, Result)) then begin Result := FWebRequest.QueryFields.Values[ParamName]; if Result = EmptyStr then Result := FWebRequest.ContentFields.Values[ParamName]; if Result = EmptyStr then Result := FWebRequest.CookieFields.Values[ParamName]; end; end; function TMVCWebRequest.GetParamAllAsInt64(const ParamName: string): Int64; begin Result := StrToInt64(GetParamAll(ParamName)); end; function TMVCWebRequest.GetParamAllAsInteger(const ParamName: string): Integer; begin Result := StrToInt(GetParamAll(ParamName)); end; function TMVCWebRequest.GetParamNames: TArray; var I: Integer; Names: TList; n: string; begin if Length(FParamNames) > 0 then Exit(FParamNames); Names := TList.Create; try if Assigned(FParamsTable) and (Length(FParamsTable.Keys.ToArray) > 0) then for n in FParamsTable.Keys.ToArray do Names.Add(n); if FWebRequest.QueryFields.Count > 0 then for I := 0 to FWebRequest.QueryFields.Count - 1 do Names.Add(FWebRequest.QueryFields.Names[I]); if FWebRequest.ContentFields.Count > 0 then for I := 0 to FWebRequest.ContentFields.Count - 1 do Names.Add(FWebRequest.ContentFields.Names[I]); if FWebRequest.CookieFields.Count > 0 then for I := 0 to FWebRequest.CookieFields.Count - 1 do Names.Add(FWebRequest.CookieFields.Names[I]); Result := Names.ToArray; finally Names.Free; end; end; function TMVCWebRequest.GetPathInfo: string; begin Result := FWebRequest.PathInfo; end; procedure TMVCWebRequest.SetParamsTable(AParamsTable: TMVCRequestParamsTable); begin FParamsTable := AParamsTable; end; function TMVCWebRequest.ThereIsRequestBody: Boolean; begin Result := FWebRequest.Content <> ''; end; { MVCHTTPMethodAttribute } constructor MVCHTTPMethodAttribute.Create(AMVCHTTPMethods: TMVCHTTPMethods); begin inherited Create; FMVCHTTPMethods := AMVCHTTPMethods; end; function MVCHTTPMethodAttribute.GetMVCHTTPMethodsAsString: string; var I: TMVCHTTPMethodType; begin Result := ''; for I := low(TMVCHTTPMethodType) to high(TMVCHTTPMethodType) do begin if I in FMVCHTTPMethods then begin Result := Result + ',' + GetEnumName (TypeInfo(TMVCHTTPMethodType), Ord(I)); end; end; if not Result.IsEmpty then Result := Result.Remove(0, 1) else Result := 'any'; end; { TMVCStaticContents } class procedure TMVCStaticContents.SendFile(AFileName, AMimeType: string; Context: TWebContext); var LFileDate: TDateTime; LReqDate: TDateTime; S: TFileStream; begin LFileDate := IndyFileAge(AFileName); if (LFileDate = 0.0) and (not FileExists(AFileName)) then begin Context.Response.StatusCode := 404; end else begin LReqDate := GMTToLocalDateTime(Context.Request.Headers ['If-Modified-Since']); if (LReqDate <> 0) and (abs(LReqDate - LFileDate) < 2 * (1 / (24 * 60 * 60))) then begin Context.Response.ContentType := AMimeType; Context.Response.StatusCode := 304; end else begin S := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone); // Content-Length is set in (%DELPHI%)\source\internet\Web.Win.IsapiHTTP.pas // procedure TISAPIResponse.SendResponse; // if set twice it could be a problem under IIS (ISAPI) // the header is available 1x but the value are doubled // sometimes some images are not shown // How to unittest this behavior? // Context.Response.SetCustomHeader('Content-Length', IntToStr(S.Size)); Context.Response.SetCustomHeader('Last-Modified', LocalDateTimeToHttpStr(LFileDate)); Context.Response.SetContentStream(S, AMimeType); end; end; end; class function TMVCStaticContents.IsScriptableFile(StaticFileName: string; Config: TMVCConfig): Boolean; begin Result := TPath.GetExtension(StaticFileName).ToLower = '.' + Config[TMVCConfigKey.DefaultViewFileExtension].ToLower; end; class function TMVCStaticContents.IsStaticFile(AViewPath, AWebRequestPath : string; out ARealFileName: string): Boolean; var FileName: string; begin if TDirectory.Exists(AViewPath) then // absolute path FileName := AViewPath + AWebRequestPath.Replace('/', TPath.DirectorySeparatorChar) else FileName := GetApplicationFileNamePath + AViewPath + // relative path AWebRequestPath.Replace('/', TPath.DirectorySeparatorChar); Result := TFile.Exists(FileName); ARealFileName := FileName; end; procedure TMVCBase.SetApplicationSession(const Value: TWebApplicationSession); begin if Assigned(FApplicationSession) then raise EMVCException.Create('Application Session already set'); FApplicationSession := Value; end; procedure TMVCBase.SetMVCConfig(const Value: TMVCConfig); begin FMVCConfig := Value; end; procedure TMVCBase.SetMVCEngine(const Value: TMVCEngine); begin FMVCEngine := Value; end; class function TMVCBase.GetApplicationFileName: string; var fname: PChar; Size: Integer; begin Result := ''; fname := GetMemory(2048); try Size := GetModuleFileName(0, fname, 2048); if Size > 0 then Result := fname; finally FreeMem(fname, 2048); end; end; class function TMVCBase.GetApplicationFileNamePath: string; begin Result := IncludeTrailingPathDelimiter (ExtractFilePath(GetApplicationFileName)); end; function TMVCBase.GetMVCConfig: TMVCConfig; begin if not Assigned(FMVCConfig) then EMVCConfigException.Create('MVCConfig not assigned to this ' + ClassName + ' instances'); Result := FMVCConfig; end; function TMVCBase.GetMVCEngine: TMVCEngine; begin Result := FMVCEngine; end; { TMVCISAPIWebRequest } constructor TMVCISAPIWebRequest.Create(AWebRequest: TWebRequest); begin inherited; FWebRequest := AWebRequest as TISAPIRequest; end; { TMVCApacheWebRequest } {$IF CompilerVersion >= 27} constructor TMVCApacheWebRequest.Create(AWebRequest: TWebRequest); begin inherited; FWebRequest := AWebRequest as TApacheRequest; end; {$ENDIF} { TMVCINDYWebRequest } constructor TMVCINDYWebRequest.Create(AWebRequest: TWebRequest); begin inherited; FWebRequest := AWebRequest; // as TIdHTTPAppRequest; end; { TWebSession } procedure TMVCController.RaiseSessionExpired; begin raise EMVCSessionExpiredException.Create('Session expired'); end; function TMVCController.ReceiveMessageFromTopic(const ATopic: string; ATimeout: Int64; var JSONObject: TJSONObject): Boolean; var Stomp: IStompClient; frame: IStompFrame; o: TJSONValue; begin Result := false; Stomp := GetNewStompClient(GetClientID); if not Stomp.Receive(frame, ATimeout) then JSONObject := nil else begin o := TJSONObject.ParseJSONValue(frame.GetBody); if not Assigned(o) then raise EMVCException.Create('Message is not a valid JSONObject') else begin if not(o is TJSONObject) then begin FreeAndNil(o); raise EMVCException.Create ('Message is a JSONValue but not a JSONObject') end else JSONObject := TJSONObject(o); end; end; end; procedure TMVCController.Redirect(const URL: string); begin FContext.Response.FWebResponse.SendRedirect(URL); end; procedure TMVCController.Render(E: Exception; ErrorItems: TList); var j: TJSONObject; S: string; jarr: TJSONArray; begin if E is EMVCException then ResponseStatusCode(EMVCException(E).HTTPErrorCode, E.Message + ' [' + E.ClassName + ']') else begin if Context.Response.StatusCode = 200 then ResponseStatusCode(500, E.Message + ' [' + E.ClassName + ']'); end; if (not Context.Request.IsAjax) and (Context.Request.ClientPreferHTML) then begin ContentType := TMVCMimeType.TEXT_HTML; ContentCharset := TMVCConstants.DEFAULT_CONTENT_CHARSET; ResponseStream.Clear; ResponseStream.Append ('') .Append('

' + Config[TMVCConfigKey.ServerName] + ': Error Raised

') .AppendFormat('
HTTP Return Code: %d' + sLineBreak,
      [Context.Response.StatusCode])
      .AppendFormat('HTTP Reason Text: "%s"
', [Context.Response.ReasonString]).Append('

')
      .AppendFormat('Exception Class Name : %s' + sLineBreak, [E.ClassName])
      .AppendFormat('Exception Message    : %s' + sLineBreak, [E.Message])
      .Append('

'); if Assigned(ErrorItems) and (ErrorItems.Count > 0) then begin ResponseStream.Append('

');
      for S in ErrorItems do
        ResponseStream.AppendLine('- ' + S);
      ResponseStream.Append('

'); end else begin ResponseStream.AppendLine('
No other informations available
'); end; ResponseStream.Append(''); Render; end else if Context.Request.IsAjax or (ContentType = 'application/json') then begin j := TJSONObject.Create; j.AddPair('status', 'error'); j.AddPair('classname', E.ClassName); j.AddPair('message', E.Message); j.AddPair('http_error', TJSONNumber.Create(Context.Response.StatusCode)); if Assigned(ErrorItems) then begin jarr := TJSONArray.Create; j.AddPair('erroritems', jarr); for S in ErrorItems do begin jarr.AddElement(TJSONString.Create(S)); end; end; Render(j); end else begin Render(Format('Exception: [%s] %s', [E.ClassName, E.Message])); end; end; procedure TMVCController.Render(const aErrorCode: UInt16; const aErrorMessage: string; const AErrorClassName: string = ''); var j: TJSONObject; status: string; begin ResponseStatusCode(aErrorCode, aErrorMessage); if Context.Request.IsAjax or (ContentType = 'application/json') then begin status := 'error'; if (aErrorCode div 100) = 2 then status := 'ok'; j := TJSONObject.Create; j.AddPair('status', status); if AErrorClassName = '' then j.AddPair('classname', TJSONNull.Create) else j.AddPair('classname', AErrorClassName); j.AddPair('message', aErrorMessage); Render(j); end else begin Render(Format('Error: [%d] %s', [aErrorCode, aErrorMessage])); end; end; procedure TMVCController.Render(aDataSet: TDataSet; aInstanceOwner: Boolean; aOnlySingleRecord: Boolean; aJSONObjectActionProc: TJSONObjectActionProc); var arr: TJSONArray; JObj: TJSONObject; begin if ContentType = TMVCMimeType.APPLICATION_JSON then begin if not aOnlySingleRecord then begin aDataSet.First; arr := TJSONArray.Create; Mapper.DataSetToJSONArray(aDataSet, arr, aInstanceOwner, aJSONObjectActionProc); Render(arr); end else begin JObj := TJSONObject.Create; Mapper.DataSetToJSONObject(aDataSet, JObj, aInstanceOwner, aJSONObjectActionProc); Render(JObj); end; end else raise Exception.Create('ContentType not supported for this render [' + ContentType + ']'); // if ContentType = TMVCMimeType.TEXT_XML then // begin // Mapper.DataSetToXML(ADataSet, S, AInstanceOwner); // Render(S); // end; end; procedure TMVCController.Render(const AStream: TStream; aInstanceOwner: Boolean); begin SendStream(AStream, aInstanceOwner); end; procedure TMVCController.RenderWrappedList(aList: IWrappedList; aJSONObjectActionProc: TJSONObjectActionProc = nil; aSerializationType: TDMVCSerializationType = TDMVCSerializationType. Properties); var JSON: TJSONArray; begin if aSerializationType = TSerializationType.Properties then JSON := Mapper.ObjectListToJSONArray(aList, true, aJSONObjectActionProc) else JSON := Mapper.ObjectListToJSONArrayFields(aList, true, aJSONObjectActionProc); Render(JSON, true); end; procedure TMVCController.Render(aCollection: TObjectList; aInstanceOwner: Boolean; aJSONObjectActionProc: TJSONObjectActionProc; aSerializationType: TSerializationType); var JSON: TJSONArray; begin if aSerializationType = TSerializationType.Properties then JSON := Mapper.ObjectListToJSONArray(aCollection, false, aJSONObjectActionProc) else JSON := Mapper.ObjectListToJSONArrayFields(aCollection, false, aJSONObjectActionProc); Render(JSON, true); if aInstanceOwner then FreeAndNil(aCollection); end; procedure TMVCController.RenderJSONArrayAsProperty(const aPropertyName: string; AJSONArray: TJSONArray); begin Render(TJSONObject.Create(TJSONPair.Create(aPropertyName, AJSONArray))); end; procedure TMVCController.RenderListAsProperty(const aPropertyName: string; aObjectList: TObjectList; aOwnsInstance: Boolean; aJSONObjectActionProc: TJSONObjectActionProc); begin Render(TJSONObject.Create(TJSONPair.Create(aPropertyName, Mapper.ObjectListToJSONArray(aObjectList, aOwnsInstance, aJSONObjectActionProc)))); end; procedure TMVCController.RenderStreamAndFree(const AStream: TStream); begin SendStream(AStream); end; procedure TMVCController.Render(aTextWriter: TTextWriter; aInstanceOwner: Boolean); begin InternalRenderText(aTextWriter.ToString, ContentType, ContentCharset, Context); end; procedure TMVCController.Render(aJSONValue: TJSONValue; aInstanceOwner: Boolean); begin InternalRender(aJSONValue, ContentType, ContentCharset, Context, aInstanceOwner); end; procedure TMVCController.ResponseStatusCode(const AStatusCode: UInt16; AStatusText: string); begin Context.Response.StatusCode := AStatusCode; Context.Response.ReasonString := AStatusText; end; function TMVCController.ResponseStream: TStringBuilder; begin if not Assigned(FResponseStream) then FResponseStream := TStringBuilder.Create; Result := FResponseStream; end; constructor MVCPathAttribute.Create; begin Create(''); end; procedure TMVCController.Render(const aErrorCode: UInt16; aJSONValue: TJSONValue; aInstanceOwner: Boolean); begin ResponseStatusCode(aErrorCode); if ContentType = 'application/json' then begin Render(aJSONValue, aInstanceOwner); end else begin raise EMVCException.Create ('Cannot render a JSONValue if ContentType is not application/json'); end; end; procedure TMVCController.Render(const aErrorCode: UInt16; aObject: TObject; aInstanceOwner: Boolean); begin Render(aErrorCode, Mapper.ObjectToJSONObject(aObject), true); if aInstanceOwner then aObject.Free; end; procedure TMVCController.Render; begin RenderResponseStream; end; { MVCStringAttribute } constructor MVCStringAttribute.Create(const Value: string); begin inherited Create; FValue := Value; end; function IsShuttingDown: Boolean; begin Result := TInterlocked.Read(_IsShuttingDown) = 1 end; procedure EnterInShutdownState; begin TInterlocked.Add(_IsShuttingDown, 1); end; { MVCProduceAttribute } constructor MVCProducesAttribute.Create(const Value, ProduceEncoding: string); begin Create(Value); FProduceEncoding := ProduceEncoding; end; constructor MVCProducesAttribute.Create(const Value: string); begin inherited; FProduceEncoding := 'UTF-8'; end; procedure MVCProducesAttribute.SetProduceEncoding(const Value: string); begin FProduceEncoding := Value; end; { TUser } procedure TUser.Clear; begin FUserName := ''; FLoggedSince := 0; FRealm := ''; FRoles.Clear; end; constructor TUser.Create; begin inherited; FRoles := TList.Create; Clear; end; destructor TUser.Destroy; begin FRoles.Free; inherited; end; function TUser.GetIsValidLoggedUser: Boolean; begin Result := (not UserName.IsEmpty) and (LoggedSince > 0); end; function TUser.LoadFromSession(AWebSession: TWebSession): Boolean; var LSerObj: string; LPieces: TArray; I: Integer; begin if not Assigned(AWebSession) then Exit(false); LSerObj := AWebSession[TMVCConstants.CURRENT_USER_SESSION_KEY]; Result := not LSerObj.IsEmpty; if Result then begin Clear; LPieces := LSerObj.Split(['$$'], TStringSplitOptions.None); UserName := LPieces[0]; LoggedSince := ISOStrToDateTime(LPieces[1]); Realm := LPieces[2]; Roles.Clear; for I := 2 to Length(LPieces) - 1 do begin Roles.Add(LPieces[I]); end; end; end; procedure TUser.SaveToSession(AWebSession: TWebSession); var LRoles: string; begin if FRoles.Count > 0 then // bug in string.Join LRoles := string.Join('$$', FRoles.ToArray) else LRoles := ''; AWebSession[TMVCConstants.CURRENT_USER_SESSION_KEY] := FUserName + '$$' + ISODateTimeToString(FLoggedSince) + '$$' + FRealm + '$$' + LRoles; end; procedure TUser.SetLoggedSince(const Value: TDateTime); begin if FLoggedSince = 0 then FLoggedSince := Value else raise EMVCException.Create('User.LoggedSince already set'); end; procedure TUser.SetRealm(const Value: string); begin FRealm := Value; end; procedure TUser.SetUserName(const Value: string); begin FUserName := Value; end; { TMVCControllerRoutable } constructor TMVCControllerRoutable.Create(AClass: TMVCControllerClass; ADelegate: TMVCControllerDelegate); begin FClass := AClass; FDelegate := ADelegate; end; initialization _IsShuttingDown := 0; end.