1unit extjsjson;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8  Classes, SysUtils, httpdefs, fphttp, fpwebdata, fpextjs, fpjson, db, jsonparser;
9
10type
11
12  { TExtJSJSonWebdataInputAdaptor }
13
14  TExtJSJSonWebdataInputAdaptor = CLass(TCustomWebdataInputAdaptor)
15  private
16    FRows : TJSONArray;
17    FCurrentRow : TJSONObject;
18    FRowIndex : integer;
19    function CheckData: Boolean;
20  Public
21    procedure reset; override;
22    Function GetNextBatch : Boolean; override;
23    Function TryFieldValue(Const AFieldName : String; out AValue : String) : Boolean; override;
24    Destructor destroy; override;
25  end;
26
27  { TExtJSJSONDataFormatter }
28  TJSONObjectEvent = Procedure(Sender : TObject; AObject : TJSONObject) of Object;
29  TJSONExceptionObjectEvent = Procedure(Sender : TObject; E : Exception; AResponse : TJSONObject) of Object;
30  TJSONObjectAllowRowEvent = Procedure(Sender : TObject; Dataset : TDataset; Var Allow : Boolean) of Object;
31  TJSONObjectAllowEvent = Procedure(Sender : TObject; AObject : TJSONObject; Var Allow : Boolean) of Object;
32
33  TExtJSJSONDataFormatter = Class(TExtJSDataFormatter)
34  private
35    FAfterDataToJSON: TJSONObjectEvent;
36    FAfterDelete: TJSONObjectEvent;
37    FAfterInsert: TJSONObjectEvent;
38    FAfterRowToJSON: TJSONObjectEvent;
39    FAfterUpdate: TJSONObjectEvent;
40    FBeforeDataToJSON: TJSONObjectEvent;
41    FBeforeDelete: TNotifyEvent;
42    FBeforeInsert: TNotifyEvent;
43    FBeforeRowToJSON: TJSONObjectEvent;
44    FBeforeUpdate: TNotifyEvent;
45    FOnAllowRow: TJSONObjectAllowRowEvent;
46    FOnErrorResponse: TJSONExceptionObjectEvent;
47    FOnMetaDataToJSON: TJSONObjectEvent;
48    FBatchResult : TJSONArray;
49    Function AddIdToBatch : TJSONObject;
50    procedure SendSuccess(ResponseContent: TStream; AddIDValue : Boolean = False);
51  protected
52    function AllowRow(ADataset : TDataset) : Boolean; virtual;
53    Procedure StartBatch(ResponseContent : TStream); override;
54    Procedure NextBatchItem(ResponseContent : TStream); override;
55    Procedure EndBatch(ResponseContent : TStream); override;
56    Function CreateAdaptor(ARequest : TRequest) : TCustomWebdataInputAdaptor; override;
57    Function AddFieldToJSON(O: TJSONObject; AFieldName: String; F: TField): TJSONData;
58    function GetDataContentType: String; override;
59    Function GetJSONMetaData: TJSONObject;
60    function RowToJSON: TJSONObject;
61    Procedure DoBeforeRow(ARow : TJSONObject); virtual;
62    Procedure DoAfterRow(ARow : TJSONObject); virtual;
63    Procedure DoBeforeData(AResponse : TJSONObject); virtual;
64    Procedure DoAfterData(AResponse : TJSONObject); virtual;
65    Procedure DoOnMetaData(AMetadata : TJSONObject); virtual;
66    procedure DatasetToStream(Stream: TStream); override;
67    Procedure DoExceptionToStream(E : Exception; ResponseContent : TStream); override;
68    Procedure DoInsertRecord(ResponseContent : TStream); override;
69    Procedure DoUpdateRecord(ResponseContent : TStream); override;
70    Procedure DoDeleteRecord(ResponseContent : TStream); override;
71  Public
72    Destructor destroy; override;
73  Published
74    // Called before any fields are added to row object (passed to handler).
75    Property AfterRowToJSON : TJSONObjectEvent Read FAfterRowToJSON Write FAfterRowToJSON;
76    // Called After all fields are added to row object (passed to handler).
77    Property BeforeRowToJSON : TJSONObjectEvent Read FBeforeRowToJSON Write FBeforeRowToJSON;
78    // Called when metadata object has been created (passed to handler).
79    Property OnMetaDataToJSON : TJSONObjectEvent Read FOnMetaDataToJSON Write FOnMetaDataToJSON;
80    // Called when response object has been created, and has Rows property (response passed to handler).
81    Property AfterDataToJSON : TJSONObjectEvent Read FAfterDataToJSON Write FAfterDataToJSON;
82    // Called just before response object will be streamed (response passed to handler).
83    Property BeforeDataToJSON : TJSONObjectEvent Read FBeforeDataToJSON Write FBeforeDataToJSON;
84    // Called when an exception is caught and formatted.
85    Property OnErrorResponse : TJSONExceptionObjectEvent Read FOnErrorResponse Write FOnErrorResponse;
86    // Called to decide whether a record is sent to the client;
87    Property OnAllowRow : TJSONObjectAllowRowEvent Read FOnAllowRow Write FOnAllowRow;
88    // After a record was succesfully updated
89    Property AfterUpdate : TJSONObjectEvent Read FAfterUpdate Write FAfterUpdate;
90    // After a record was succesfully inserted.
91    Property AfterInsert : TJSONObjectEvent Read FAfterInsert Write FAfterInsert;
92    // After a record was succesfully inserted.
93    Property AfterDelete : TJSONObjectEvent Read FAfterDelete Write FAfterDelete;
94    // From TCustomHTTPDataContentProducer
95    Property BeforeUpdate;
96    Property BeforeInsert;
97    Property BeforeDelete;
98  end;
99
100implementation
101{ $define wmdebug}
102{$ifdef wmdebug}
103uses dbugintf;
104{$endif wmdebug}
105
106Resourcestring
107  SErrWrongDataFormat = 'Post ROWS data has wrong value type. Expected array or object, got : %s.';
108  SerrNoExceptionMessage = 'No exception to take error message from.';
109
110Const
111  // Do not localize these strings
112  SDefMetaDataProperty  = 'metaData';
113  SDefFieldsProperty    = 'fields';
114  SDefFieldProperty     = 'field';
115  SDefFieldNameProperty = 'name';
116  SDefDirectionProperty = 'direction';
117  SDefSortInfoProperty  = 'sortInfo';
118  SIdProperty           = 'idProperty';
119  SSuccessProperty      = 'successProperty';
120  SRootProperty         = 'root';
121  STotalProperty        = 'totalProperty';
122  SDefAscDesc : Array[Boolean] of string = ('ASC','DESC');
123
124function TExtJSJSONDataFormatter.GetDataContentType: String;
125begin
126  Result:='text/html';
127end;
128
129function TExtJSJSONDataFormatter.CreateAdaptor(ARequest: TRequest
130  ): TCustomWebdataInputAdaptor;
131begin
132  Result:=TExtJSJSonWebdataInputAdaptor.Create(Self);
133  Result.Request:=ARequest;
134end;
135
136function TExtJSJSONDataFormatter.AddFieldToJSON(O : TJSONObject; AFieldName : String; F : TField): TJSONData;
137
138Var
139  S : String;
140
141
142begin
143 if F.IsNull then
144   Result:=O.Items[O.Add(AFieldName)]
145 else
146  Case F.DataType of
147    ftSmallint,
148    ftInteger,
149    ftAutoInc,
150    ftWord:
151      Result:=O.Items[O.Add(AFieldName,F.AsInteger)];
152    ftBoolean:
153      Result:=O.Items[O.Add(AFieldName,F.AsBoolean)];
154    ftLargeint:
155      Result:=O.Items[O.Add(AFieldName,F.AsLargeInt)];
156    ftDate:
157      Result:=O.Items[O.Add(AFieldName,FormatDateTime('yyyy-mm-dd',F.AsDateTime))];
158    ftDateTime:
159      Result:=O.Items[O.Add(AFieldName,FormatDateTime('yyyy-mm-dd hh":"nn":"ss',F.AsDateTime))];
160    ftTime:
161      Result:=O.Items[O.Add(AFieldName,FormatDateTime('hh":"nn":"ss',F.AsDateTime))];
162    ftMemo,
163    ftFmtMemo,
164    ftWideMemo,
165    ftBlob :
166      begin
167      S:=F.AsString;
168      If (OnTranscode<>Nil) then
169        OnTranscode(Self,F,S,True);
170      Result:=O.Items[O.Add(AFieldName,S)];
171      end;
172  else
173    S:=F.DisplayText;
174    If (OnTranscode<>Nil) then
175      OnTranscode(Self,F,S,True);
176    Result:=O.Items[O.Add(AFieldName,S)];
177  end;
178end;
179
180function TExtJSJSONDataFormatter.RowToJSON: TJSONObject;
181
182Var
183  F : TField;
184  I : Integer;
185
186
187begin
188  Result:=TJSONObject.Create();
189  try
190    DobeforeRow(Result);
191    For I:=0 to Dataset.Fields.Count-1 do
192      begin
193      F:=Dataset.Fields[I];
194      AddFieldToJSON(Result,F.FieldName,F);
195      end;
196    DoAfterRow(Result);
197  except
198    Result.Free;
199    Raise;
200  end;
201end;
202
203procedure TExtJSJSONDataFormatter.DoBeforeRow(ARow: TJSONObject);
204begin
205  If Assigned(FBeforeRowToJSON) then
206    FBeforeRowToJSON(Self,ARow);
207end;
208
209procedure TExtJSJSONDataFormatter.DoAfterRow(ARow: TJSONObject);
210begin
211  If Assigned(FAfterRowToJSON) then
212    FAfterRowToJSON(Self,ARow);
213end;
214
215procedure TExtJSJSONDataFormatter.DoBeforeData(AResponse: TJSONObject);
216begin
217  If Assigned(FBeforeDataToJSON) then
218    FBeforeDataToJSON(Self,AResponse);
219end;
220
221procedure TExtJSJSONDataFormatter.DoAfterData(AResponse: TJSONObject);
222begin
223  If Assigned(FAfterDataToJSON) then
224    FAfterDataToJSON(Self,AResponse);
225end;
226
227procedure TExtJSJSONDataFormatter.DoOnMetaData(AMetadata: TJSONObject);
228begin
229  If Assigned(FOnMetaDataToJSON) then
230    FOnMetaDataToJSON(Self,AMetaData);
231end;
232
233Function TExtJSJSONDataFormatter.GetJSONMetaData: TJSONObject;
234
235  Function DefReplace(S : String) : String;
236
237  begin
238    Result:=StringReplace(Result,'/',DateSeparator,[rfReplaceAll]);
239    Result:=StringReplace(Result,':',TimeSeparator,[rfReplaceAll]);
240    Result:=StringReplace(Result,'hh','H',[rfReplaceAll]);
241    Result:=StringReplace(Result,'nn','i',[rfReplaceAll]);
242    Result:=StringReplace(S,'n','i',[rfReplaceAll]);
243  end;
244
245Var
246  F : TJSONArray;
247  Fi : TField;
248  I : Integer;
249  O : TJSONObject;
250  SF,FT : String;
251
252begin
253  If (SortField='') then
254    SF:=Dataset.Fields[0].FieldName
255  else
256    SF:=SortField;
257  Result:=TJSonObject.Create;
258  try
259    F:=TJSONArray.Create;
260    Result.add(SDefFieldsProperty,F);
261    For I:=0 to Dataset.Fields.Count-1 do
262      begin
263      Fi:=Dataset.Fields[i];
264      O:=TJSONObject.Create();
265      O.Add(SDefFieldNameProperty,Fi.FieldName);
266      Ft:='';
267      Case Fi.DataType of
268        ftInteger,
269        ftSmallint,
270        ftWord,
271        ftLargeInt : FT:='int';
272        ftCurrency,
273        ftFloat,
274        ftBCD : FT:='float';
275        ftBoolean : ft:='boolean';
276        ftDate,
277        ftDateTime,
278        ftTimeStamp,
279        ftTime : ft:='date';
280        ftString,
281        ftMemo,
282        ftFmtMemo,
283        ftFixedChar,
284        ftWideString,
285        ftWideMemo : ft:='string'
286      end;
287      if (FT<>'') then
288        begin
289        O.Add('type',FT);
290        if (FT='date') then
291          // Needs improving
292          Case Fi.DataType of
293            ftDate : O.Add('dateFormat','Y-m-d');
294            ftTime : O.Add('dateFormat','H:i:s');
295            ftDateTime,
296            ftTimeStamp : O.Add('dateFormat','Y-m-d H:i:s');
297          end;
298        end;
299      F.Add(O);
300      end;
301    O:=TJSONObject.Create();
302    O.Add(SDefFieldProperty,SF);
303    O.Add(SDefDirectionProperty,SDefAscDesc[SortDescending]);
304    Result.Add(SDefSortInfoProperty,O);
305 {$ifdef wmdebug}senddebug('ID property: '+Provider.IDFieldName);{$endif}
306    Result.Add(SIdProperty,Provider.IDFieldName);
307    Result.Add(SSuccessProperty, SuccessProperty);
308    Result.Add(SRootProperty, RowsProperty);
309    Result.Add(STotalProperty, totalProperty);
310    DoOnMetaData(Result);
311  except
312    Result.free;
313    Raise;
314  end;
315end;
316
317procedure TExtJSJSONDataFormatter.DatasetToStream(Stream: TStream);
318
319Var
320  Rows : TJSONArray;
321  Meta,Resp : TJSONObject;
322  L : String;
323  DS : TDataset;
324  i,RCount,ACount : Integer;
325
326begin
327  Rows:=Nil;
328  Resp:=TJSONObject.Create;
329  try
330    Rows:=TJSONArray.Create();
331    Resp.Add(RowsProperty,Rows);
332    DoBeforeData(Resp);
333    DS:=Dataset;
334    DS.First;
335    RCount:=0;
336    If MetaData then
337      begin
338      Meta:=GetJSONMetaData;
339      Resp.Add(SDefMetaDataProperty,Meta);
340      end;
341    // Go to start
342    ACount:=PageStart;
343    While (Not DS.EOF) and (ACount>0) do
344      begin
345      DS.Next;
346      Dec(ACount);
347      Inc(RCount);
348      end;
349    ACount:=PageSize;
350    While (not DS.EOF) and ((PageSize=0) or (ACount>0)) do
351      begin
352      If AllowRow(DS) then
353        begin
354        Inc(RCount);
355        Dec(ACount);
356        Rows.Add(RowToJSON);
357        end;
358      DS.Next;
359      end;
360    If (PageSize>0) then
361      While (not DS.EOF) do
362        begin
363        Inc(RCount);
364        DS.Next;
365        end;
366    Resp.Add(SuccessProperty,True);
367    If (PageSize>0) then
368       Resp.Add(TotalProperty,RCount);
369    DoAfterData(Resp);
370    L:=Resp.AsJSON;
371    Stream.WriteBuffer(L[1],Length(L));
372  finally
373    Resp.Free;
374  end;
375end;
376
377procedure TExtJSJSONDataFormatter.DoExceptionToStream(E: Exception;
378  ResponseContent: TStream);
379
380Var
381   Resp : TJSonObject;
382   L : String;
383
384begin
385  Resp:=tjsonObject.Create();
386  try
387    Resp.Add(SuccessProperty,False);
388    If Assigned(E) then
389      Resp.Add(MessageProperty,E.Message)
390    else
391      Resp.Add(MessageProperty,SerrNoExceptionMessage);
392    L:=Resp.AsJSON;
393    If Length(L)>0 then
394      ResponseContent.WriteBuffer(L[1],Length(L));
395    Resp.Add('root',RowsProperty);
396    Resp.Add(RowsProperty,TJSONArray.Create());
397    If Assigned(FOnErrorResponse) then
398      FOnErrorResponse(Self,E,Resp);
399  finally
400    Resp.Free;
401  end;
402end;
403
404procedure TExtJSJSONDataFormatter.SendSuccess(ResponseContent: TStream; AddIDValue : Boolean = False);
405
406Var
407   Resp : TJSonObject;
408   L : String;
409
410begin
411  try
412    Resp:=TJsonObject.Create;
413    Resp.Add(SuccessProperty,True);
414    Resp.Add('root',Self.RowsProperty);
415    If Assigned(FBatchResult) and (FBatchResult.Count>0) then
416      begin
417      Resp.Add(Self.RowsProperty,FBatchResult);
418      FBatchResult:=Nil;
419      end
420    else
421      Resp.Add(Self.RowsProperty,TJSONNull.Create());
422    L:=Resp.AsJSON;
423    ResponseContent.WriteBuffer(L[1],Length(L));
424  finally
425    Resp.Free;
426  end;
427end;
428
429function TExtJSJSONDataFormatter.AllowRow(ADataset: TDataset): Boolean;
430begin
431  Result:=True;
432  If Assigned(FOnAllowRow) then
433    FOnAllowRow(Self,Dataset,Result);
434end;
435
436procedure TExtJSJSONDataFormatter.StartBatch(ResponseContent: TStream);
437begin
438  If Assigned(FBatchResult) then
439    FBatchResult.Clear
440  else
441    FBatchResult:=TJSONArray.Create();
442end;
443
444procedure TExtJSJSONDataFormatter.NextBatchItem(ResponseContent: TStream);
445begin
446end;
447
448procedure TExtJSJSONDataFormatter.EndBatch(ResponseContent: TStream);
449begin
450  SendSuccess(Responsecontent,True);
451end;
452
453Function TExtJSJSONDataFormatter.AddIdToBatch : TJSONObject;
454
455begin
456  Result:=TJSONObject.Create([Provider.IDFieldName,Provider.IDFieldValue]);
457  FBatchResult.Add(Result);
458end;
459
460procedure TExtJSJSONDataFormatter.DoInsertRecord(ResponseContent: TStream);
461
462Var
463  D : TJSONObject;
464
465begin
466  Inherited;
467  D:=AddIDToBatch;
468  If Assigned(FAfterInsert) then
469    FAfterInsert(Self,D);
470end;
471
472procedure TExtJSJSONDataFormatter.DoUpdateRecord(ResponseContent: TStream);
473
474Var
475  D : TJSONObject;
476
477begin
478  inherited DoUpdateRecord(ResponseContent);
479  D:=AddIDToBatch;
480  If Assigned(FAfterUpdate) then
481    FAfterUpdate(Self,D);
482end;
483
484procedure TExtJSJSONDataFormatter.DoDeleteRecord(ResponseContent: TStream);
485begin
486  inherited DoDeleteRecord(ResponseContent);
487  If Assigned(FAfterDelete) then
488    FAfterDelete(Self,Nil);
489end;
490
491destructor TExtJSJSONDataFormatter.destroy;
492begin
493  FreeAndNil(FBatchResult);
494  inherited destroy;
495end;
496
497{ TExtJSJSonWebdataInputAdaptor }
498
499function TExtJSJSonWebdataInputAdaptor.CheckData : Boolean;
500
501Var
502  D : TJSONData;
503  P : TJSONParser;
504  S : String;
505
506begin
507  Result:=Assigned(FCurrentRow);
508  If Not (Result) and TryParamValue('rows',S) then
509    begin
510    {$ifdef wmdebug}senddebug('Check data: '+GetParamValue('rows'));{$endif}
511    P:=TJSONParser.Create(S);
512    try
513      D:=P.Parse;
514      {$ifdef wmdebug}senddebug('Classname : '+D.ClassName);{$endif}
515      If D is TJSONArray then
516        begin
517        FRows:=TJSONArray(D);
518        FRowIndex:=0;
519        FCurrentRow:=FRows.Items[0] as TJSONObject;
520        end
521      else If D is TJSONObject then
522        begin
523        FRows:=Nil;
524        FCurrentRow:=TJSONObject(D);
525        end
526      else if D is TJSONInt64Number then
527        begin
528        FRows:=nil;
529        FCurrentRow:=TJSONObject.Create(['ID',D]);
530        end
531      else
532        begin
533        FreeAndNil(D);
534        Raise EFPHTTPError.CreateFmt(SErrWrongDataFormat,[D.ClassName]);
535        end;
536      Result:=True;
537    finally
538      P.Free;
539    end;
540    end;
541end;
542
543procedure TExtJSJSonWebdataInputAdaptor.reset;
544begin
545  If (FRows=Nil) then
546    FreeAndNil(FCurrentRow)
547  else
548    FreeAndNil(FRows);
549  FRowIndex:=0;
550  inherited reset;
551end;
552
553function TExtJSJSonWebdataInputAdaptor.GetNextBatch: Boolean;
554begin
555  If (FRows=Nil) then
556    Result:=inherited GetNextBatch
557  else
558    begin
559    Result:=FRowindex<FRows.Count-1;
560    Inc(FRowIndex);
561    If Result then
562      FCurrentRow:=FRows.Items[FRowIndex] as TJSONObject
563    else
564      FCurrentRow:=Nil;
565    end;
566end;
567
568function TExtJSJSonWebdataInputAdaptor.TryFieldValue(const AFieldName: String;
569  out AValue: String): Boolean;
570
571Var
572  I : Integer;
573
574begin
575  Result:=False;
576  if CheckData then
577    begin
578    I:=FCurrentRow.IndexOfName(AFieldName);
579    Result:=I<>-1;
580    if result and (FCurrentRow.Items[I].JSONType<>jtNull) then
581      AValue:=FCurrentRow.Items[I].AsString;
582    end;
583end;
584
585destructor TExtJSJSonWebdataInputAdaptor.destroy;
586begin
587  If Assigned(FRows) then
588    FreeAndNil(FRows)
589  else if assigned(FCurrentRow) then
590    FreeAndNil(FCurrentRow);
591  inherited destroy;
592end;
593
594initialization
595  WebDataProviderManager.RegisterInputAdaptor('ExtJS - JSON',TExtJSJSONWebdataInputAdaptor);
596  WebDataProviderManager.RegisterDataProducer('ExtJS - JSON',TExtJSJSONDataFormatter);
597
598finalization
599  WebDataProviderManager.UnRegisterInputAdaptor('ExtJS - JSON');
600  WebDataProviderManager.UnRegisterDataProducer('ExtJS - JSON')
601end.
602
603