1{
2    This file is part of the Free Pascal run time library.
3    Copyright (c) 2019 by the Free Pascal development team
4
5    SQLDB REST bridge : XML input/output
6
7    See the file COPYING.FPC, included in this distribution,
8    for details about the copyright.
9
10    This program is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************}
15unit sqldbrestxml;
16
17{$mode objfpc}{$H+}
18
19interface
20
21uses
22  Classes, SysUtils, DateUtils, db,fpjson, dom, XMLRead, XMLWrite,sqldbrestschema,sqldbrestio, sqldbrestbridge;
23
24Type
25
26  { TXMLInputStreamer }
27
28  TXMLInputStreamer = Class(TRestInputStreamer)
29  private
30    FXML: TXMLDocument;
31    FPacket : TDOMElement;
32    FData : TDOMElement;
33    FRow : TDOMElement;
34  Protected
35    function GetNodeText(N: TDOmNode): UnicodeString;
36  Public
37    Destructor Destroy; override;
38    Class Function GetContentType: String; override;
39    Function SelectObject(aIndex : Integer) : Boolean; override;
40    function GetContentField(aName: UTF8string): TJSONData; override;
41    procedure InitStreaming; override;
42    Property XML : TXMLDocument Read FXML;
43    Property Packet : TDOMElement Read FPacket;
44    Property Data : TDOMElement Read FData;
45    Property Row : TDOMElement Read FRow;
46  end;
47
48  { TXMLOutputStreamer }
49
50  TXMLOutputStreamer = Class(TRestOutputStreamer)
51  Private
52    FXML: TXMLDocument;
53    FData : TDOMElement;
54    FRow: TDOMElement;
55    FRoot: TDomElement;
56  Public
57    procedure EndData; override;
58    procedure EndRow; override;
59    procedure FinalizeOutput; override;
60    procedure StartData; override;
61    procedure StartRow; override;
62    // Return Nil for null field.
63    function FieldToXML(aPair: TRestFieldPair): TDOMElement; virtual;
64    procedure WriteField(aPair: TRestFieldPair); override;
65    procedure WriteMetadata(aFieldList: TRestFieldPairArray); override;
66    Procedure CreateErrorContent(aCode : Integer; Const aMessage: String); override;
67    Property XML : TXMLDocument Read FXML;
68    Property Data : TDOMelement Read FData;
69    Property Row : TDOMelement Read FRow;
70  Public
71    Destructor Destroy; override;
72    Class Function GetContentType: String; override;
73    procedure InitStreaming; override;
74  end;
75
76implementation
77
78uses sqldbrestconst;
79
80{ TXMLInputStreamer }
81
82destructor TXMLInputStreamer.Destroy;
83begin
84  FreeAndNil(FXML);
85  inherited Destroy;
86end;
87
88class function TXMLInputStreamer.GetContentType: String;
89begin
90  Result:='text/xml';
91end;
92
93function TXMLInputStreamer.SelectObject(aIndex: Integer): Boolean;
94
95Var
96  N : TDomNode;
97  NN : UnicodeString;
98begin
99  Result:=False;
100  NN:=UTF8Decode(GetString(rpRowName));
101  N:=FData.FindNode(NN);
102  While (aIndex>0) and (N<>Nil) and (N.NodeName<>NN) and (N.NodeType<>ELEMENT_NODE) do
103    begin
104    N:=N.NextSibling;
105    Dec(aIndex);
106    end;
107  Result:=(aIndex=0) and (N<>Nil);
108  If Result then
109    FRow:=N as TDomElement
110  else
111    FRow:=Nil;
112end;
113
114Function TXMLInputStreamer.GetNodeText(N : TDOmNode) : UnicodeString;
115
116Var
117  V : TDomNode;
118
119begin
120  Result:='';
121  V:=N.FirstChild;
122  While (V<>Nil) and (V.NodeType<>TEXT_NODE) do
123    V:=V.NextSibling;
124  If Assigned(V) then
125    Result:=V.NodeValue;
126end;
127
128function TXMLInputStreamer.GetContentField(aName: UTF8string): TJSONData;
129
130Var
131  NN : UnicodeString;
132  N : TDomNode;
133begin
134  NN:=UTF8Decode(aName);
135  N:=FRow.FindNode(NN);
136  if Assigned(N) and (N.NodeType=ELEMENT_NODE) then
137    Result:=TJSONString.Create(UTF8Encode(GetNodeText(N)));
138end;
139
140procedure TXMLInputStreamer.InitStreaming;
141
142Var
143  Msg : String;
144  N : TDomNode;
145  NN : UnicodeString;
146
147begin
148  FreeAndNil(FXML);
149  if Stream.Size<=0 then
150    exit;
151  try
152    ReadXMLFile(FXML,Stream);
153  except
154    On E : Exception do
155      begin
156      Msg:=E.Message;
157      FXML:=Nil;
158      end;
159  end;
160  if (FXML=Nil)  then
161    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[Msg]);
162  FPacket:=FXML.DocumentElement;
163  NN:=UTF8Decode(GetString(rpXMLDocumentRoot));
164  if (NN<>'') then
165    begin
166    if FPacket.NodeName<>NN then
167      Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[SErrMissingDocumentRoot]);
168    NN:=UTF8Decode(GetString(rpDataRoot));
169    N:=FPacket.FindNode(NN);
170    end
171  else
172    begin
173    // if Documentroot is empty, data packet is the root element
174    NN:=UTF8Decode(GetString(rpDataRoot));
175    if (Packet.NodeName=NN) then
176      N:=FPacket
177    else
178      N:=Nil
179    end;
180  if Not (Assigned(N) and (N is TDOMelement)) then
181    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInputMissingElement,[NN]);
182  FData:=(N as TDOMelement);
183end;
184
185{ TXMLOutputStreamer }
186
187
188procedure TXMLOutputStreamer.EndData;
189begin
190  FData:=Nil;
191end;
192
193procedure TXMLOutputStreamer.EndRow;
194begin
195  FRow:=Nil;
196end;
197
198procedure TXMLOutputStreamer.FinalizeOutput;
199
200begin
201{$IFNDEF VER3_0}
202  if Not (ooHumanReadable in OutputOptions) then
203    begin
204    With TDOMWriter.Create(Stream,FXML) do
205      try
206        LineBreak:='';
207        IndentSize:=0;
208        WriteNode(FXML);
209      finally
210        Free;
211      end;
212    end
213  else
214{$ENDIF}
215    xmlwrite.WriteXML(FXML,Stream);
216  FreeAndNil(FXML);
217end;
218
219procedure TXMLOutputStreamer.StartData;
220begin
221  FData:=FXML.CreateElement(UTF8Decode(GetString(rpDataRoot)));
222  FRoot.AppendChild(FData);
223end;
224
225procedure TXMLOutputStreamer.StartRow;
226begin
227  if (FRow<>Nil) then
228    Raise ESQLDBRest.Create(Statuses.GetStatusCode(rsError),SErrDoubleRowStart);
229  FRow:=FXML.CreateElement(UTF8Decode(GetString(rpRowName)));
230  FData.AppendChild(FRow);
231end;
232
233Function TXMLOutputStreamer.FieldToXML(aPair: TRestFieldPair) : TDomElement;
234
235Var
236  F : TField;
237  S : UTF8String;
238
239begin
240  Result:=Nil;
241  F:=aPair.DBField;;
242  If (aPair.RestField.FieldType=rftUnknown) then
243    raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrUnsupportedRestFieldType, [aPair.RestField.PublicName]);
244  If (F.IsNull) then
245    Exit;
246  S:=FieldToString(aPair.RestField.FieldType,F);
247  Result:=FXML.CreateElement(UTF8Decode(aPair.RestField.PublicName));
248  Result.AppendChild(FXML.CreateTextNode(UTF8Decode(S)));
249end;
250
251procedure TXMLOutputStreamer.WriteField(aPair: TRestFieldPair);
252
253Var
254  D : TDOMElement;
255  N : UTF8String;
256
257begin
258  N:=aPair.RestField.PublicName;
259  if FRow=Nil then
260    Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrFieldWithoutRow,[N]);
261  D:=FieldToXML(aPair);
262  if (D=Nil) and (not HasOption(ooSparse)) then
263    D:=FXML.CreateElement(UTF8Decode(aPair.RestField.PublicName));
264  if D<>Nil then
265    FRow.AppendChild(D);
266end;
267
268procedure TXMLOutputStreamer.WriteMetadata(aFieldList: TRestFieldPairArray);
269
270Var
271  M : TDOMElement;
272  F : TDomElement;
273  P : TREstFieldPair;
274begin
275  F:=FXML.CreateElement(UTF8Decode(GetString(rpMetaDataFields)));
276  M:=FXML.CreateElement(UTF8Decode(GetString(rpMetaDataRoot)));
277  M.AppendChild(F);
278  FRoot.AppendChild(M);
279  M:=F;
280  For P in aFieldList do
281    begin
282    F:=FXML.CreateElement(UTF8Decode(GetString(rpMetaDataField)));
283    M.AppendChild(F);
284    F[UTF8Decode(GetString(rpFieldNameProp))]:=UTF8Decode(P.RestField.PublicName);
285    F[UTF8Decode(GetString(rpFieldTypeProp))]:=UTF8Decode(typenames[P.RestField.FieldType]);
286    Case P.RestField.FieldType of
287      rftDate : F[UTF8Decode(GetString(rpFieldDateFormatProp))]:=UTF8Decode(GetString(rpDateFormat));
288      rftTime : F[UTF8Decode(GetString(rpFieldDateFormatProp))]:=UTF8Decode(GetString(rpTimeFormat));
289      rftDateTime : F[UTF8Decode(GetString(rpFieldDateFormatProp))]:=UTF8Decode(GetString(rpDateTimeFormat));
290      rftString : F[UTF8Decode(GetString(rpFieldMaxLenProp))]:=UTF8Decode(IntToStr(P.DBField.Size));
291    end;
292    end;
293end;
294
295class function TXMLOutputStreamer.GetContentType: String;
296begin
297  Result:='text/xml';
298end;
299
300procedure TXMLOutputStreamer.CreateErrorContent(aCode: Integer; const aMessage: String);
301
302Var
303  ErrorObj : TDomElement;
304
305begin
306  ErrorObj:=FXML.CreateElement(UTF8Decode(GetString(rpErrorRoot)));
307  ErrorObj['code']:=UTF8Decode(IntToStr(aCode));
308  ErrorObj['message']:=UTF8Decode(aMessage);
309  FRoot.AppendChild(ErrorObj);
310end;
311
312destructor TXMLOutputStreamer.Destroy;
313begin
314  FreeAndNil(FXML);
315  inherited Destroy;
316end;
317
318procedure TXMLOutputStreamer.InitStreaming;
319begin
320  FXML:=TXMLDocument.Create;
321  FRoot:=FXML.CreateElement('datapacket');
322  FXML.AppendChild(FRoot);
323end;
324
325Initialization
326  TXMLInputStreamer.RegisterStreamer('xml');
327  TXMLOutputStreamer.RegisterStreamer('xml');
328end.
329
330