/// generate cross-platform clients code and documentation from a mORMot server // - this unit is a part of the freeware Synopse mORMot framework, // licensed under a MPL/GPL/LGPL tri-license; version 1.18 unit mORMotWrappers; { This file is part of Synopse mORMot framework. Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** Version: MPL 1.1/GPL 2.0/LGPL 2.1 The contents of this file are subject to the Mozilla Public License Version 1.1 (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.mozilla.org/MPL Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is Synopse mORMot framework. The Initial Developer of the Original Code is Arnaud Bouchez. Portions created by the Initial Developer are Copyright (C) 2020 the Initial Developer. All Rights Reserved. Contributor(s) (for this unit and the .mustache templates): - EMartin - Sabbiolina - Sevo - Stefan Diestelmann Alternatively, the contents of this file may be used under the terms of either the GNU General Public License Version 2 or later (the "GPL"), or the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), in which case the provisions of the GPL or the LGPL are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of either the GPL or the LGPL, and not to allow others to use your version of this file under the terms of the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the GPL or the LGPL. If you do not delete the provisions above, a recipient may use your version of this file under the terms of any one of the MPL, the GPL or the LGPL. ***** END LICENSE BLOCK ***** } {$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER interface uses {$ifdef ISDELPHIXE2}System.SysUtils,{$else}SysUtils,{$endif} Classes, Contnrs, Variants, SynCommons, SynTable, mORMot, SynLZ, SynMustache; /// compute the Model information, ready to be exported as JSON // - will publish the ORM and SOA properties // - to be used e.g. for client code generation via Mustache templates // - optional aSourcePath parameter may be used to retrieve additional description // from the comments of the source code of the unit - this text content may // also be injected by WRAPPER_RESOURCENAME // - you may specify a description file (as generated by FillDescriptionFromSource) function ContextFromModel(aServer: TSQLRestServer; const aSourcePath: TFileName=''; const aDescriptions: TFileName=''): variant; /// compute the information of an interface method, ready to be exported as JSON // - to be used e.g. for the implementation of the MVC controller via interfaces // - no description text will be included - use ContextFromModel() if needed function ContextFromMethod(const method: TServiceMethod): variant; /// compute the information of an interface, ready to be exported as JSON // - to be used e.g. for the implementation of the MVC controller via interfaces // - no description text will be included - use ContextFromModel() if needed function ContextFromMethods(int: TInterfaceFactory): variant; /// generate a code/doc wrapper for a given Model and Mustache template content // - will use all ORM and SOA properties of the supplied server // - aFileName will be transmitted as {{filename}}, e.g. 'mORMotClient' // - you should also specify a "fake" HTTP port e.g. 888 // - the template content could be retrieved from a file via StringFromFile() // - you may optionally retrieve a copy of the data context as TDocVariant // - this function may be used to generate the client at build time, directly // from a just built server, in an automated manner // - you may specify custom helpers (e.g. via TSynMustache.HelpersGetStandardList) // and retrieve the generated data context after generation (if aContext is // a TDocVariant object, its fields would be added to the rendering context), // or a custom description file (as generated by FillDescriptionFromSource) function WrapperFromModel(aServer: TSQLRestServer; const aMustacheTemplate, aFileName: RawUTF8; aPort: integer; aHelpers: TSynMustacheHelpers=nil; aContext: PVariant=nil; const aDescriptions: TFileName=''): RawUTF8; /// generate a code/doc wrapper for a given set of types and Mustache template content // - will use aTables[] to define the ORM information, and supplied aSharedServices[] // aSharedServicesContract[] for SOA definition of a shared API (expected to // be called from TSQLRestClientURI.ServiceDefineSharedAPI) // - aFileName will be transmitted as {{filename}}, e.g. 'mORMotClient' // - you should also specify a "fake" HTTP port e.g. 888 // - the template content could be retrieved from a file via StringFromFile() // - you may optionally retrieve a copy of the data context as TDocVariant // - this function may be used to generate the client at build time, directly // from a just built server, in an automated manner // - you may specify custom helpers (e.g. via TSynMustache.HelpersGetStandardList) // and retrieve the generated data context after generation (if aContext is // a TDocVariant object, its fields would be added to the rendering context), // or a custom description file (as generated by FillDescriptionFromSource) function WrapperForPublicAPI(const aTables: array of TSQLRecordClass; const aRoot, aMustacheTemplate, aFileName: RawUTF8; const aSharedServices: array of TGUID; const aSharedServicesContract: array of RawUTF8; aResultAsJSONObjectWithoutResult: boolean; aPort: integer; aHelpers: TSynMustacheHelpers=nil; aContext: PVariant=nil; const aDescriptions: TFileName=''): RawUTF8; /// instantiate a TSQLRest server instance, including supplied ORM and SOA definitions // - will use aTables[] to define the ORM information, and supplied aSharedServices[] // aSharedServicesContract[] for SOA definition of a shared API, implemented as // abstract classes using TInterfaceStub // - as used e.g. by WrapperForPublicAPI() to generate some code/doc wrappers function WrapperFakeServer(const aTables: array of TSQLRecordClass; const aRoot: RawUTF8; const aSharedServices: array of TGUID; const aSharedServicesContract: array of RawUTF8; aResultAsJSONObjectWithoutResult: boolean): TSQLRestServerFullMemory; /// you can call this procedure within a method-based service allow // code-generation of an ORM and SOA client from a web browser // - you have to specify one or several client *.mustache file paths // - the first path containing any *.mustache file will be used as templates // - for instance: // ! procedure TCustomServer.Wrapper(Ctxt: TSQLRestServerURIContext); // ! begin // search in the current path // ! WrapperMethod(Ctxt,['.']); // ! end; // - optional SourcePath parameter may be used to retrieve additional description // from the comments of the source code of the unit // - you may specify a description file (as generated by FillDescriptionFromSource) procedure WrapperMethod(Ctxt: TSQLRestServerURIContext; const Path: array of TFileName; const SourcePath: TFileName=''; const Descriptions: TFileName=''); /// you can call this procedure to add a 'Wrapper' method-based service // to a given server, to allow code-generation of an ORM and SOA client // - you have to specify one or several client *.mustache file paths // - the first path containing any *.mustache file will be used as templates // - if no path is specified (i.e. as []), it will search in the .exe folder // - the root/wrapper URI will be accessible without authentication (i.e. // from any plain browser) // - for instance: // ! aServer := TSQLRestServerFullMemory.Create(aModel,'test.json',false,true); // ! AddToServerWrapperMethod(aServer,['..']); // - optional SourcePath parameter may be used to retrieve additional description // from the comments of the source code of the unit procedure AddToServerWrapperMethod(Server: TSQLRestServer; const Path: array of TFileName; const SourcePath: TFileName=''); /// you can call this procedure to generate the mORMotServer.pas unit needed // to compile a given server source code using FPC // - will locate FPCServer-mORMotServer.pas.mustache in the given Path[] array // - will write the unit using specified file name or to mORMotServer.pas in the // current directory if DestFileName is '', or to a sub-folder of the matching // Path[] if DestFileName starts with '\' (to allow relative folder use) // - the missing RTTI for records and interfaces would be defined, together // with some patch comments for published record support (if any) for the ORM procedure ComputeFPCServerUnit(Server: TSQLRestServer; const Path: array of TFileName; DestFileName: TFileName=''); /// you can call this procedure to generate the mORMotInterfaces.pas unit needed // to register all needed interface RTTI for FPC // - to circumvent http://bugs.freepascal.org/view.php?id=26774 unresolved issue // - will locate FPC-mORMotInterfaces.pas.mustache in the given Path[] array // - will write the unit using specified file name or to mORMotInterfaces.pas in // the current directory if DestFileName is '', or to a sub-folder of the // matching Path[] if DestFileName starts with '\' (to allow relative folder use) // - all used interfaces will be exported, including SOA and mocking/stubing // types: so you may have to run this function AFTER all process is done procedure ComputeFPCInterfacesUnit(const Path: array of TFileName; DestFileName: TFileName=''); /// rough parsing of the supplied .pas unit, adding the /// commentaries // into a TDocVariant content procedure FillDescriptionFromSource(var Descriptions: TDocVariantData; const SourceFileName: TFileName); /// rough parsing of the supplied .pas unit, adding the /// commentaries // into a compressed binary resource // - could be then compiled into a WRAPPER_RESOURCENAME resource, e.g. via the // following .rc source file, assuming ResourceDestFileName='wrapper.desc': // $ WrappersDescription 10 "wrapper.desc" // - you may specify a .json file name, for debugging/validation purposes // - calls internally FillDescriptionFromSource // - returns the TDocVariant JSON object corresponding to all decriptions function ResourceDescriptionFromSource(const ResourceDestFileName: TFileName; const SourceFileNames: array of TFileName; const JsonDestFileName: TFileName = ''): variant; const /// internal Resource name used for bounded description // - as generated by FillDescriptionFromSource/ResourceDescriptionFromSource // - would be used e.g. by TWrapperContext.Create to inject the available // text description from any matching resource WRAPPER_RESOURCENAME = 'WrappersDescription'; var /// how FillDescriptionFromSource() handles trailing '-' in parsed comments // - default is [*], as expected by buggy AsciiDoc format DESCRIPTION_ITEM_PREFIX: RawUTF8 = ' [*]'; /// this function would generate a pascal unit defining asynchronous // (non-blocking) types from a DDD's blocking dual-phase Select/Command service // - you should specify the services to be converted, as an array - note that // due to how RTTI is stored by the compiler, all "pure input" parameters should // be defined explicitly as "const", otherwise the generated class won't match // - optionally, the TCQRSServiceClass implementing the first Select() phase of // the blocking service may be specified in queries array; a set of unit names // in which those TCQRSServiceClass are defined may be specified // - a Mustache template content should be provided - e.g. asynch.pas.mustache // as published in SQLite3\DDD\dom folder of the source code repository // - FileName would contain the resulting unit filename (without the .pas) // - ProjectName would be written in the main unit comment // - CallType should be the type used at Domain level to identify each // asynchronous call - this type should be an integer, or a function may be // supplied as CallFunction (matching VariantToInteger signature) // - the first phase of the service should have set Key: KeyType, which would be // used to create a single shared asynchronous service instance for all keys // - ExceptionType may be customize, mainly to use a Domain-specific class // - blocking execution may reach some timeout waiting for the asynchronous // acknowledgement: a default delay (in ms) is to be supplied, and some custom // delays may be specified as trios, e.g. ['IMyInterface', 'Method', 10000, ...] function GenerateAsynchServices(const services: array of TGUID; const queries: array of TClass; const units: array of const; const additionalcontext: array of const; Template, FileName, ProjectName, CallType, CallFunction, Key, KeyType, ExceptionType: RawUTF8; DefaultDelay: integer; const CustomDelays: array of const): RawUTF8; type /// the options retrieved during a ExecuteFromCommandLine() call TServiceClientCommandLineOptions = set of (cloPrompt, cloNoColor, cloPipe, cloHeaders, cloVerbose, cloNoExpand, cloNoBody); /// event handler to let ExecuteFromCommandLine call a remote server // - before call, aParams.InBody will be set with the expected JSON content TOnCommandLineCall = procedure(aOptions: TServiceClientCommandLineOptions; const aService: TInterfaceFactory; aMethod: PServiceMethod; var aParams: TSQLRestURIParams) of object; const /// help information displayed by ExecuteFromCommandLine() with no command EXECUTEFROMCOMMANDLINEHELP = ' % help -> show all services (interfaces)'#13#10 + ' % [service] [help] -> show all methods of a given service'#13#10 + ' % [service] [method] help -> show parameters of a given method'#13#10 + ' % [options] [service] [method] [parameters] -> call a given method ' + {$ifdef MSWINDOWS} 'with [parameters] being name=value or name=""value with spaces"" or ' + 'name:={""some"":""json""}' + ' and [options] as /nocolor /pipe /headers /verbose /noexpand /nobody'; {$else} 'with [parameters] being name=value or name=''"value with spaces"'' or ' + 'name:=''{"some":"json"}''' + ' and [options] as --nocolor --pipe --headers --verbose --noexpand --nobody'; {$endif MSWINDOWS} /// command-line SOA remote access to mORMot interface-based services // - supports the following EXECUTEFROMCOMMANDLINEHELP commands // - you shall have registered the aServices interface(s) by a previous call to // the overloaded Get(TypeInfo(IMyInterface)) method or RegisterInterfaces() // - you may specify an optional description file, as previously generated // by mORMotWrappers' FillDescriptionFromSource function - a local // 'WrappersDescription' resource will also be checked // - to actually call the remote server, aOnGetClient should be supplied procedure ExecuteFromCommandLine(const aServices: array of TGUID; const aOnCall: TOnCommandLineCall; const aDescriptions: TFileName = ''); implementation type /// a cross-platform published property kind // - does not match mORMot.pas TSQLFieldType: here we recognize only types // which may expect a special behavior in SynCrossPlatformREST.pas unit // - should match TSQLFieldKind order in SynCrossPlatformREST.pas TCrossPlatformSQLFieldKind = ( cpkDefault, cpkDateTime, cpkTimeLog, cpkBlob, cpkModTime, cpkCreateTime, cpkRecord, cpkVariant); const /// those text values should match TSQLFieldKind in SynCrossPlatformREST.pas CROSSPLATFORMKIND_TEXT: array[TCrossPlatformSQLFieldKind] of RawUTF8 = ( 'sftUnspecified', 'sftDateTime', 'sftTimeLog', 'sftBlob', 'sftModTime', 'sftCreateTime', 'sftRecord', 'sftVariant'); type /// types recognized and handled by this mORMotWrappers unit TWrapperType = ( wUnknown, wBoolean, wEnum, wSet, wByte, wWord, wInteger, wCardinal, wInt64, wQWord, wID, wReference, wTimeLog, wModTime, wCreateTime, wCurrency, wSingle, wDouble, wDateTime, wRawUTF8, wString, wRawJSON, wBlob, wGUID, wCustomAnswer, wRecord, wArray, wVariant, wObject, wSQLRecord, wInterface, wRecordVersion); /// supported languages typesets TWrapperLanguage = ( lngDelphi, lngPascal, lngCS, lngJava, lngTypeScript, lngSwagger); const CROSSPLATFORM_KIND: array[TSQLFieldType] of TCrossPlatformSQLFieldKind = ( // sftUnknown, sftAnsiText, sftUTF8Text, sftEnumerate, sftSet, sftInteger, cpkDefault, cpkDefault, cpkDefault, cpkDefault, cpkDefault,cpkDefault, // sftID, sftRecord, sftBoolean,sftFloat, sftDateTime, cpkDefault,cpkDefault,cpkDefault,cpkDefault,cpkDateTime, // sftTimeLog,sftCurrency, cpkTimeLog,cpkDefault, // sftObject, sftVariant, sftNullable, sftBlob, sftBlobDynArray, sftBlobCustom, cpkDefault, cpkVariant, cpkVariant, cpkBlob, cpkDefault, cpkDefault, // sftUTF8Custom,sftMany, sftModTime, sftCreateTime, sftTID, sftRecordVersion cpkRecord, cpkDefault,cpkModTime, cpkCreateTime, cpkDefault, cpkDefault, // sftSessionUserID, sftDateTimeMS, sftUnixTime, sftUnixMStime cpkDefault, cpkDateTime, cpkDefault, cpkDefault); SIZETODELPHI: array[0..8] of string[7] = ( 'integer','byte','word','integer','integer','int64','int64','int64','int64'); TYPES_SIZE: array[0..8] of TWrapperType = ( wInteger,wByte,wWord,wInteger,wInteger,wInt64,wInt64,wInt64,wInt64); SWI32 = '{"type":"integer"}'; SWI64 = '{"type":"integer","format":"int64"}'; SWD32 = '{"type":"number","format":"float"}'; SWD64 = '{"type":"number","format":"double"}'; { TODO: refactor TID and Int64 for JavaScript (integers truncated to 53-bit) } TYPES_LANG: array[TWrapperLanguage,TWrapperType] of RawUTF8 = ( // lngDelphi ('', 'Boolean', '', '', 'Byte', 'Word', 'Integer', 'Cardinal', 'Int64', 'UInt64', 'TID', 'TRecordReference', 'TTimeLog', 'TModTime', 'TCreateTime', 'Currency', 'Single', 'Double', 'TDateTime', 'RawUTF8','String', 'RawJSON', 'TSQLRawBlob', 'TGUID', 'TServiceCustomAnswer', '', '', 'Variant', '', '', '', 'TRecordVersion'), // lngPascal ('', 'Boolean', '', '', 'Byte', 'Word', 'Integer', 'Cardinal', 'Int64', 'UInt64', 'TID', 'TRecordReference', 'TTimeLog', 'TModTime', 'TCreateTime', 'Currency', 'Single', 'Double', 'TDateTime', 'String', 'String', 'Variant', 'TSQLRawBlob', 'TGUID', 'THttpBody', '', '', 'Variant', '', 'TID', '', 'TRecordVersion'), // lngCS ('', 'bool', '', '', 'byte', 'word', 'integer', 'uint', 'long', 'ulong', 'TID', 'TRecordReference', 'TTimeLog', 'TModTime', 'TCreateTime', 'decimal', 'single', 'double', 'double', 'string', 'string', 'dynamic', 'byte[]', 'Guid', 'byte[]', '', '', 'dynamic', '', 'TID', '', 'TRecordVersion'), // lngJava ('', 'boolean', '', '', 'byte', 'int', 'int', 'long', 'long', 'long', 'TID', 'TRecordReference', 'TTimeLog', 'TModTime', 'TCreateTime', 'BigDecimal', 'single', 'double', 'double', 'String', 'String', 'Object', 'byte[]', 'String', 'byte[]', '', '', 'Object', '', 'TID', '', 'TRecordVersion'), // lngTypeScript ('', 'boolean', '', '', 'number', 'number', 'number', 'number', 'number', 'number', 'mORMot.TID', 'mORMot.TRecordReference', 'mORMot.TTimeLog', 'mORMot.TModTime', 'mORMot.TCreateTime', 'number', 'number', 'number', 'mORMot.TDateTime', 'string', 'string', 'any', 'mORMot.TSQLRawBlob', 'mORMot.TGUID', 'mORMot.THttpBody', '', '', 'any', '', '', '', 'mORMot.TRecordVersion'), // lngSwagger ('', '{"type":"boolean"}', '', '', SWI32, SWI32, SWI32, SWI32, SWI64, SWI64, SWI64, SWI64, SWI64, SWI64, SWI64, SWD64, SWD32, SWD64, '{"type":"string","format":"date-time"}', // wDateTime '{"type":"string"}','{"type":"string"}', '{"type":"object"}', //FIXME! //wRawJSON '{"type":"string","format":"binary"}','{"type":"string"}', //wBlob,wGUID '', '', '', '', //wCustomAnswer, wRecord, wArray, wVariant '', SWI64, '', '' //wObject, wSQLRecord, wInterface, wRecordVersion )); TYPES_ORM: array[TSQLFieldType] of TWrapperType = (wUnknown, // sftUnknown wString, // sftAnsiText wRawUTF8, // sftUTF8Text wEnum, // sftEnumerate wSet, // sftSet wUnknown, // sftInteger - wUnknown to force exact type wSQLRecord, // sftID wReference, // sftRecord wBoolean, // sftBoolean wUnknown, // sftFloat - wUnknown to force exact type wDateTime, // sftDateTime wTimeLog, // sftTimeLog wCurrency, // sftCurrency wObject, // sftObject wVariant, // sftVariant wVariant, // sftNullable wBlob, // sftBlob wBlob, // sftBlobDynArray wRecord, // sftBlobCustom wRecord, // sftUTF8Custom wUnknown, // sftMany wModTime, // sftModTime wCreateTime, // sftCreateTime wID, // sftID wRecordVersion, // sftRecordVersion wID, // sftSessionUserID wDateTime, // sftDateTimeMS wUnknown, // sftUnixTime wUnknown); // sftUnixMSTime TYPES_SIMPLE: array[TJSONCustomParserRTTIType] of TWrapperType = ( //ptArray, ptBoolean, ptByte, ptCardinal, ptCurrency, ptDouble, ptExtended, wArray, wBoolean, wByte, wCardinal, wCurrency, wDouble, wDouble, //ptInt64, ptInteger, ptQWord, ptRawByteString, ptRawJSON, ptRawUTF8, ptRecord, wInt64, wInteger, wQWord, wBlob, wRawJSON, wRawUTF8, wRecord, //ptSingle, ptString, ptSynUnicode, ptDateTime, ptDateTimeMS, wSingle, wString, wRawUTF8, wDateTime, wDateTime, //ptGUID, ptID, ptTimeLog, ptUnicodeString, wGUID, wID, wTimeLog, {$ifdef HASVARUSTRING} wRawUTF8, {$endif} //ptVariant, ptWideString, ptWord, ptCustom wVariant, wRawUTF8, wWord, wUnknown); TYPES_SOA: array[TServiceMethodValueType] of TWrapperType = ( wUnknown,wUnknown,wBoolean,wEnum,wSet,wUnknown,wUnknown,wUnknown, wDouble,wDateTime,wCurrency,wRawUTF8,wString,wRawUTF8,wRawUTF8,wRawUTF8, wRecord,wVariant,wObject,wRawJSON,wArray, wUnknown); // integers are wUnknown to force best type type EWrapperContext = class(ESynException); TWrapperContext = class protected fServer: TSQLRestServer; fORM, fRecords,fEnumerates,fSets,fArrays,fUnits,fDescriptions: TDocVariantData; fSOA: variant; fSourcePath: TFileNameDynArray; fHasAnyRecord: boolean; function ContextFromInfo(typ: TWrapperType; typName: RawUTF8=''; typInfo: PTypeInfo=nil): variant; function ContextNestedProperties(rtti: TJSONCustomParserRTTI): variant; function ContextOneProperty(prop: TJSONCustomParserRTTI): variant; function ContextFromMethods(int: TInterfaceFactory): variant; function ContextFromMethod(const meth: TServiceMethod): variant; function ContextArgsFromMethod(const meth: TServiceMethod): variant; procedure AddUnit(const aUnitName: ShortString; addAsProperty: PVariant); public constructor Create(const aDescriptions: TFileName); constructor CreateFromModel(aServer: TSQLRestServer; const aSourcePath: TFileName; const aDescriptions: TFileName); constructor CreateFromUsedInterfaces(const aDescriptions: TFileName); function Context: variant; end; { TWrapperContext } constructor TWrapperContext.Create(const aDescriptions: TFileName); var desc: RawByteString; begin TDocVariant.NewFast([@fORM,@fRecords,@fEnumerates,@fSets,@fArrays, @fUnits,@fDescriptions]); if aDescriptions<>'' then desc := StringFromFile(aDescriptions); if desc='' then ResourceSynLZToRawByteString(WRAPPER_RESOURCENAME,desc); if desc<>'' then fDescriptions.InitJSONInPlace(Pointer(desc),JSON_OPTIONS_FAST); end; constructor TWrapperContext.CreateFromModel(aServer: TSQLRestServer; const aSourcePath, aDescriptions: TFileName); var t,f,s,n: integer; nfoList: TSQLPropInfoList; nfo: TSQLPropInfo; nfoSQLFieldRTTITypeName: RawUTF8; kind: TCrossPlatformSQLFieldKind; hasRecord: boolean; fields,services: TDocVariantData; field,rec: variant; srv: TServiceFactoryServer; uri: RawUTF8; source: TFileName; src: PChar; begin Create(aDescriptions); if aSourcePath<>'' then begin src := pointer(aSourcePath); n := 0; repeat source := GetNextItemString(src,';'); if (source<>'') and DirectoryExists(source) then begin SetLength(fSourcePath,n+1); fSourcePath[n] := IncludeTrailingPathDelimiter(source); inc(n); end; until src=nil; end; fServer := aServer; TDocVariant.NewFast([@fields,@services]); // compute ORM information for t := 0 to fServer.Model.TablesMax do begin nfoList := fServer.Model.TableProps[t].Props.Fields; fields.Clear; fields.Init; hasRecord := false; for f := 0 to nfoList.Count-1 do begin nfo := nfoList.List[f]; nfoSQLFieldRTTITypeName := nfo.SQLFieldRTTITypeName; if nfo.InheritsFrom(TSQLPropInfoRTTI) then field := ContextFromInfo(TYPES_ORM[nfo.SQLFieldType],nfoSQLFieldRTTITypeName, TSQLPropInfoRTTI(nfo).PropType) else if nfo.InheritsFrom(TSQLPropInfoRecordTyped) then begin hasRecord := true; fHasAnyRecord := true; field := ContextFromInfo(wRecord,nfoSQLFieldRTTITypeName, TSQLPropInfoRecordTyped(nfo).TypeInfo); end else raise EWrapperContext.CreateUTF8('Unexpected type % for %.%', [nfo,fServer.Model.Tables[t],nfo.Name]); kind := CROSSPLATFORM_KIND[nfo.SQLFieldType]; _ObjAddProps(['index',f+1,'name',nfo.Name,'sql',ord(nfo.SQLFieldType), 'sqlName',nfo.SQLFieldTypeName^,'typeKind',ord(kind), 'typeKindName',CROSSPLATFORMKIND_TEXT[kind],'attr',byte(nfo.Attributes)],field); if aIsUnique in nfo.Attributes then _ObjAddProps(['unique',true],field); if nfo.FieldWidth>0 then _ObjAddProps(['width',nfo.FieldWidth],field); if f0 then begin for s := 0 to fServer.Services.Count-1 do begin srv := fServer.Services.Index(s) as TServiceFactoryServer; if fServer.Services.ExpectMangledURI then uri := srv.InterfaceMangledURI else uri := srv.InterfaceURI; with srv do rec := _ObjFast(['uri',uri,'interfaceURI',InterfaceURI, 'interfaceMangledURI',InterfaceMangledURI, 'interfaceName',InterfaceFactory.InterfaceTypeInfo^.Name, 'GUID',GUIDToRawUTF8(InterfaceFactory.InterfaceIID), 'contractExpected',UnQuoteSQLString(ContractExpected), 'instanceCreation',ord(InstanceCreation), 'instanceCreationName',GetEnumNameTrimed( TypeInfo(TServiceInstanceImplementation),InstanceCreation), 'methods',ContextFromMethods(InterfaceFactory), 'bypassAuthentication',ByPassAuthentication, 'resultAsJSONObject',ResultAsJSONObject, 'resultAsJSONObjectWithoutResult',ResultAsJSONObjectWithoutResult and (InstanceCreation in SERVICE_IMPLEMENTATION_NOID), 'resultAsXMLObject',ResultAsXMLObject, 'timeoutSec',TimeoutSec, 'serviceDescription',fDescriptions.GetValueOrNull(InterfaceFactory.InterfaceName)]); if srv.InstanceCreation=sicClientDriven then rec.isClientDriven := true; services.AddItem(rec); end; fSOA := _ObjFast(['enabled',True,'services',variant(services), 'expectMangledURI',fServer.Services.ExpectMangledURI]); end; end; constructor TWrapperContext.CreateFromUsedInterfaces(const aDescriptions: TFileName); var interfaces: TSynObjectListLocked; services: TDocVariantData; i: Integer; begin Create(aDescriptions); interfaces := TInterfaceFactory.GetUsedInterfaces; if interfaces=nil then exit; services.InitFast; for i := 0 to interfaces.Count-1 do services.AddItem(_ObjFast([ 'interfaceName',TInterfaceFactory(interfaces.List[i]).InterfaceTypeInfo^.Name, 'methods',ContextFromMethods(interfaces.List[i])])); fSOA := _ObjFast(['enabled',True,'services',variant(services)]); end; function TWrapperContext.ContextArgsFromMethod(const meth: TServiceMethod): variant; const DIRTODELPHI: array[TServiceMethodValueDirection] of string[7] = ( 'const','var','out','result'); DIRTOSMS: array[TServiceMethodValueDirection] of string[7] = ( 'const','var','var','result'); var a,r: integer; arg: variant; begin TDocVariant.NewFast(result); r := 0; for a := 1 to high(meth.Args) do begin with meth.Args[a] do begin arg := ContextFromInfo(TYPES_SOA[ValueType],'',ArgTypeInfo); arg.argName := ParamName^; arg.argType := ArgTypeName^; arg.dir := ord(ValueDirection); arg.dirName := DIRTODELPHI[ValueDirection]; arg.dirNoOut := DIRTOSMS[ValueDirection]; // no OUT in DWS/SMS -> VAR instead if ValueDirection in [smdConst,smdVar] then arg.dirInput := true; if ValueDirection in [smdVar,smdOut,smdResult] then arg.dirOutput := true; if ValueDirection=smdResult then arg.dirResult := true; end; if a=0], 'args',ContextArgsFromMethod(meth), 'argsOutputCount',ArgsOutputValuesCount]); if self<>nil then begin// can be called as TWraperContext(nil).ContextFromMethod d := fDescriptions.GetValueOrNull(InterfaceDotMethodName); if VarIsEmptyOrNull(d) then RawUTF8ToVariant(InterfaceDotMethodName,d); result.methodDescription := d; end; if ArgsInFirst>=0 then result.hasInParams := true; if ArgsOutFirst>=0 then begin result.hasOutParams := true; if ArgsOutNotResultLast>0 then result.hasOutNotResultParams := true; end; if ArgsResultIsServiceCustomAnswer then result.resultIsServiceCustomAnswer := true; if IsInherited then result.isInherited := true; end; end; function ResourceDescriptionFromSource(const ResourceDestFileName: TFileName; const SourceFileNames: array of TFileName; const JsonDestFileName: TFileName): variant; var desc: TDocVariantData absolute result; i: integer; json: RawUTF8; begin VarClear(result); desc.InitFast; for i := 0 to high(SourceFileNames) do FillDescriptionFromSource(desc,SourceFileNames[i]); json := desc.ToJSON; if JsonDestFileName <> '' then JSONReformatToFile(json, JsonDestFileName); FileFromString(SynLZCompress(json),ResourceDestFileName); end; procedure FillDescriptionFromSource(var Descriptions: TDocVariantData; const SourceFileName: TFileName); var desc,typeName,interfaceName: RawUTF8; P: PUTF8Char; withinCode: boolean; begin P := pointer(StringFromFile(SourceFileName)); if P=nil then exit; withinCode := false; repeat // rough parsing of the .pas unit file to extract /// description P := GotoNextNotSpace(P); if IdemPChar(P,'IMPLEMENTATION') then break; // only the "interface" section is parsed if IdemPChar(P,'{$IFDEF ') then begin repeat // just ignore any $ifdef ... $endif P := GotoNextLine(P); if P=nil then exit; until IdemPChar(GotoNextNotSpace(P),'{$ENDIF'); P := GotoNextLine(P); P := GotoNextNotSpace(P); end; if (P[0]='/') and (P[1]='/') and (P[2]='/') then begin desc := GetNextLine(GotoNextNotSpace(P+3),P); if desc='' then break; desc[1] := UpCase(desc[1]); repeat if P=nil then exit; P := GotoNextNotSpace(P); if IdemPChar(P,'{$IFDEF ') then begin repeat // just ignore any $ifdef ... $endif P := GotoNextLine(P); if P=nil then exit; until IdemPChar(GotoNextNotSpace(P),'{$ENDIF'); P := GotoNextLine(P); end else if (P[0]='/') and (P[1]='/') then begin if P[2]='/' then inc(P,3) else inc(P,2); P := GotoNextNotSpace(P); if P^ in ['$','!'] then begin if not withinCode then begin withinCode := true; desc := desc+#13#10#13#10'----'; // AsciiDoc source code block end; desc := desc+#13#10; inc(P); end else if P^='-' then begin desc := desc+#13#10#13#10'-'+ DESCRIPTION_ITEM_PREFIX; inc(P); end else desc := desc+' '; desc := desc+GetNextLine(P,P); end else break; until false; if withinCode then begin desc := desc+#13#10'----'; // code block should end the description withinCode := false; end; GetNextItem(P,' ',typeName); if P=nil then exit; if typeName<>'' then if P^='=' then begin // simple type (record, array, enumeration, set) if Descriptions.GetValueIndex(typeName)<0 then begin Descriptions.AddValue(typeName,RawUTF8ToVariant(desc)); if typeName[1]='I' then interfaceName := Copy(typeName,2,128) else interfaceName := ''; end; end else if interfaceName<>'' then if IdemPropNameU(typeName,'function') or IdemPropNameU(typeName,'procedure') then if GetNextFieldProp(P,typeName) then Descriptions.AddValue(interfaceName+'.'+typeName,RawUTF8ToVariant(desc)); end else P := GotoNextLine(P); until (P=nil); end; procedure TWrapperContext.AddUnit(const aUnitName: ShortString; addAsProperty: PVariant); var unitName: variant; i: Integer; begin if (aUnitName='') or IdemPropName(aUnitName,'mORMot') then exit; RawUTF8ToVariant(@aUnitName[1],ord(aUnitName[0]),unitName); if addAsProperty<>nil then _ObjAddProps(['unitName',unitName],addAsProperty^); if (self=nil) or (fUnits.SearchItemByValue(unitName)>=0) then exit; // already registered fUnits.AddItem(unitName); if fSourcePath=nil then exit; for i := 0 to high(fSourcePath) do FillDescriptionFromSource(fDescriptions,format('%s%s.pas',[fSourcePath[i], aUnitName])); end; function TWrapperContext.ContextFromMethods(int: TInterfaceFactory): variant; var m: integer; methods: TDocVariantData; // circumvent FPC -O2 memory leak begin AddUnit(int.InterfaceTypeInfo^.InterfaceUnitName^,nil); methods.InitFast; for m := 0 to int.MethodsCount-1 do methods.AddItem(ContextFromMethod(int.Methods[m])); result := variant(methods); end; function TWrapperContext.ContextOneProperty(prop: TJSONCustomParserRTTI): variant; var typ: pointer; l,level: integer; begin if prop.InheritsFrom(TJSONCustomParserCustom) then begin typ := TJSONCustomParserCustom(prop).CustomTypeInfo; if (typ=nil) and (prop.ClassType=TJSONCustomParserCustomSimple) then case TJSONCustomParserCustomSimple(prop).KnownType of ktBinary: typ := TypeInfo(RawUTF8); end; end else typ := nil; result := ContextFromInfo(TYPES_SIMPLE[prop.PropertyType],prop.CustomTypeName,typ); if prop.PropertyName<>'' then _ObjAddProps(['propName',prop.PropertyName,'fullPropName',prop.FullPropertyName],result); level := 0; for l := 1 to length(prop.FullPropertyName) do if prop.FullPropertyName[l]='.' then inc(level); if level>0 then result.nestedIdentation := StringOfChar(' ',level*2); case prop.PropertyType of ptRecord: begin result.isSimple := null; result.nestedRecord := _ObjFast( ['nestedRecord',null,'fields',ContextNestedProperties(prop)]); end; ptArray: begin result.isSimple := null; if prop.NestedProperty[0].PropertyName='' then result.nestedSimpleArray := ContextOneProperty(prop.NestedProperty[0]) else result.nestedRecordArray := _ObjFast( ['nestedRecordArray',null,'fields',ContextNestedProperties(prop)]); end; else if TDocVariantData(result).GetValueIndex('toVariant')<0 then result.isSimple := true else result.isSimple := null; end; end; function TWrapperContext.ContextNestedProperties(rtti: TJSONCustomParserRTTI): variant; var i: integer; begin SetVariantNull(result); if rtti.PropertyType in [ptRecord,ptArray] then begin TDocVariant.NewFast(result); for i := 0 to high(rtti.NestedProperty) do TDocVariantData(result).AddItem(ContextOneProperty(rtti.NestedProperty[i])); end; end; function TWrapperContext.ContextFromInfo(typ: TWrapperType; typName: RawUTF8; typInfo: PTypeInfo): variant; var typeWrapper: PShortString; function VarName(lng: TWrapperLanguage): variant; begin if TYPES_LANG[lng,typ]<>'' then RawUTF8ToVariant(TYPES_LANG[lng,typ],result) else if typName='' then SetVariantNull(result) else RawUTF8ToVariant(typName,result); end; procedure RegisterType(var list: TDocVariantData); var info: variant; item: PTypeInfo; itemSize: integer; objArray: PClassInstance; objArrayType: TWrapperType; parser: TJSONRecordAbstract; begin if list.SearchItemByProp('name',typName,false)>=0 then exit; // already registered if typInfo=nil then raise EWrapperContext.CreateUTF8('%.RegisterType(%): no RTTI',[typeWrapper^,typName]); case typ of wEnum: // full (untrimed) identifier: values[] may be trimmed at mustache level info := _JsonFastFmt('{name:?,values:%}', [typInfo^.EnumBaseType^.GetEnumNameAllAsJSONArray(false)],[typName]); wSet: // full (untrimed) identifier: values[] may be trimmed at mustache level info := _JsonFastFmt('{name:?,values:%}', [typInfo^.SetEnumType^.GetEnumNameAllAsJSONArray(false)],[typName]); wRecord: begin parser := TTextWriter.RegisterCustomJSONSerializerFindParser(typInfo,true); if (parser<>nil) and (parser.Root<>nil) and (parser.Root.CustomTypeName<>'') then info := _ObjFast(['name',typName,'fields',ContextNestedProperties(parser.Root)]); end; wArray: begin item := typInfo^.DynArrayItemType(@itemSize); if item=nil then begin if itemSize=SizeOf(pointer) then begin objArray := TJSONSerializer.RegisterObjArrayFindType(typInfo); if objArray<>nil then begin // T*ObjArray -> retrieve item information if objArray.ItemCreate=cicTSQLRecord then objArrayType := wSQLRecord else objArrayType := wObject; info := ContextFromInfo(objArrayType,'',objArray^.ItemClass.ClassInfo); _ObjAddProps(['isObjArray',true],info); end; end; if VarIsEmptyOrNull(info) and DynArrayItemTypeIsSimpleBinary(typName) then info := ContextFromInfo(wRawUTF8); if VarIsEmptyOrNull(info) then info := ContextFromInfo(TYPES_SIZE[itemSize]); end else info := ContextFromInfo(wUnknown,'',item); info.name := typName; end; end; if not VarIsEmptyOrNull(info) then // null e.g. for a record without custom text definition list.AddItem(info); end; var siz, i: integer; enum: PEnumType; begin if typ=wUnknown then begin if typInfo=nil then raise EWrapperContext.CreateUTF8('No RTTI nor typ for [%]',[typName]); typ := TYPES_ORM[typInfo.GetSQLFieldType]; if typ=wUnknown then begin typ := TYPES_SIMPLE[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(typInfo)]; if typ=wUnknown then case typInfo^.Kind of tkRecord{$ifdef FPC},tkObject{$endif}: typ := wRecord; tkInterface: typ := wInterface; else raise EWrapperContext.CreateUTF8('Not enough RTTI for [%]',[typInfo^.Name]); end; end; end; if typName='' then begin if typInfo<>nil then begin TypeInfoToQualifiedName(typInfo,typName); i := PosExChar('.',typName); if i>0 then trimcopy(typName,i+1,maxInt,typName); // trim unit name end else typName := TYPES_LANG[lngDelphi,typ]; end; if (typ=wRecord) and IdemPropNameU(typName,'TGUID') then typ := wGUID else if (typ=wRecord) and IdemPropNameU(typName,'TServiceCustomAnswer') then typ := wCustomAnswer; typeWrapper := GetEnumName(TypeInfo(TWrapperType),ord(typ)); result := _ObjFast([ 'typeWrapper',typeWrapper^, 'typeSource',typName, 'typeDelphi',VarName(lngDelphi), 'typePascal',VarName(lngPascal), 'typeCS',VarName(lngCS), 'typeJava',VarName(lngJava), 'typeTS',VarName(lngTypeScript), 'typeSwagger',VarName(lngSwagger)]); if self=nil then exit; // no need to have full info if called e.g. from MVC if typInfo<>nil then case typInfo^.Kind of tkClass: AddUnit(typInfo^.ClassType^.UnitName,@result); end; case typ of wBoolean,wByte,wWord,wInteger,wCardinal,wInt64,wQWord,wID,wReference,wTimeLog, wModTime,wCreateTime,wSingle,wDouble,wRawUTF8,wString: ; // simple types have no special marshalling wDateTime: _ObjAddProps(['isDateTime',true,'toVariant','DateTimeToIso8601', 'fromVariant','Iso8601ToDateTime'],result); wRecordVersion: _ObjAddProps(['isRecordVersion',true],result); wCurrency: _ObjAddProps(['isCurrency',true],result); wVariant: _ObjAddProps(['isVariant',true],result); wRawJSON: _ObjAddProps(['isJson',true],result); wEnum: begin _ObjAddProps(['isEnum',true,'toVariant','ord','fromVariant','Variant2'+typName],result); if self<>nil then RegisterType(fEnumerates); end; wSet: begin enum := typInfo^.SetEnumType; if enum=nil then siz := 0 else siz := enum^.SizeInStorageAsSet; _ObjAddProps(['isSet',true,'toVariant',SIZETODELPHI[siz],'fromVariant',typName],result); if self<>nil then RegisterType(fSets); end; wGUID: _ObjAddProps(['toVariant','GUIDToVariant','fromVariant','VariantToGUID'],result); wCustomAnswer: _ObjAddProps(['toVariant','HttpBodyToVariant','fromVariant','VariantToHttpBody'],result); wRecord: begin _ObjAddProps(['isRecord',true],result); if typInfo<>nil then begin _ObjAddProps(['toVariant',typName+'2Variant','fromVariant','Variant2'+typName],result); if self<>nil then RegisterType(fRecords); end; end; wSQLRecord: if fServer.Model.GetTableIndexInheritsFrom(TSQLRecordClass(typInfo^.ClassType^.ClassType))<0 then raise EWrapperContext.CreateUTF8('% should be part of the model',[typName]) else _ObjAddProps(['isSQLRecord',true],result); wObject: begin _ObjAddProps(['isObject',true],result); if typInfo<>nil then _ObjAddProps(['toVariant','ObjectToVariant','fromVariant',typName+'.CreateFromVariant'],result); end; wArray: begin _ObjAddProps(['isArray',true],result); if typInfo<>nil then begin _ObjAddProps(['toVariant',typName+'2Variant','fromVariant','Variant2'+typName],result); if self<>nil then RegisterType(fArrays); end; end; wBlob: _ObjAddProps(['isBlob',true, 'toVariant','BlobToVariant','fromVariant','VariantToBlob'],result); wInterface: _ObjAddProps(['isInterface',true],result); else raise EWrapperContext.CreateUTF8('Unexpected type % (%) for [%]', [typeWrapper^,ord(typ),typName]); end; end; function TWrapperContext.Context: variant; procedure AddDescription(var list: TDocVariantData; const propName,descriptionName: RawUTF8); var i: integer; propValue: RawUTF8; begin if (list.Kind<>dvArray) or (fDescriptions.Count=0) then exit; for i := 0 to list.Count-1 do with _Safe(list.Values[i])^ do if GetAsRawUTF8(propName,propValue) then AddValue(descriptionName,fDescriptions.GetValueOrNull(propValue)); end; var s: integer; authClass: TClass; begin // compute the Model information as JSON result := _ObjFast(['time',NowToString, 'year',CurrentYear, 'mORMotVersion',SYNOPSE_FRAMEWORK_VERSION, 'exeVersion',VarStringOrNull(StringToUTF8(ExeVersion.Version.DetailedOrVoid)), 'exeInfo',ExeVersion.Version.VersionInfo, 'exeName',ExeVersion.ProgramName, 'hasorm',fORM.Count>0, 'orm',variant(fORM), 'soa',fSOA]); if fServer<>nil then _ObjAddProps(['root',fServer.Model.Root],result); if fHasAnyRecord then result.ORMWithRecords := true; if fRecords.Count>0 then begin AddDescription(fRecords,'name','recordDescription'); result.records := variant(fRecords); result.withRecords := true; result.withHelpers := true; end; if fEnumerates.Count>0 then begin AddDescription(fEnumerates,'name','enumDescription'); result.enumerates := variant(fEnumerates); result.withEnumerates := true; result.withHelpers := true; end; if fSets.Count>0 then begin AddDescription(fSets,'name','setDescription'); result.sets := variant(fSets); result.withsets := true; result.withHelpers := true; end; if fArrays.Count>0 then begin result.arrays := variant(fArrays); result.withArrays := true; result.withHelpers := true; end; if fUnits.Count>0 then result.units := variant(fUnits); // add the first registered supported authentication class type as default if fServer<>nil then for s := 0 to fServer.AuthenticationSchemesCount-1 do begin authClass := fServer.AuthenticationSchemes[s].ClassType; if (authClass=TSQLRestServerAuthenticationDefault) or (authClass=TSQLRestServerAuthenticationNone) then begin result.authClass := authClass.ClassName; break; end; end; end; function ContextFromModel(aServer: TSQLRestServer; const aSourcePath, aDescriptions: TFileName): variant; begin with TWrapperContext.CreateFromModel(aServer,aSourcePath,aDescriptions) do try result := Context; finally Free; end; end; function ContextFromMethod(const method: TServiceMethod): variant; begin result := TWrapperContext(nil).ContextFromMethod(method); end; function ContextFromMethods(int: TInterfaceFactory): variant; begin result := TWrapperContext(nil).ContextFromMethods(int); end; procedure WrapperMethod(Ctxt: TSQLRestServerURIContext; const Path: array of TFileName; const SourcePath, Descriptions: TFileName); var root, templateName, templateTitle, savedName, templateExt, unitName, template, result, host, uri, head: RawUTF8; context: variant; SR: TSearchRec; i, templateFound, port: integer; begin // URI is e.g. GET http://localhost:888/root/wrapper/Delphi/UnitName.pas if (Ctxt.Method<>mGET) or (high(Path)<0) then exit; templateFound := -1; for i := 0 to high(Path) do if FindFirst(Path[i]+PathDelim+'*.mustache',faAnyFile,SR)=0 then begin templateFound := i; break; end; if templateFound<0 then Ctxt.Error('Please copy some .mustache files in the expected folder (e.g. %)',[Path[0]]) else try context := ContextFromModel(Ctxt.Server,SourcePath,Descriptions); context.uri := Ctxt.URIWithoutSignature; if llfHttps in Ctxt.Call^.LowLevelFlags then begin context.protocol := 'https'; context.https := true; end else context.protocol := 'http'; host := Ctxt.InHeader['host']; if host<>'' then context.host := host; port := GetInteger(pointer(split(host,':',host))); if port=0 then port := 80; context.port := port; if IdemPropNameU(Ctxt.URIBlobFieldName,'context') then begin Ctxt.ReturnsJson(context,200,{304=}true,twNone,{humanreadable=}true); exit; end; root := Ctxt.Server.Model.Root; if Ctxt.URIBlobFieldName='' then begin result := 'mORMot Wrappers'+ '

Generated Code/Doc Wrappers

'+ '

Available Templates:

You can also retrieve the corresponding '+ 'template context.

Generated by a '+ 'Synopse mORMot '+SYNOPSE_FRAMEWORK_VERSION+ ' server.',[result,root]); Ctxt.Returns(result,HTTP_SUCCESS,HTML_CONTENT_TYPE_HEADER); exit; end; finally FindClose(SR); end; Split(Ctxt.URIBlobFieldName,'/',templateName,unitName); Split(unitName,'.',unitName,templateExt); if PosExChar('.',templateExt)>0 then begin // see as text if IdemPropNameU(Split(templateExt,'.',templateExt),'mustache') then unitName := ''; // force return .mustache head := TEXT_CONTENT_TYPE_HEADER; end else // download as file head := HEADER_CONTENT_TYPE+'application/'+LowerCase(templateExt); templateName := templateName+'.'+templateExt+'.mustache'; template := AnyTextFileToRawUTF8( Path[templateFound]+PathDelim+UTF8ToString(templateName),true); if template='' then begin Ctxt.Error(templateName,HTTP_NOTFOUND); exit; end; if unitName='' then result := template else begin context.templateName := templateName; context.filename := unitName; result := TSynMustache.Parse(template).Render(context,nil, TSynMustache.HelpersGetStandardList,nil,true); end; Ctxt.Returns(result,HTTP_SUCCESS,head); end; function WrapperFromModel(aServer: TSQLRestServer; const aMustacheTemplate, aFileName: RawUTF8; aPort: integer; aHelpers: TSynMustacheHelpers; aContext: PVariant; const aDescriptions: TFileName): RawUTF8; var context: variant; begin // no context.uri nor context.host here context := ContextFromModel(aServer,'',aDescriptions); with _Safe(context)^ do begin if aPort<>0 then I['port'] := aPort; U['filename'] := aFileName; if aContext<>nil then begin AddFrom(aContext^); aContext^ := context; end; end; if aHelpers=nil then aHelpers := TSynMustache.HelpersGetStandardList; result := TSynMustache.Parse(aMustacheTemplate).Render(context,nil,aHelpers,nil,true); end; function WrapperFakeServer(const aTables: array of TSQLRecordClass; const aRoot: RawUTF8; const aSharedServices: array of TGUID; const aSharedServicesContract: array of RawUTF8; aResultAsJSONObjectWithoutResult: boolean): TSQLRestServerFullMemory; var contract: RawUTF8; fake: IInterface; i: integer; begin result := TSQLRestServerFullMemory.CreateWithOwnModel(aTables,false,aRoot); for i := 0 to high(aSharedServices) do begin if i<=high(aSharedServicesContract) then contract := aSharedServicesContract[i] else contract := ''; result.ServiceDefine(TInterfaceStub.Create(aSharedServices[i], fake). LastInterfacedObjectFake,[aSharedServices[i]],contract). ResultAsJSONObjectWithoutResult := aResultAsJSONObjectWithoutResult; end; end; function WrapperForPublicAPI(const aTables: array of TSQLRecordClass; const aRoot, aMustacheTemplate, aFileName: RawUTF8; const aSharedServices: array of TGUID; const aSharedServicesContract: array of RawUTF8; aResultAsJSONObjectWithoutResult: boolean; aPort: integer; aHelpers: TSynMustacheHelpers; aContext: PVariant; const aDescriptions: TFileName): RawUTF8; var server: TSQLRestServer; begin server := WrapperFakeServer(aTables,aRoot,aSharedServices,aSharedServicesContract, aResultAsJSONObjectWithoutResult); try result := WrapperFromModel(server,aMustacheTemplate,aFileName,aPort,aHelpers, aContext,aDescriptions); finally server.Free; end; end; { TWrapperMethodHook } type TWrapperMethodHook = class(TPersistent) public SearchPath: TFileNameDynArray; SourcePath: TFileName; published procedure Wrapper(Ctxt: TSQLRestServerURIContext); end; procedure TWrapperMethodHook.Wrapper(Ctxt: TSQLRestServerURIContext); begin WrapperMethod(Ctxt,SearchPath,SourcePath); end; procedure ComputeSearchPath(const Path: array of TFileName; out SearchPath: TFileNameDynArray); var i: integer; begin if length(Path)=0 then begin SetLength(SearchPath,1); SearchPath[0] := ExeVersion.ProgramFilePath; // use .exe path end else begin SetLength(SearchPath,length(Path)); for i := 0 to high(Path) do SearchPath[i] := ExpandFileName(Path[i]); // also convert \ if needed on FPC end; end; procedure AddToServerWrapperMethod(Server: TSQLRestServer; const Path: array of TFileName; const SourcePath: TFileName); var hook: TWrapperMethodHook; begin if Server=nil then exit; hook := TWrapperMethodHook.Create; Server.PrivateGarbageCollector.Add(hook); // Server.Free will call hook.Free ComputeSearchPath(Path,hook.SearchPath); hook.SourcePath := SourcePath; Server.ServiceMethodRegisterPublishedMethods('',hook); Server.ServiceMethodByPassAuthentication('wrapper'); end; function FindTemplate(const TemplateName: TFileName; const Path: array of TFileName): TFileName; var SearchPath: TFileNameDynArray; i: integer; begin ComputeSearchPath(Path,SearchPath); for i := 0 to High(SearchPath) do begin result := IncludeTrailingPathDelimiter(SearchPath[i])+TemplateName; if FileExists(result) then exit; end; result := ''; end; procedure ComputeFPCServerUnit(Server: TSQLRestServer; const Path: array of TFileName; DestFileName: TFileName); var TemplateName: TFileName; begin TemplateName := FindTemplate('FPCServer-mORMotServer.pas.mustache',Path); if TemplateName='' then exit; if DestFileName='' then DestFileName := 'mORMotServer.pas' else if DestFileName[1]=PathDelim then DestFileName := ExtractFilePath(TemplateName)+DestFileName; FileFromString(WrapperFromModel(Server,AnyTextFileToRawUTF8(TemplateName,true), StringToUTF8(ExtractFileName(DestFileName)),0),DestFileName); end; procedure ComputeFPCInterfacesUnit(const Path: array of TFileName; DestFileName: TFileName); const TEMPLATE_NAME = 'FPC-mORMotInterfaces.pas.mustache'; var TemplateName: TFileName; ctxt: variant; begin TemplateName := FindTemplate(TEMPLATE_NAME,Path); if TemplateName='' then exit; if DestFileName='' then DestFileName := 'mORMotInterfaces.pas' else if DestFileName[1]=PathDelim then DestFileName := ExtractFilePath(TemplateName)+DestFileName; with TWrapperContext.CreateFromUsedInterfaces('') do try ctxt := Context; finally Free; end; ctxt.fileName := GetFileNameWithoutExt(ExtractFileName(DestFileName)); FileFromString(TSynMustache.Parse(AnyTextFileToRawUTF8(TemplateName,true)). Render(ctxt,nil,nil,nil,true),DestFileName); end; {$ifdef ISDELPHI20062007} {$WARNINGS OFF} // circument Delphi 2007 false positive warning {$endif} function GenerateAsynchServices(const services: array of TGUID; const queries: array of TClass; const units: array of const; const additionalcontext: array of const; Template, FileName, ProjectName, CallType, CallFunction, Key, KeyType, ExceptionType: RawUTF8; DefaultDelay: integer; const CustomDelays: array of const): RawUTF8; var server: TSQLRestServerFullMemory; stub: IInvokable; context: variant; service, method: PDocVariantData; pas, intf, meth: RawUTF8; delay: Int64; i: integer; begin result := ''; if high(services) < 0 then exit; if FileName = '' then FileName := 'ServicesAsynch'; if CallType = '' then CallType := 'TBlockingProcessPoolCall'; if ExceptionType = '' then ExceptionType := 'EServiceException'; server := TSQLRestServerFullMemory.CreateWithOwnModel([]); try for i := 0 to high(services) do server.ServiceDefine(TInterfaceStub.Create(services[i], stub). LastInterfacedObjectFake, [services[i]]); context := ContextFromModel(server); _Safe(context)^.AddNameValuesToObject(['filename', FileName, 'projectname', ProjectName, 'exeName', ExeVersion.ProgramName, 'User', ExeVersion.User, 'calltype', CallType, 'callfunction', CallFunction, 'exception', ExceptionType, 'defaultdelay', DefaultDelay]); if high(units) >= 0 then _Safe(context.units)^.AddItems(units); if Key <> '' then _Safe(context)^.AddNameValuesToObject(['asynchkey', Key, 'asynchkeytype', KeyType]); _Safe(context)^.AddNameValuesToObject(additionalcontext); for i := 0 to high(services) do if i < length(queries) then begin intf := ToUTF8(TInterfaceFactory.GUID2TypeInfo(services[i])^.Name); if _Safe(context.soa.services)^.GetDocVariantByProp( 'interfaceName', intf, false, service) then service^.AddValue('query', queries[i].ClassName) else raise EWrapperContext.CreateUTF8('CustomDelays: unknown %', [intf]); end; i := 0; while i + 2 <= high(CustomDelays) do begin if VarRecToUTF8IsString(CustomDelays[i], intf) and VarRecToUTF8IsString(CustomDelays[i + 1], meth) and VarRecToInt64(CustomDelays[i + 2], delay) then if _Safe(context.soa.services)^.GetDocVariantByProp( 'interfaceName',intf, false, service) and service^.GetAsDocVariantSafe('methods')^.GetDocVariantByProp( 'methodName', meth, false, method) then method^.I['asynchdelay'] := delay else raise EWrapperContext.CreateUTF8('CustomDelays: unknown %.%', [intf, meth]); inc(i, 3); end; pas := TSynMustache.Parse(Template).Render(context, nil, TSynMustache.HelpersGetStandardList); result := StringReplaceAll(pas, ['();', ';', '():', ':']); //FileFromString(_Safe(context)^.ToJSON('','',jsonUnquotedPropName),FileName+'.json'); finally server.Free; end; end; {$ifdef ISDELPHI20062007} {$WARNINGS ON} // circument Delphi 2007 false positive warning {$endif} { TServiceClientCommandLine } type /// a class implementing ExecuteFromCommandLine() TServiceClientCommandLine = class(TSynPersistent) protected fExe: RawUTF8; fOptions: TServiceClientCommandLineOptions; fServices: array of TInterfaceFactory; fDescriptions: TDocVariantData; fOnCall: TOnCommandLineCall; procedure ToConsole(const Fmt: RawUTF8; const Args: array of const; Color: TConsoleColor = ccLightGray; NoLineFeed: boolean = false); function Find(const name: RawUTF8; out service: TInterfaceFactory): boolean; procedure WriteDescription(desc: RawUTF8; color: TConsoleColor; firstline: boolean); procedure ShowHelp; procedure ShowAllServices; procedure ShowService(service: TInterfaceFactory); procedure ShowMethod(service: TInterfaceFactory; method: PServiceMethod); procedure ExecuteMethod(service: TInterfaceFactory; method: PServiceMethod; firstparam: integer); public constructor Create(const aServices: array of TGUID; const aOnCall: TOnCommandLineCall; const aDescriptions: TFileName); reintroduce; procedure Execute; destructor Destroy; override; end; {$I-} procedure TServiceClientCommandLine.ToConsole(const Fmt: RawUTF8; const Args: array of const; Color: TConsoleColor; NoLineFeed: boolean); begin ConsoleWrite(FormatUTF8(Fmt, Args), Color, NoLineFeed, cloNoColor in fOptions); end; function TServiceClientCommandLine.Find(const name: RawUTF8; out service: TInterfaceFactory): boolean; var s: integer; begin for s := 0 to high(fServices) do if IdemPropNameU(fServices[s].InterfaceURI, name) then begin service := fServices[s]; result := true; exit; end; result := false; end; procedure TServiceClientCommandLine.WriteDescription(desc: RawUTF8; color: TConsoleColor; firstline: boolean); var line: RawUTF8; P: PUTF8Char; i, j, k, l: integer; begin if not(cloNoColor in fOptions) then TextColor(color); if firstline then SetLength(desc, PosExChar(#13, desc) - 1); if desc = '' then exit; P := pointer(desc); repeat line := GetNextLine(P,P); if line = '' then continue; if line = '----' then begin if not(cloNoColor in fOptions) then TextColor(ccBrown); end else begin line := StringReplaceAll(line, ['`','', '<<','', '>>','']); i := 1; repeat j := PosEx('[', line, i); if j = 0 then break; k := PosEx('](', line, j + 1); if k = 0 then break; l := PosEx(')', line, k + 2); if l = 0 then break; delete(line, k, l - k + 1); delete(line, j, 1); i := k; until false; writeln(line); end; until P = nil; end; procedure TServiceClientCommandLine.ShowHelp; begin ToConsole('% %'#13#10, [fExe, ExeVersion.Version.DetailedOrVoid], ccLightGreen); ToConsole(EXECUTEFROMCOMMANDLINEHELP, [fExe, fExe, fExe, fExe]); end; procedure TServiceClientCommandLine.ShowAllServices; var i: integer; begin for i := 0 to high(fServices) do begin ToConsole('% %', [fExe, fServices[i].InterfaceURI], ccWhite); WriteDescription(fDescriptions.U[fServices[i].InterfaceName], ccLightGray, true); end; end; procedure TServiceClientCommandLine.ShowService(service: TInterfaceFactory); var m: integer; begin ToConsole('% %', [fExe, service.InterfaceURI], ccWhite); WriteDescription(fDescriptions.U[service.InterfaceName], ccLightGray, false); for m := 0 to service.MethodsCount - 1 do with service.Methods[m] do begin ToConsole('% % % [parameters]', [fExe, service.InterfaceURI, URI], ccWhite); WriteDescription(fDescriptions.U[InterfaceDotMethodName], ccLightGray, true); end; end; procedure TServiceClientCommandLine.ShowMethod(service: TInterfaceFactory; method: PServiceMethod); procedure Arguments(input: boolean); const IN_OUT: array[boolean] of RawUTF8 = ('OUT', ' IN'); var i: integer; line, typ: RawUTF8; begin ToConsole('%', [IN_OUT[input]], ccDarkGray, {nolinefeed=}true); if not input and method^.ArgsResultIsServiceCustomAnswer then line := ' is undefined' else begin line := ' { '; i := 0; while method^.ArgNext(i, input) do with method^.Args[i] do begin typ := TYPES_LANG[lngCS, TYPES_SOA[ValueType]]; if typ = '' then ShortStringToAnsi7String(ArgTypeName^, typ); line := FormatUTF8('%"%":%, ', [line, ParamName^, typ]); end; i := length(line); line[i - 1] := ' '; line[i] := '}'; end; ToConsole('%', [line], ccDarkGray); end; begin ToConsole('% % % [parameters]', [fExe, service.InterfaceURI, method.URI], ccWhite); WriteDescription(fDescriptions.U[method.InterfaceDotMethodName], ccLightGray, false); if method.ArgsInputValuesCount <> 0 then Arguments({input=}true); if method.ArgsOutputValuesCount <> 0 then Arguments({input=}false); end; procedure TServiceClientCommandLine.ExecuteMethod(service: TInterfaceFactory; method: PServiceMethod; firstparam: integer); var params, result: RawUTF8; i: integer; cc: TConsoleColor; call: TSQLRestURIParams; begin call.Init; if cloPipe in fOptions then call.InBody := ConsoleReadBody else begin for i := firstparam to ParamCount do params := FormatUTF8('% %', [params, ParamStr(i)]); //writeln(params); // for debugging call.InBody := method^.ArgsCommandLineToObject(pointer(params), {input=}true, true); end; // writeln(call.InBody); exit; if [cloVerbose, cloHeaders] * fOptions <> [] then ToConsole('POST %', [method.InterfaceDotMethodName], ccLightGray); if cloVerbose in fOptions then ToConsole('%', [call.InBody], ccLightBlue); if not Assigned(fOnCall) then raise EServiceException.CreateUTF8('No Client available to call %', [method.InterfaceDotMethodName]); fOnCall(fOptions, service, method, call); // will set URI + Bearer if [cloVerbose, cloHeaders] * fOptions <> [] then ToConsole('HTTP %'#13#10'%', [call.OutStatus, call.OutHead], ccLightGray); if (call.OutBody <> '') and (call.OutBody[1] = '[') then call.OutBody := method^.ArgsArrayToObject(pointer(call.OutBody), false); if cloNoBody in fOptions then FormatUTF8('% bytes received', [length(call.OutBody)], result) else if (cloNoExpand in fOptions) or not call.OutBodyTypeIsJson then result := call.OutBody else JSONBufferReformat(pointer(call.OutBody), result); cc := ccWhite; if not StatusCodeIsSuccess(call.OutStatus) then cc := ccLightRed; ToConsole('%', [result], cc, {nofeed=}true); end; constructor TServiceClientCommandLine.Create(const aServices: array of TGUID; const aOnCall: TOnCommandLineCall; const aDescriptions: TFileName); var desc: RawByteString; n, s, i: integer; begin inherited Create; fExe := {$ifndef MSWINDOWS}'./' + {$endif} ExeVersion.ProgramName; n := length(aServices); SetLength(fServices, n); s := 0; for i := 0 to n - 1 do begin fServices[s] := TInterfaceFactory.Get(aServices[i]); if fServices[s] <> nil then inc(s); end; if s = 0 then raise EServiceException.Create('ExecuteFromCommandLine: no service - did you call RegisterInterfaces()?'); if s <> n then SetLength(fServices, s); fOnCall := aOnCall; TDocVariant.NewFast([@fDescriptions]); if aDescriptions <> '' then desc := StringFromFile(aDescriptions); if desc = '' then ResourceSynLZToRawByteString(WRAPPER_RESOURCENAME, desc); if desc <> '' then fDescriptions.InitJSONInPlace(pointer(desc), JSON_OPTIONS_FAST); end; procedure TServiceClientCommandLine.Execute; var p: array[0..3] of RawUTF8; a: PUTF8Char; i, j, n, first: integer; s: TInterfaceFactory; m: PServiceMethod; begin first := 3; n := 0; for i := 1 to ParamCount do begin StringToUTF8(ParamStr(i), p[n]); a := pointer(p[n]); if a^ in ['-', '/'] then begin inc(a); if a^ = '-' then inc(a); j := PTypeInfo(TypeInfo(TServiceClientCommandLineOptions))^.SetEnumType^. GetEnumNameTrimedValue(a); if j >= 0 then begin SetBitPtr(@fOptions, j); if n < high(p) then inc(first); continue; end; raise EServiceException.CreateUTF8('%.Execute: unknown option [%]', [self, p[n]]); end; if n < high(p) then inc(n); end; case n of 0: ShowHelp; 1: if Find(p[0], s) then ShowService(s) else ShowAllServices; else if Find(p[0], s) then begin m := s.FindMethod(p[1]); if m = nil then ShowService(s) else if IdemPropNameU(p[2], 'help') or ((m^.ArgsInputValuesCount <> 0) and (PosExChar('=', p[2]) = 0)) then ShowMethod(s, m) else ExecuteMethod(s, m, first); end else ShowAllServices; end; ToConsole('', [], ccDarkGray); end; destructor TServiceClientCommandLine.Destroy; begin inherited Destroy; end; {$I+} procedure ExecuteFromCommandLine(const aServices: array of TGUID; const aOnCall: TOnCommandLineCall; const aDescriptions: TFileName); begin with TServiceClientCommandLine.Create(aServices, aOnCall, aDescriptions) do try try Execute; except on E: Exception do ConsoleShowFatalException(E, {waitforkey=}false); end; finally Free; end; end; end.