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