Rev 18 | Rev 22 | Go to most recent revision | Only display areas with differences | Regard whitespace | Details | Blame | Last modification | View Log | RSS feed
Rev 18 | Rev 19 | ||
---|---|---|---|
1 | unit VtsCurConv; |
1 | unit VtsCurConv; |
2 | 2 | ||
3 | interface |
3 | interface |
4 | 4 | ||
5 | uses |
5 | uses |
6 | SysUtils, Classes; |
6 | SysUtils, Classes; |
7 | 7 | ||
8 | type |
8 | type |
9 | EVtsCurConvException = class(Exception); |
9 | EVtsCurConvException = class(Exception); |
10 | 10 | ||
11 | TVtsCurApiKey = string; |
11 | TVtsCurApiKey = string; |
12 | TVtsCur = string; |
12 | TVtsCur = string; |
13 | TVtsRate = double; |
13 | TVtsRate = double; |
14 | 14 | ||
15 | TVtsCurConv = class(TObject) |
15 | TVtsCurConv = class(TObject) |
16 | private |
16 | private |
17 | FSecure: boolean; |
17 | FSecure: boolean; |
18 | FMaxAgeSeconds: integer; |
18 | FMaxAgeSeconds: integer; |
19 | FConfirmWebAccess: boolean; |
19 | FConfirmWebAccess: boolean; |
20 | FFallBackToCache: boolean; |
20 | FFallBackToCache: boolean; |
21 | FInteractiveAPIKeyInput: boolean; |
21 | FInteractiveAPIKeyInput: boolean; |
22 | protected |
22 | protected |
23 | function GetJsonRaw(HistoricDate: TDate=0): string; |
23 | function GetJsonRaw(HistoricDate: TDate=0): string; |
24 | procedure QueryAPIKey(msg: string=''); virtual; |
24 | procedure QueryAPIKey(msg: string=''); virtual; |
25 | public |
25 | public |
26 | property Secure: boolean read FSecure write FSecure; |
26 | property Secure: boolean read FSecure write FSecure; |
27 | property MaxAgeSeconds: integer read FMaxAgeSeconds write FMaxAgeSeconds; |
27 | property MaxAgeSeconds: integer read FMaxAgeSeconds write FMaxAgeSeconds; |
28 | property ConfirmWebAccess: boolean read FConfirmWebAccess write FConfirmWebAccess; |
28 | property ConfirmWebAccess: boolean read FConfirmWebAccess write FConfirmWebAccess; |
29 | property FallBackToCache: boolean read FFallBackToCache write FFallBackToCache; |
29 | property FallBackToCache: boolean read FFallBackToCache write FFallBackToCache; |
30 | property InteractiveAPIKeyInput: boolean read FInteractiveAPIKeyInput write FInteractiveAPIKeyInput; |
30 | property InteractiveAPIKeyInput: boolean read FInteractiveAPIKeyInput write FInteractiveAPIKeyInput; |
31 | class procedure WriteAPIKey(key: TVtsCurApiKey; UserMode: boolean=true); |
31 | class procedure WriteAPIKey(key: TVtsCurApiKey; UserMode: boolean=true); |
32 | class function ReadAPIKey: TVtsCurApiKey; |
32 | class function ReadAPIKey: TVtsCurApiKey; |
33 | class function DeleteAPIKey(UserMode: boolean=true): boolean; |
33 | class function DeleteAPIKey(UserMode: boolean=true): boolean; |
34 | function Convert(value: Currency; fromCur, toCur: TVtsCur; HistoricDate: TDate=0): Currency; |
34 | function Convert(value: Currency; fromCur, toCur: TVtsCur; HistoricDate: TDate=0): Currency; |
35 | function GetAcceptedCurrencies(sl: TStringList=nil; HistoricDate: TDate=0): integer; |
35 | function GetAcceptedCurrencies(sl: TStringList=nil; HistoricDate: TDate=0): integer; |
36 | end; |
36 | end; |
37 | 37 | ||
38 | implementation |
38 | implementation |
39 | 39 | ||
40 | uses |
40 | uses |
41 | Windows, Registry, uLkJSON, Dialogs, IdHTTP, DateUtils; |
41 | Windows, Registry, uLkJSON, Dialogs, IdHTTP, DateUtils; |
42 | 42 | ||
43 | function FileGetContents(filename: string): string; |
43 | function FileGetContents(filename: string): string; |
44 | var |
44 | var |
45 | sl: TStringList; |
45 | sl: TStringList; |
46 | begin |
46 | begin |
47 | sl := TStringList.Create; |
47 | sl := TStringList.Create; |
48 | try |
48 | try |
49 | sl.LoadFromFile(filename); |
49 | sl.LoadFromFile(filename); |
50 | result := sl.Text; |
50 | result := sl.Text; |
51 | finally |
51 | finally |
52 | sl.Free; |
52 | sl.Free; |
53 | end; |
53 | end; |
54 | end; |
54 | end; |
55 | 55 | ||
56 | procedure FilePutContents(filename, content: string); |
56 | procedure FilePutContents(filename, content: string); |
57 | var |
57 | var |
58 | sl: TStringList; |
58 | sl: TStringList; |
59 | begin |
59 | begin |
60 | sl := TStringList.Create; |
60 | sl := TStringList.Create; |
61 | try |
61 | try |
62 | sl.Text := content; |
62 | sl.Text := content; |
63 | sl.SaveToFile(filename); |
63 | sl.SaveToFile(filename); |
64 | finally |
64 | finally |
65 | sl.Free; |
65 | sl.Free; |
66 | end; |
66 | end; |
67 | end; |
67 | end; |
68 | 68 | ||
69 | function GetPage(aURL: string): string; |
69 | function GetPage(aURL: string): string; |
70 | var |
70 | var |
71 | Response: TStringStream; |
71 | Response: TStringStream; |
72 | HTTP: TIdHTTP; |
72 | HTTP: TIdHTTP; |
73 | const |
73 | const |
74 | HTTP_RESPONSE_OK = 200; |
74 | HTTP_RESPONSE_OK = 200; |
75 | resourcestring |
75 | resourcestring |
76 | S_CANNOT_DOWNLOAD = 'Cannot download from %s'; |
76 | S_CANNOT_DOWNLOAD = 'Cannot download from %s'; |
77 | begin |
77 | begin |
78 | // https://stackoverflow.com/questions/9239267/how-to-download-a-web-page-into-a-variable |
78 | // https://stackoverflow.com/questions/9239267/how-to-download-a-web-page-into-a-variable |
79 | Result := ''; |
79 | Result := ''; |
80 | Response := TStringStream.Create(''); |
80 | Response := TStringStream.Create(''); |
81 | try |
81 | try |
82 | HTTP := TIdHTTP.Create(nil); |
82 | HTTP := TIdHTTP.Create(nil); |
83 | try |
83 | try |
84 | HTTP.Get(aURL, Response); |
84 | HTTP.Get(aURL, Response); |
85 | if HTTP.ResponseCode = HTTP_RESPONSE_OK then |
85 | if HTTP.ResponseCode = HTTP_RESPONSE_OK then |
86 | Result := Response.DataString |
86 | Result := Response.DataString |
87 | else |
87 | else |
88 | raise EVtsCurConvException.CreateFmt(S_CANNOT_DOWNLOAD, [aURL]); |
88 | raise EVtsCurConvException.CreateFmt(S_CANNOT_DOWNLOAD, [aURL]); |
89 | finally |
89 | finally |
90 | HTTP.Free; |
90 | HTTP.Free; |
91 | end; |
91 | end; |
92 | finally |
92 | finally |
93 | Response.Free; |
93 | Response.Free; |
94 | end; |
94 | end; |
95 | end; |
95 | end; |
96 | 96 | ||
97 | function GetTempDir: string; |
97 | function GetTempDir: string; |
98 | var |
98 | var |
99 | Dir: string; |
99 | Dir: string; |
100 | Len: DWord; |
100 | Len: DWord; |
101 | begin |
101 | begin |
102 | SetLength(Dir, MAX_PATH); |
102 | SetLength(Dir, MAX_PATH); |
103 | Len := GetTempPath(MAX_PATH, PChar(Dir)); |
103 | Len := GetTempPath(MAX_PATH, PChar(Dir)); |
104 | if Len > 0 then |
104 | if Len > 0 then |
105 | begin |
105 | begin |
106 | SetLength(Dir, Len); |
106 | SetLength(Dir, Len); |
107 | Result := Dir; |
107 | Result := Dir; |
108 | end |
108 | end |
109 | else |
109 | else |
110 | RaiseLastOSError; |
110 | RaiseLastOSError; |
111 | end; |
111 | end; |
112 | 112 | ||
113 | { TVtsCurConv } |
113 | { TVtsCurConv } |
114 | 114 | ||
115 | class procedure TVtsCurConv.WriteAPIKey(key: TVtsCurApiKey; UserMode: boolean=true); |
115 | class procedure TVtsCurConv.WriteAPIKey(key: TVtsCurApiKey; UserMode: boolean=true); |
116 | procedure _WriteAPIKey(root: HKEY); |
116 | procedure _WriteAPIKey(root: HKEY); |
117 | var |
117 | var |
118 | reg: TRegistry; |
118 | reg: TRegistry; |
119 | resourcestring |
119 | resourcestring |
120 | S_CANNOT_OPEN_REGISTRY = 'Cannot open registry key'; |
120 | S_CANNOT_OPEN_REGISTRY = 'Cannot open registry key'; |
121 | begin |
121 | begin |
122 | reg := TRegistry.Create; |
122 | reg := TRegistry.Create; |
123 | try |
123 | try |
124 | reg.RootKey := root; |
124 | reg.RootKey := root; |
125 | if reg.OpenKey('Software\ViaThinkSoft\CurrencyConverter', true) then |
125 | if reg.OpenKey('Software\ViaThinkSoft\CurrencyConverter', true) then |
126 | begin |
126 | begin |
127 | reg.WriteString('APIKey', key); |
127 | reg.WriteString('APIKey', key); |
128 | reg.CloseKey; |
128 | reg.CloseKey; |
129 | end |
129 | end |
130 | else raise EVtsCurConvException.Create(S_CANNOT_OPEN_REGISTRY); |
130 | else raise EVtsCurConvException.Create(S_CANNOT_OPEN_REGISTRY); |
131 | finally |
131 | finally |
132 | reg.Free; |
132 | reg.Free; |
133 | end; |
133 | end; |
134 | end; |
134 | end; |
135 | begin |
135 | begin |
136 | if UserMode then |
136 | if UserMode then |
137 | _WriteAPIKey(HKEY_CURRENT_USER) |
137 | _WriteAPIKey(HKEY_CURRENT_USER) |
138 | else |
138 | else |
139 | _WriteAPIKey(HKEY_LOCAL_MACHINE); |
139 | _WriteAPIKey(HKEY_LOCAL_MACHINE); |
140 | end; |
140 | end; |
141 | 141 | ||
142 | class function TVtsCurConv.DeleteAPIKey(UserMode: boolean=true): boolean; |
142 | class function TVtsCurConv.DeleteAPIKey(UserMode: boolean=true): boolean; |
143 | procedure _DeleteAPIKey(root: HKEY); |
143 | procedure _DeleteAPIKey(root: HKEY); |
144 | var |
144 | var |
145 | reg: TRegistry; |
145 | reg: TRegistry; |
146 | begin |
146 | begin |
147 | reg := TRegistry.Create; |
147 | reg := TRegistry.Create; |
148 | try |
148 | try |
149 | reg.RootKey := root; |
149 | reg.RootKey := root; |
150 | if reg.OpenKey('Software\ViaThinkSoft\CurrencyConverter', true) then |
150 | if reg.OpenKey('Software\ViaThinkSoft\CurrencyConverter', true) then |
151 | begin |
151 | begin |
152 | result := reg.DeleteValue('APIKey'); |
152 | result := reg.DeleteValue('APIKey'); |
153 | reg.CloseKey; |
153 | reg.CloseKey; |
154 | end; |
154 | end; |
155 | finally |
155 | finally |
156 | reg.Free; |
156 | reg.Free; |
157 | end; |
157 | end; |
158 | end; |
158 | end; |
159 | begin |
159 | begin |
160 | result := false; |
160 | result := false; |
161 | if UserMode then |
161 | if UserMode then |
162 | _DeleteAPIKey(HKEY_CURRENT_USER) |
162 | _DeleteAPIKey(HKEY_CURRENT_USER) |
163 | else |
163 | else |
164 | _DeleteAPIKey(HKEY_LOCAL_MACHINE); |
164 | _DeleteAPIKey(HKEY_LOCAL_MACHINE); |
165 | end; |
165 | end; |
166 | 166 | ||
167 | class function TVtsCurConv.ReadAPIKey: TVtsCurApiKey; |
167 | class function TVtsCurConv.ReadAPIKey: TVtsCurApiKey; |
168 | function _ReadAPIKey(root: HKEY): string; |
168 | function _ReadAPIKey(root: HKEY): string; |
169 | var |
169 | var |
170 | reg: TRegistry; |
170 | reg: TRegistry; |
171 | begin |
171 | begin |
172 | result := ''; |
172 | result := ''; |
173 | reg := TRegistry.Create; |
173 | reg := TRegistry.Create; |
174 | try |
174 | try |
175 | reg.RootKey := root; |
175 | reg.RootKey := root; |
176 | if reg.OpenKeyReadOnly('Software\ViaThinkSoft\CurrencyConverter') then |
176 | if reg.OpenKeyReadOnly('Software\ViaThinkSoft\CurrencyConverter') then |
177 | begin |
177 | begin |
178 | if reg.ValueExists('APIKey') then result := reg.ReadString('APIKey'); |
178 | if reg.ValueExists('APIKey') then result := reg.ReadString('APIKey'); |
179 | reg.CloseKey; |
179 | reg.CloseKey; |
180 | end; |
180 | end; |
181 | finally |
181 | finally |
182 | reg.Free; |
182 | reg.Free; |
183 | end; |
183 | end; |
184 | end; |
184 | end; |
185 | begin |
185 | begin |
186 | result := _ReadAPIKey(HKEY_CURRENT_USER); |
186 | result := _ReadAPIKey(HKEY_CURRENT_USER); |
187 | if result = '' then result := _ReadAPIKey(HKEY_LOCAL_MACHINE); |
187 | if result = '' then result := _ReadAPIKey(HKEY_LOCAL_MACHINE); |
188 | end; |
188 | end; |
189 | 189 | ||
190 | function TVtsCurConv.Convert(value: Currency; fromCur, toCur: TVtsCur; HistoricDate: TDate=0): Currency; |
190 | function TVtsCurConv.Convert(value: Currency; fromCur, toCur: TVtsCur; HistoricDate: TDate=0): Currency; |
191 | var |
191 | var |
192 | rateTo, rateFrom: TVtsRate; |
192 | rateTo, rateFrom: TVtsRate; |
193 | i: Integer; |
193 | i: Integer; |
194 | rateToFound: Boolean; |
194 | rateToFound: Boolean; |
195 | rateFromFound: Boolean; |
195 | rateFromFound: Boolean; |
196 | sJSON: String; |
196 | sJSON: String; |
197 | xSource: TlkJSONstring; |
197 | xSource: TlkJSONstring; |
198 | xRoot: TlkJSONobject; |
198 | xRoot: TlkJSONobject; |
199 | xQuotes: TlkJSONobject; |
199 | xQuotes: TlkJSONobject; |
200 | xRate: TlkJSONnumber; |
200 | xRate: TlkJSONnumber; |
201 | resourcestring |
201 | resourcestring |
202 | S_JSON_ENTRY_MISSING = 'JSON entry "%s" is missing!'; |
202 | S_JSON_ENTRY_MISSING = 'JSON entry "%s" is missing!'; |
203 | S_WRONG_QUOTE_LEN = 'Length of quotes-entry is unexpected!'; |
203 | S_WRONG_QUOTE_LEN = 'Length of quotes-entry is unexpected!'; |
204 | S_JSON_RATE_MISSING = 'JSON entry quotes->rate is missing!'; |
204 | S_JSON_RATE_MISSING = 'JSON entry quotes->rate is missing!'; |
205 | S_CURRENCY_NOT_SUPPORTED = 'Currency "%s" not supported'; |
205 | S_CURRENCY_NOT_SUPPORTED = 'Currency "%s" not supported'; |
206 | begin |
206 | begin |
207 | result := 0; // to avoid that the compiler shows a warning |
207 | result := 0; // to avoid that the compiler shows a warning |
208 | 208 | ||
209 | fromCur := Trim(UpperCase(fromCur)); |
209 | fromCur := Trim(UpperCase(fromCur)); |
210 | toCur := Trim(UpperCase(toCur)); |
210 | toCur := Trim(UpperCase(toCur)); |
211 | 211 | ||
212 | if fromCur = toCur then |
212 | if fromCur = toCur then |
213 | begin |
213 | begin |
214 | result := value; |
214 | result := value; |
215 | exit; |
215 | exit; |
216 | end; |
216 | end; |
217 | 217 | ||
218 | sJSON := GetJsonRaw(HistoricDate); |
218 | sJSON := GetJsonRaw(HistoricDate); |
219 | 219 | ||
220 | xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject; |
220 | xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject; |
221 | try |
221 | try |
222 | xSource := xRoot.Field['source'] as TlkJSONstring; |
222 | xSource := xRoot.Field['source'] as TlkJSONstring; |
223 | if not assigned(xSource) then raise EVtsCurConvException.CreateFmt(S_JSON_ENTRY_MISSING, ['source']); |
223 | if not assigned(xSource) then raise EVtsCurConvException.CreateFmt(S_JSON_ENTRY_MISSING, ['source']); |
224 | 224 | ||
225 | xQuotes := xRoot.Field['quotes'] as TlkJSONobject; |
225 | xQuotes := xRoot.Field['quotes'] as TlkJSONobject; |
226 | if not assigned(xQuotes) then raise EVtsCurConvException.CreateFmt(S_JSON_ENTRY_MISSING, ['quotes']); |
226 | if not assigned(xQuotes) then raise EVtsCurConvException.CreateFmt(S_JSON_ENTRY_MISSING, ['quotes']); |
227 | 227 | ||
228 | rateToFound := false; |
228 | rateToFound := false; |
229 | rateFromFound := false; |
229 | rateFromFound := false; |
230 | rateTo := 0.00; // to avoid that the compiler shows a warning |
230 | rateTo := 0.00; // to avoid that the compiler shows a warning |
231 | rateFrom := 0.00; // to avoid that the compiler shows a warning |
231 | rateFrom := 0.00; // to avoid that the compiler shows a warning |
232 | 232 | ||
233 | for i := 0 to xQuotes.Count - 1 do |
233 | for i := 0 to xQuotes.Count - 1 do |
234 | begin |
234 | begin |
235 | if Length(xQuotes.NameOf[i]) <> 6 then raise EVtsCurConvException.Create(S_WRONG_QUOTE_LEN); |
235 | if Length(xQuotes.NameOf[i]) <> 6 then raise EVtsCurConvException.Create(S_WRONG_QUOTE_LEN); |
236 | 236 | ||
237 | xRate := xQuotes.Field[xQuotes.NameOf[i]] as TlkJSONnumber; |
237 | xRate := xQuotes.Field[xQuotes.NameOf[i]] as TlkJSONnumber; |
238 | if not Assigned(xRate) then raise EVtsCurConvException.Create(S_JSON_RATE_MISSING); |
238 | if not Assigned(xRate) then raise EVtsCurConvException.Create(S_JSON_RATE_MISSING); |
239 | 239 | ||
240 | if Copy(xQuotes.NameOf[i], 1, 3) = xSource.Value then |
240 | if Copy(xQuotes.NameOf[i], 1, 3) = xSource.Value then |
241 | begin |
241 | begin |
242 | if Copy(xQuotes.NameOf[i], 4, 3) = toCur then |
242 | if Copy(xQuotes.NameOf[i], 4, 3) = toCur then |
243 | begin |
243 | begin |
244 | rateTo := xRate.Value; |
244 | rateTo := xRate.Value; |
245 | rateToFound := true; |
245 | rateToFound := true; |
246 | end; |
246 | end; |
247 | if Copy(xQuotes.NameOf[i], 4, 3) = fromCur then |
247 | if Copy(xQuotes.NameOf[i], 4, 3) = fromCur then |
248 | begin |
248 | begin |
249 | rateFrom := xRate.Value; |
249 | rateFrom := xRate.Value; |
250 | rateFromFound := true; |
250 | rateFromFound := true; |
251 | end; |
251 | end; |
252 | end; |
252 | end; |
253 | end; |
253 | end; |
254 | 254 | ||
255 | if not rateToFound then raise EVtsCurConvException.CreateFmt(S_CURRENCY_NOT_SUPPORTED, [toCur]); |
255 | if not rateToFound then raise EVtsCurConvException.CreateFmt(S_CURRENCY_NOT_SUPPORTED, [toCur]); |
256 | if not rateFromFound then raise EVtsCurConvException.CreateFmt(S_CURRENCY_NOT_SUPPORTED, [fromCur]); |
256 | if not rateFromFound then raise EVtsCurConvException.CreateFmt(S_CURRENCY_NOT_SUPPORTED, [fromCur]); |
257 | 257 | ||
258 | result := value * rateTo / rateFrom; |
258 | result := value * rateTo / rateFrom; |
259 | finally |
259 | finally |
260 | xRoot.Free; |
260 | xRoot.Free; |
261 | end; |
261 | end; |
262 | end; |
262 | end; |
263 | 263 | ||
264 | procedure TVtsCurConv.QueryAPIKey(msg: string=''); |
264 | procedure TVtsCurConv.QueryAPIKey(msg: string=''); |
265 | var |
265 | var |
266 | s: string; |
266 | s: string; |
267 | resourcestring |
267 | resourcestring |
268 | S_CURRENCYLAYER = 'currencylayer.com'; |
268 | S_CURRENCYLAYER = 'currencylayer.com'; |
269 | S_ENTER_KEY = 'Please enter your API key:'; |
269 | S_ENTER_KEY = 'Please enter your API key:'; |
270 | S_NO_API_KEY = 'No API key provided.'; |
270 | S_NO_API_KEY = 'No API key provided.'; |
271 | begin |
271 | begin |
272 | s := Trim(InputBox(S_CURRENCYLAYER, Trim(msg + ' ' + S_ENTER_KEY), '')); |
272 | s := Trim(InputBox(S_CURRENCYLAYER, Trim(msg + ' ' + S_ENTER_KEY), '')); |
273 | if s = '' then raise EVtsCurConvException.Create(S_NO_API_KEY); |
273 | if s = '' then raise EVtsCurConvException.Create(S_NO_API_KEY); |
274 | WriteAPIKey(s); |
274 | WriteAPIKey(s); |
275 | end; |
275 | end; |
276 | 276 | ||
277 | function TVtsCurConv.GetAcceptedCurrencies(sl: TStringList=nil; HistoricDate: TDate=0): integer; |
277 | function TVtsCurConv.GetAcceptedCurrencies(sl: TStringList=nil; HistoricDate: TDate=0): integer; |
278 | var |
278 | var |
279 | i: Integer; |
279 | i: Integer; |
280 | sJSON: String; |
280 | sJSON: String; |
281 | xSource: TlkJSONstring; |
281 | xSource: TlkJSONstring; |
282 | xRoot: TlkJSONobject; |
282 | xRoot: TlkJSONobject; |
283 | xQuotes: TlkJSONobject; |
283 | xQuotes: TlkJSONobject; |
284 | resourcestring |
284 | resourcestring |
285 | S_JSON_ENTRY_MISSING = 'JSON entry "%s" is missing!'; |
285 | S_JSON_ENTRY_MISSING = 'JSON entry "%s" is missing!'; |
286 | S_WRONG_QUOTE_LEN = 'Length of quotes-entry is unexpected!'; |
286 | S_WRONG_QUOTE_LEN = 'Length of quotes-entry is unexpected!'; |
287 | begin |
287 | begin |
288 | result := 0; |
288 | result := 0; |
289 | 289 | ||
290 | sJSON := GetJsonRaw(HistoricDate); |
290 | sJSON := GetJsonRaw(HistoricDate); |
291 | 291 | ||
292 | xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject; |
292 | xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject; |
293 | try |
293 | try |
294 | xSource := xRoot.Field['source'] as TlkJSONstring; |
294 | xSource := xRoot.Field['source'] as TlkJSONstring; |
295 | if not assigned(xSource) then raise EVtsCurConvException.CreateFmt(S_JSON_ENTRY_MISSING, ['source']); |
295 | if not assigned(xSource) then raise EVtsCurConvException.CreateFmt(S_JSON_ENTRY_MISSING, ['source']); |
296 | 296 | ||
297 | xQuotes := xRoot.Field['quotes'] as TlkJSONobject; |
297 | xQuotes := xRoot.Field['quotes'] as TlkJSONobject; |
298 | if not assigned(xQuotes) then raise EVtsCurConvException.CreateFmt(S_JSON_ENTRY_MISSING, ['quotes']); |
298 | if not assigned(xQuotes) then raise EVtsCurConvException.CreateFmt(S_JSON_ENTRY_MISSING, ['quotes']); |
299 | 299 | ||
300 | for i := 0 to xQuotes.Count - 1 do |
300 | for i := 0 to xQuotes.Count - 1 do |
301 | begin |
301 | begin |
302 | if Length(xQuotes.NameOf[i]) <> 6 then raise EVtsCurConvException.Create(S_WRONG_QUOTE_LEN); |
302 | if Length(xQuotes.NameOf[i]) <> 6 then raise EVtsCurConvException.Create(S_WRONG_QUOTE_LEN); |
303 | 303 | ||
304 | if Copy(xQuotes.NameOf[i], 1, 3) = xSource.Value then |
304 | if Copy(xQuotes.NameOf[i], 1, 3) = xSource.Value then |
305 | begin |
305 | begin |
306 | Inc(result); |
306 | Inc(result); |
307 | if Assigned(sl) then sl.Add(Copy(xQuotes.NameOf[i], 4, 3)); |
307 | if Assigned(sl) then sl.Add(Copy(xQuotes.NameOf[i], 4, 3)); |
308 | end; |
308 | end; |
309 | end; |
309 | end; |
310 | finally |
310 | finally |
311 | xRoot.Free; |
311 | xRoot.Free; |
312 | end; |
312 | end; |
313 | end; |
313 | end; |
314 | 314 | ||
315 | function TVtsCurConv.GetJsonRaw(HistoricDate: TDate=0): string; |
315 | function TVtsCurConv.GetJsonRaw(HistoricDate: TDate=0): string; |
316 | 316 | ||
317 | procedure _HandleKeyInvalidOrMissing(cacheFileName: string; msg: string; out doRetry: boolean; out json: string); |
317 | procedure _HandleKeyInvalidOrMissing(cacheFileName: string; msg: string; out doRetry: boolean; out json: string); |
318 | resourcestring |
318 | resourcestring |
319 | S_ENTER_NEW_KEY = 'Do you want to enter a new one?'; |
319 | S_ENTER_NEW_KEY = 'Do you want to enter a new one?'; |
320 | S_NO_CACHE_EXISTING = 'Cannot get the data online, and no cache exists. Please check your internet connection and API key.'; |
320 | S_NO_CACHE_EXISTING = 'Cannot get the data online, and no cache exists. Please check your internet connection and API key.'; |
321 | begin |
321 | begin |
322 | if FallBackToCache then |
322 | if FallBackToCache then |
323 | begin |
323 | begin |
324 | if not InteractiveAPIKeyInput then |
324 | if not InteractiveAPIKeyInput then |
325 | begin |
325 | begin |
326 | if not FileExists(cacheFileName) then |
326 | if not FileExists(cacheFileName) then |
327 | begin |
327 | begin |
328 | raise Exception.Create(S_NO_CACHE_EXISTING); |
328 | raise Exception.Create(S_NO_CACHE_EXISTING); |
329 | end; |
329 | end; |
330 | json := FileGetContents(cacheFileName); |
330 | json := FileGetContents(cacheFileName); |
331 | doRetry := false; |
331 | doRetry := false; |
332 | end |
332 | end |
333 | else |
333 | else |
334 | begin |
334 | begin |
335 | if MessageDlg(Trim(msg + ' ' + S_ENTER_NEW_KEY), mtError, mbYesNoCancel, 0) = ID_YES then |
335 | if MessageDlg(Trim(msg + ' ' + S_ENTER_NEW_KEY), mtError, mbYesNoCancel, 0) = ID_YES then |
336 | begin |
336 | begin |
337 | QueryAPIKey; |
337 | QueryAPIKey; |
338 | doRetry := true; |
338 | doRetry := true; |
339 | end |
339 | end |
340 | else |
340 | else |
341 | begin |
341 | begin |
342 | if not FileExists(cacheFileName) then |
342 | if not FileExists(cacheFileName) then |
343 | begin |
343 | begin |
344 | raise Exception.Create(S_NO_CACHE_EXISTING); |
344 | raise Exception.Create(S_NO_CACHE_EXISTING); |
345 | end; |
345 | end; |
346 | json := FileGetContents(cacheFileName); |
346 | json := FileGetContents(cacheFileName); |
347 | doRetry := false; |
347 | doRetry := false; |
348 | end; |
348 | end; |
349 | end; |
349 | end; |
350 | end |
350 | end |
351 | else // if not FallBackToCache then |
351 | else // if not FallBackToCache then |
352 | begin |
352 | begin |
353 | if not InteractiveAPIKeyInput then |
353 | if not InteractiveAPIKeyInput then |
354 | begin |
354 | begin |
355 | raise EVtsCurConvException.Create(msg); |
355 | raise EVtsCurConvException.Create(msg); |
356 | end |
356 | end |
357 | else |
357 | else |
358 | begin |
358 | begin |
359 | QueryAPIKey(msg); |
359 | QueryAPIKey(msg); |
360 | doRetry := true; |
360 | doRetry := true; |
361 | end; |
361 | end; |
362 | end; |
362 | end; |
363 | end; |
363 | end; |
364 | 364 | ||
365 | function protocol: string; |
365 | function protocol: string; |
366 | begin |
366 | begin |
367 | if Secure then result := 'https' else result := 'http'; |
367 | if Secure then result := 'https' else result := 'http'; |
368 | end; |
368 | end; |
369 | 369 | ||
370 | function url: string; |
370 | function url: string; |
371 | var |
371 | var |
372 | sDate: string; |
372 | sDate: string; |
373 | begin |
373 | begin |
374 | if HistoricDate = 0 then |
374 | if HistoricDate = 0 then |
375 | begin |
375 | begin |
376 | sDate := ''; |
376 | sDate := ''; |
377 | result := protocol + '://www.apilayer.net/api/live?access_key=' + ReadAPIKey; |
377 | result := protocol + '://www.apilayer.net/api/live?access_key=' + ReadAPIKey; |
378 | end |
378 | end |
379 | else |
379 | else |
380 | begin |
380 | begin |
381 | DateTimeToString(sDate, 'YYYY-MM-DD', HistoricDate); |
381 | DateTimeToString(sDate, 'YYYY-MM-DD', HistoricDate); |
382 | result := protocol + '://www.apilayer.net/api/historical?date=' + sDate + '&access_key=' + ReadAPIKey; |
382 | result := protocol + '://www.apilayer.net/api/historical?date=' + sDate + '&access_key=' + ReadAPIKey; |
383 | end; |
383 | end; |
384 | end; |
384 | end; |
385 | 385 | ||
386 | function cacheFileName: string; |
386 | function cacheFileName: string; |
387 | resourcestring |
387 | resourcestring |
388 | S_CANNOT_CREATE_DIR = 'Cannot create directory %s'; |
388 | S_CANNOT_CREATE_DIR = 'Cannot create directory %s'; |
389 | var |
389 | var |
390 | sDate: string; |
390 | sDate: string; |
391 | cacheDirName: string; |
391 | cacheDirName: string; |
392 | begin |
392 | begin |
393 | // cacheDirName := IncludeTrailingPathDelimiter(GetSpecialPath(CSIDL_PROGRAM_FILES_COMMON)) + 'ViaThinkSoft\CurrencyConverter\'; |
393 | // cacheDirName := IncludeTrailingPathDelimiter(GetSpecialPath(CSIDL_PROGRAM_FILES_COMMON)) + 'ViaThinkSoft\CurrencyConverter\'; |
394 | cacheDirName := IncludeTrailingPathDelimiter(GetTempDir) + 'ViaThinkSoft\CurrencyConverter\'; |
394 | cacheDirName := IncludeTrailingPathDelimiter(GetTempDir) + 'ViaThinkSoft\CurrencyConverter\'; |
395 | if not ForceDirectories(cacheDirName) then |
395 | if not ForceDirectories(cacheDirName) then |
396 | begin |
396 | begin |
397 | raise EVtsCurConvException.CreateFmt(S_CANNOT_CREATE_DIR, [cacheDirName]); |
397 | raise EVtsCurConvException.CreateFmt(S_CANNOT_CREATE_DIR, [cacheDirName]); |
398 | end; |
398 | end; |
399 | 399 | ||
400 | if HistoricDate = 0 then |
400 | if HistoricDate = 0 then |
401 | begin |
401 | begin |
402 | sDate := ''; |
402 | sDate := ''; |
403 | result := IncludeTrailingPathDelimiter(cacheDirName) + 'live.json'; |
403 | result := IncludeTrailingPathDelimiter(cacheDirName) + 'live.json'; |
404 | end |
404 | end |
405 | else |
405 | else |
406 | begin |
406 | begin |
407 | DateTimeToString(sDate, 'YYYY-MM-DD', HistoricDate); |
407 | DateTimeToString(sDate, 'YYYY-MM-DD', HistoricDate); |
408 | result := IncludeTrailingPathDelimiter(cacheDirName) + 'historical-' + sDate + '.json'; |
408 | result := IncludeTrailingPathDelimiter(cacheDirName) + 'historical-' + sDate + '.json'; |
409 | end; |
409 | end; |
410 | end; |
410 | end; |
411 | 411 | ||
412 | var |
412 | var |
413 | sJSON, msg: string; |
413 | sJSON, msg: string; |
414 | xRoot: TlkJSONobject; |
414 | xRoot: TlkJSONobject; |
415 | xSuccess: TlkJSONboolean; |
415 | xSuccess: TlkJSONboolean; |
416 | keyInvalid, doRetry: boolean; |
416 | keyInvalid, doRetry: boolean; |
417 | needDownload: boolean; |
417 | needDownload: boolean; |
418 | mTime: TDateTime; |
418 | mTime: TDateTime; |
419 | resourcestring |
419 | resourcestring |
420 | S_INVALID_MAXAGE = 'Invalid maxage'; |
420 | S_INVALID_MAXAGE = 'Invalid maxage'; |
421 | S_NO_API_KEY_PROVIDED = 'No API key provided.'; |
421 | S_NO_API_KEY_PROVIDED = 'No API key provided.'; |
422 | S_DOWNLOAD_QUERY = 'Download %s to %s ?'; |
422 | S_DOWNLOAD_QUERY = 'Download %s to %s ?'; |
423 | S_JSON_FILE_INVALID = 'JSON file invalid'; |
423 | S_JSON_FILE_INVALID = 'JSON file invalid'; |
424 | S_UNKNOWN_SUCCESS = 'Cannot determinate status of the query.'; |
424 | S_UNKNOWN_SUCCESS = 'Cannot determinate status of the query.'; |
425 | S_JSON_UNKNOWN_ERROR = 'Unknown error while loading JSON.'; |
425 | S_JSON_UNKNOWN_ERROR = 'Unknown error while loading JSON.'; |
426 | S_API_KEY_INVALID = 'API key invalid.'; |
426 | S_API_KEY_INVALID = 'API key invalid.'; |
427 | begin |
427 | begin |
428 | try |
- | |
429 | {$REGION 'Determinate if we need to download or not'} |
428 | {$REGION 'Determinate if we need to download or not'} |
430 | if HistoricDate = 0 then |
429 | if HistoricDate = 0 then |
431 | begin |
430 | begin |
432 | needDownload := true; |
431 | needDownload := true; |
433 | if MaxAgeSeconds < -1 then |
432 | if MaxAgeSeconds < -1 then |
434 | begin |
433 | begin |
435 | raise EVtsCurConvException.Create(S_INVALID_MAXAGE); |
434 | raise EVtsCurConvException.Create(S_INVALID_MAXAGE); |
436 | end |
435 | end |
437 | else if MaxAgeSeconds = -1 then |
436 | else if MaxAgeSeconds = -1 then |
438 | begin |
437 | begin |
439 | // Only download once |
438 | // Only download once |
440 | needDownload := not FileExists(cacheFileName); |
439 | needDownload := not FileExists(cacheFileName); |
441 | end |
440 | end |
442 | else if MaxAgeSeconds = 0 then |
441 | else if MaxAgeSeconds = 0 then |
443 | begin |
442 | begin |
444 | // Always download |
443 | // Always download |
445 | needDownload := true; |
444 | needDownload := true; |
446 | end |
445 | end |
447 | else if MaxAgeSeconds > 0 then |
446 | else if MaxAgeSeconds > 0 then |
448 | begin |
447 | begin |
449 | // Download if older than <MaxAge> seconds |
448 | // Download if older than <MaxAge> seconds |
450 | FileAge(cacheFileName, mTime); |
449 | FileAge(cacheFileName, mTime); |
451 | needDownload := not FileExists(cacheFileName) or (SecondsBetween(Now, mTime) > MaxAgeSeconds); |
450 | needDownload := not FileExists(cacheFileName) or (SecondsBetween(Now, mTime) > MaxAgeSeconds); |
452 | end; |
451 | end; |
453 | end |
452 | end |
454 | else |
453 | else |
455 | begin |
454 | begin |
456 | needDownload := not FileExists(cacheFileName) |
455 | needDownload := not FileExists(cacheFileName) |
457 | end; |
456 | end; |
458 | {$ENDREGION} |
457 | {$ENDREGION} |
459 | 458 | ||
460 | if not needDownload and FileExists(cacheFileName) then |
459 | if not needDownload and FileExists(cacheFileName) then |
461 | begin |
460 | begin |
462 | sJSON := FileGetContents(cacheFileName); |
461 | sJSON := FileGetContents(cacheFileName); |
463 | end |
462 | end |
464 | else |
463 | else |
465 | begin |
464 | begin |
466 | doRetry := false; |
465 | doRetry := false; |
467 | 466 | ||
468 | {$REGION 'Is an API key available?'} |
467 | {$REGION 'Is an API key available?'} |
469 | if ReadAPIKey = '' then |
468 | if ReadAPIKey = '' then |
470 | begin |
469 | begin |
471 | _HandleKeyInvalidOrMissing(cacheFileName, S_NO_API_KEY_PROVIDED, doRetry, sJSON); |
470 | _HandleKeyInvalidOrMissing(cacheFileName, S_NO_API_KEY_PROVIDED, doRetry, sJSON); |
472 | if not doRetry then |
471 | if not doRetry then |
473 | begin |
472 | begin |
474 | result := sJSON; |
473 | result := sJSON; |
475 | Exit; |
474 | Exit; |
476 | end; |
475 | end; |
477 | end; |
476 | end; |
478 | {$ENDREGION} |
477 | {$ENDREGION} |
479 | 478 | ||
480 | {$REGION 'Download and check if everything is OK'} |
479 | {$REGION 'Download and check if everything is OK'} |
481 | repeat |
480 | repeat |
482 | {$REGION 'Confirm web access?'} |
481 | {$REGION 'Confirm web access?'} |
483 | if ConfirmWebAccess and (MessageDlg(Format(S_DOWNLOAD_QUERY, [url, cacheFileName]), mtConfirmation, mbYesNoCancel, 0) <> ID_YES) then |
482 | if ConfirmWebAccess and (MessageDlg(Format(S_DOWNLOAD_QUERY, [url, cacheFileName]), mtConfirmation, mbYesNoCancel, 0) <> ID_YES) then |
484 | begin |
483 | begin |
485 | if FallBackToCache and FileExists(cacheFileName) then |
484 | if FallBackToCache and FileExists(cacheFileName) then |
486 | begin |
485 | begin |
487 | result := FileGetContents(cacheFileName); |
486 | result := FileGetContents(cacheFileName); |
488 | Exit; |
487 | Exit; |
489 | end |
488 | end |
490 | else Abort; |
489 | else Abort; |
491 | end; |
490 | end; |
492 | {$ENDREGION} |
491 | {$ENDREGION} |
493 | 492 | ||
494 | doRetry := false; |
493 | doRetry := false; |
495 | 494 | ||
496 | sJSON := GetPage(url); |
495 | sJSON := GetPage(url); |
497 | 496 | ||
498 | xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject; |
497 | xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject; |
499 | if not assigned(xRoot) then raise EVtsCurConvException.Create(S_JSON_FILE_INVALID); |
498 | if not assigned(xRoot) then raise EVtsCurConvException.Create(S_JSON_FILE_INVALID); |
500 | 499 | try |
|
501 | xSuccess := xRoot.Field['success'] as TlkJSONboolean; |
500 | xSuccess := xRoot.Field['success'] as TlkJSONboolean; |
502 | if not assigned(xSuccess) then raise EVtsCurConvException.Create(S_UNKNOWN_SUCCESS); |
501 | if not assigned(xSuccess) then raise EVtsCurConvException.Create(S_UNKNOWN_SUCCESS); |
503 | 502 | ||
504 | if xSuccess.Value then |
503 | if xSuccess.Value then |
505 | begin |
504 | begin |
506 | try |
505 | try |
507 | FilePutContents(cacheFileName, sJSON); |
506 | FilePutContents(cacheFileName, sJSON); |
508 | except |
507 | except |
509 | // Since this is only a cache, we should not break the whole process if only the saving fails |
508 | // Since this is only a cache, we should not break the whole process if only the saving fails |
510 | end; |
509 | end; |
511 | end |
510 | end |
512 | else |
511 | else |
513 | begin |
512 | begin |
514 | {$REGION 'Get information of the error'} |
513 | {$REGION 'Get information of the error'} |
515 | try |
514 | try |
516 | keyInvalid := xRoot.Field['error'].Field['code'].Value = 101; |
515 | keyInvalid := xRoot.Field['error'].Field['code'].Value = 101; |
517 | msg := Format('%s (%s, %s)', [ |
516 | msg := Format('%s (%s, %s)', [ |
518 | xRoot.Field['error'].Field['info'].Value, |
517 | xRoot.Field['error'].Field['info'].Value, |
519 | xRoot.Field['error'].Field['code'].Value, |
518 | xRoot.Field['error'].Field['code'].Value, |
520 | xRoot.Field['error'].Field['type'].Value]); |
519 | xRoot.Field['error'].Field['type'].Value]); |
521 | except |
520 | except |
522 | keyInvalid := false; |
521 | keyInvalid := false; |
523 | msg := S_JSON_UNKNOWN_ERROR; |
522 | msg := S_JSON_UNKNOWN_ERROR; |
524 | end; |
523 | end; |
525 | {$ENDREGION} |
524 | {$ENDREGION} |
526 | 525 | ||
527 | if keyInvalid then |
526 | if keyInvalid then |
528 | begin |
527 | begin |
529 | _HandleKeyInvalidOrMissing(cacheFileName, S_API_KEY_INVALID, doRetry, sJSON); |
528 | _HandleKeyInvalidOrMissing(cacheFileName, S_API_KEY_INVALID, doRetry, sJSON); |
530 | end |
529 | end |
531 | else // if not keyInvalid then |
530 | else // if not keyInvalid then |
532 | begin |
531 | begin |
533 | if FallBackToCache and FileExists(cacheFileName) then |
532 | if FallBackToCache and FileExists(cacheFileName) then |
534 | begin |
533 | begin |
535 | result := FileGetContents(cacheFileName); |
534 | result := FileGetContents(cacheFileName); |
536 | Exit; |
535 | Exit; |
537 | end |
536 | end |
538 | else |
537 | else |
539 | begin |
538 | begin |
540 | raise EVtsCurConvException.Create(msg); |
539 | raise EVtsCurConvException.Create(msg); |
541 | end; |
540 | end; |
542 | end; |
541 | end; |
543 | end; |
542 | end; |
- | 543 | finally |
|
- | 544 | FreeAndNil(xRoot); |
|
- | 545 | end; |
|
544 | until not doRetry; |
546 | until not doRetry; |
545 | {$ENDREGION} |
547 | {$ENDREGION} |
546 | end; |
548 | end; |
547 | 549 | ||
548 | result := sJSON; |
550 | result := sJSON; |
549 | finally |
- | |
550 | FreeAndNil(xRoot); |
- | |
551 | end; |
- | |
552 | end; |
551 | end; |
553 | 552 | ||
554 | end. |
553 | end. |
555 | 554 |