| 0,0 → 1,492 |
|---|
| unit VtsCurConv; |
| |
| interface |
| |
| uses |
| SysUtils, Classes, Controls; |
| |
| type |
| EVtsCurConvException = class(Exception); |
| |
| TVtsCurApiKey = string; |
| TVtsCur = string; |
| TVtsRate = double; |
| |
| TVtsCurConv = class(TObject) |
| private |
| FSecure: boolean; |
| FMaxAgeSeconds: integer; |
| FConfirmWebAccess: boolean; |
| FFallBackToCache: boolean; |
| FInteractiveAPIKeyInput: boolean; |
| protected |
| function GetJsonRaw(HistoricDate: TDate=0): string; |
| procedure QueryAPIKey(msg: string=''); virtual; |
| public |
| property Secure: boolean read FSecure write FSecure; |
| property MaxAgeSeconds: integer read FMaxAgeSeconds write FMaxAgeSeconds; |
| property ConfirmWebAccess: boolean read FConfirmWebAccess write FConfirmWebAccess; |
| property FallBackToCache: boolean read FFallBackToCache write FFallBackToCache; |
| property InteractiveAPIKeyInput: boolean read FInteractiveAPIKeyInput write FInteractiveAPIKeyInput; |
| class procedure WriteAPIKey(key: TVtsCurApiKey; UserMode: boolean=true); |
| class function ReadAPIKey: TVtsCurApiKey; |
| class function DeleteAPIKey(UserMode: boolean=true): boolean; |
| function Convert(value: Currency; fromCur, toCur: TVtsCur; HistoricDate: TDate=0): Currency; |
| function GetAcceptedCurrencies(sl: TStringList=nil; HistoricDate: TDate=0): integer; |
| end; |
| |
| implementation |
| |
| uses |
| Windows, Registry, uLkJSON, Dialogs, IdHTTP, DateUtils; |
| |
| function FileGetContents(filename: string): string; |
| var |
| sl: TStringList; |
| begin |
| sl := TStringList.Create; |
| try |
| sl.LoadFromFile(filename); |
| result := sl.Text; |
| finally |
| sl.Free; |
| end; |
| end; |
| |
| procedure FilePutContents(filename, content: string); |
| var |
| sl: TStringList; |
| begin |
| sl := TStringList.Create; |
| try |
| sl.Text := content; |
| sl.SaveToFile(filename); |
| finally |
| sl.Free; |
| end; |
| end; |
| |
| function GetPage(aURL: string): string; |
| var |
| Response: TStringStream; |
| HTTP: TIdHTTP; |
| const |
| HTTP_RESPONSE_OK = 200; |
| begin |
| // https://stackoverflow.com/questions/9239267/how-to-download-a-web-page-into-a-variable |
| Result := ''; |
| Response := TStringStream.Create(''); |
| try |
| HTTP := TIdHTTP.Create(nil); |
| try |
| HTTP.Get(aURL, Response); |
| if HTTP.ResponseCode = HTTP_RESPONSE_OK then |
| Result := Response.DataString |
| else |
| raise EVtsCurConvException.CreateFmt('Cannot download from %s', [aURL]); |
| finally |
| HTTP.Free; |
| end; |
| finally |
| Response.Free; |
| end; |
| end; |
| |
| function GetTempDir: string; |
| var |
| Dir: string; |
| Len: DWord; |
| begin |
| SetLength(Dir, MAX_PATH); |
| Len := GetTempPath(MAX_PATH, PChar(Dir)); |
| if Len > 0 then |
| begin |
| SetLength(Dir, Len); |
| Result := Dir; |
| end |
| else |
| RaiseLastOSError; |
| end; |
| |
| { TVtsCurConv } |
| |
| class procedure TVtsCurConv.WriteAPIKey(key: TVtsCurApiKey; UserMode: boolean=true); |
| procedure _WriteAPIKey(root: HKEY); |
| var |
| reg: TRegistry; |
| begin |
| reg := TRegistry.Create; |
| try |
| reg.RootKey := root; |
| if reg.OpenKey('Software\ViaThinkSoft\CurrencyConverter', true) then |
| begin |
| reg.WriteString('APIKey', key); |
| reg.CloseKey; |
| end |
| else raise EVtsCurConvException.Create('Cannot open registry key'); |
| finally |
| reg.Free; |
| end; |
| end; |
| begin |
| if UserMode then |
| _WriteAPIKey(HKEY_CURRENT_USER) |
| else |
| _WriteAPIKey(HKEY_LOCAL_MACHINE); |
| end; |
| |
| class function TVtsCurConv.DeleteAPIKey(UserMode: boolean=true): boolean; |
| procedure _DeleteAPIKey(root: HKEY); |
| var |
| reg: TRegistry; |
| begin |
| reg := TRegistry.Create; |
| try |
| reg.RootKey := root; |
| if reg.OpenKey('Software\ViaThinkSoft\CurrencyConverter', true) then |
| begin |
| result := reg.DeleteValue('APIKey'); |
| reg.CloseKey; |
| end; |
| finally |
| reg.Free; |
| end; |
| end; |
| begin |
| result := false; |
| if UserMode then |
| _DeleteAPIKey(HKEY_CURRENT_USER) |
| else |
| _DeleteAPIKey(HKEY_LOCAL_MACHINE); |
| end; |
| |
| class function TVtsCurConv.ReadAPIKey: TVtsCurApiKey; |
| function _ReadAPIKey(root: HKEY): string; |
| var |
| reg: TRegistry; |
| begin |
| result := ''; |
| reg := TRegistry.Create; |
| try |
| reg.RootKey := root; |
| if reg.OpenKeyReadOnly('Software\ViaThinkSoft\CurrencyConverter') then |
| begin |
| if reg.ValueExists('APIKey') then result := reg.ReadString('APIKey'); |
| reg.CloseKey; |
| end; |
| finally |
| reg.Free; |
| end; |
| end; |
| begin |
| result := _ReadAPIKey(HKEY_CURRENT_USER); |
| if result = '' then result := _ReadAPIKey(HKEY_LOCAL_MACHINE); |
| end; |
| |
| function TVtsCurConv.Convert(value: Currency; fromCur, toCur: TVtsCur; HistoricDate: TDate=0): Currency; |
| var |
| rateTo, rateFrom: TVtsRate; |
| i: Integer; |
| rateToFound: Boolean; |
| rateFromFound: Boolean; |
| sJSON: String; |
| xSource: TlkJSONstring; |
| xRoot: TlkJSONobject; |
| xQuotes: TlkJSONobject; |
| xRate: TlkJSONnumber; |
| begin |
| result := 0; // to avoid that the compiler shows a warning |
| |
| fromCur := Trim(UpperCase(fromCur)); |
| toCur := Trim(UpperCase(toCur)); |
| |
| sJSON := GetJsonRaw(HistoricDate); |
| |
| xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject; |
| try |
| xSource := xRoot.Field['source'] as TlkJSONstring; |
| if not assigned(xSource) then raise EVtsCurConvException.Create('JSON entry "source" is missing!'); |
| |
| xQuotes := xRoot.Field['quotes'] as TlkJSONobject; |
| if not assigned(xQuotes) then raise EVtsCurConvException.Create('JSON entry "quotes" is missing!'); |
| |
| rateToFound := false; |
| rateFromFound := false; |
| rateTo := 0.00; // to avoid that the compiler shows a warning |
| rateFrom := 0.00; // to avoid that the compiler shows a warning |
| |
| for i := 0 to xQuotes.Count - 1 do |
| begin |
| if Length(xQuotes.NameOf[i]) <> 6 then raise EVtsCurConvException.Create('Length of quotes-entry is unexpected!'); |
| |
| xRate := xQuotes.Field[xQuotes.NameOf[i]] as TlkJSONnumber; |
| if not Assigned(xRate) then raise EVtsCurConvException.Create('JSON entry quotes->rate is missing!'); |
| |
| if Copy(xQuotes.NameOf[i], 1, 3) = xSource.Value then |
| begin |
| if Copy(xQuotes.NameOf[i], 4, 3) = toCur then |
| begin |
| rateTo := xRate.Value; |
| rateToFound := true; |
| end; |
| if Copy(xQuotes.NameOf[i], 4, 3) = fromCur then |
| begin |
| rateFrom := xRate.Value; |
| rateFromFound := true; |
| end; |
| end; |
| end; |
| |
| if not rateToFound then raise EVtsCurConvException.CreateFmt('Currency "%s" not supported', [toCur]); |
| if not rateFromFound then raise EVtsCurConvException.CreateFmt('Currency "%s" not supported', [fromCur]); |
| |
| result := value * rateTo / rateFrom; |
| finally |
| xRoot.Free; |
| end; |
| end; |
| |
| procedure TVtsCurConv.QueryAPIKey(msg: string=''); |
| var |
| s: string; |
| begin |
| s := Trim(InputBox('currencylayer.com', Trim(msg + ' Please enter your API key:'), '')); |
| if s = '' then raise EVtsCurConvException.Create('No API key provided.'); |
| WriteAPIKey(s); |
| end; |
| |
| function TVtsCurConv.GetAcceptedCurrencies(sl: TStringList=nil; HistoricDate: TDate=0): integer; |
| var |
| i: Integer; |
| sJSON: String; |
| xSource: TlkJSONstring; |
| xRoot: TlkJSONobject; |
| xQuotes: TlkJSONobject; |
| begin |
| result := 0; |
| |
| sJSON := GetJsonRaw(HistoricDate); |
| |
| xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject; |
| try |
| xSource := xRoot.Field['source'] as TlkJSONstring; |
| if not assigned(xSource) then raise EVtsCurConvException.Create('JSON entry "source" is missing!'); |
| |
| xQuotes := xRoot.Field['quotes'] as TlkJSONobject; |
| if not assigned(xQuotes) then raise EVtsCurConvException.Create('JSON entry "quotes" is missing!'); |
| |
| for i := 0 to xQuotes.Count - 1 do |
| begin |
| if Length(xQuotes.NameOf[i]) <> 6 then raise EVtsCurConvException.Create('Length of quotes-entry is unexpected!'); |
| |
| if Copy(xQuotes.NameOf[i], 1, 3) = xSource.Value then |
| begin |
| Inc(result); |
| if Assigned(sl) then sl.Add(Copy(xQuotes.NameOf[i], 4, 3)); |
| end; |
| end; |
| finally |
| xRoot.Free; |
| end; |
| end; |
| |
| function TVtsCurConv.GetJsonRaw(HistoricDate: TDate=0): string; |
| |
| procedure _HandleKeyInvalidOrMissing(cacheFileName: string; msg: string; out doRetry: boolean; out json: string); |
| begin |
| if FallBackToCache then |
| begin |
| if not InteractiveAPIKeyInput then |
| begin |
| json := FileGetContents(cacheFileName); |
| doRetry := false; |
| end |
| else |
| begin |
| if MessageDlg(Trim(msg + ' Do you want to enter a new one?'), mtError, mbYesNoCancel, 0) = ID_YES then |
| begin |
| QueryAPIKey; |
| doRetry := true; |
| end |
| else |
| begin |
| json := FileGetContents(cacheFileName); |
| doRetry := false; |
| end; |
| end; |
| end |
| else // if not FallBackToCache then |
| begin |
| if not InteractiveAPIKeyInput then |
| begin |
| raise EVtsCurConvException.Create(msg); |
| end |
| else |
| begin |
| QueryAPIKey(msg); |
| doRetry := true; |
| end; |
| end; |
| end; |
| |
| var |
| sJSON, msg, protocol: string; |
| xRoot: TlkJSONobject; |
| xSuccess: TlkJSONboolean; |
| keyInvalid, doRetry: boolean; |
| sDate: string; |
| url: string; |
| cacheDirName, cacheFileName: string; |
| needDownload: boolean; |
| mTime: TDateTime; |
| begin |
| try |
| {$REGION 'Determinate file location and URL'} |
| // cacheDirName := IncludeTrailingPathDelimiter(GetSpecialPath(CSIDL_PROGRAM_FILES_COMMON)) + 'ViaThinkSoft\CurrencyConverter\'; |
| cacheDirName := IncludeTrailingPathDelimiter(GetTempDir) + 'ViaThinkSoft\CurrencyConverter\'; |
| if not ForceDirectories(cacheDirName) then |
| begin |
| raise EVtsCurConvException.CreateFmt('Cannot create directory %s', [cacheDirName]); |
| end; |
| |
| if Secure then protocol := 'https' else protocol := 'http'; |
| if HistoricDate = 0 then |
| begin |
| sDate := ''; |
| url := protocol + '://www.apilayer.net/api/live?access_key=' + ReadAPIKey; |
| cacheFileName := IncludeTrailingPathDelimiter(cacheDirName) + 'live.json'; |
| end |
| else |
| begin |
| DateTimeToString(sDate, 'YYYY-MM-DD', HistoricDate); |
| url := protocol + '://www.apilayer.net/api/historical?date=' + sDate + '&access_key=' + ReadAPIKey; |
| cacheFileName := IncludeTrailingPathDelimiter(cacheDirName) + 'historical-' + sDate + '.json'; |
| end; |
| {$ENDREGION} |
| |
| {$REGION 'Determinate if we need to download or not'} |
| if HistoricDate = 0 then |
| begin |
| needDownload := true; |
| if MaxAgeSeconds < -1 then |
| begin |
| raise EVtsCurConvException.Create('Invalid maxage'); |
| end |
| else if MaxAgeSeconds = -1 then |
| begin |
| // Only download once |
| needDownload := not FileExists(cacheFileName); |
| end |
| else if MaxAgeSeconds = 0 then |
| begin |
| // Always download |
| needDownload := true; |
| end |
| else if MaxAgeSeconds > 0 then |
| begin |
| // Download if older than <MaxAge> seconds |
| FileAge(cacheFileName, mTime); |
| needDownload := not FileExists(cacheFileName) or (SecondsBetween(Now, mTime) > MaxAgeSeconds); |
| end; |
| end |
| else |
| begin |
| needDownload := not FileExists(cacheFileName) |
| end; |
| {$ENDREGION} |
| |
| if not needDownload then |
| begin |
| sJSON := FileGetContents(cacheFileName); |
| end |
| else |
| begin |
| doRetry := false; |
| |
| {$REGION 'Is an API key available?'} |
| if ReadAPIKey = '' then |
| begin |
| _HandleKeyInvalidOrMissing(cacheFileName, 'No API key provided.', doRetry, sJSON); |
| if not doRetry then |
| begin |
| result := sJSON; |
| Exit; |
| end; |
| end; |
| {$ENDREGION} |
| |
| {$REGION 'Download and check if everything is OK'} |
| repeat |
| {$REGION 'Confirm web access?'} |
| if ConfirmWebAccess and (MessageDlg('Download ' + url + ' to ' + cacheFileName + ' ?', mtConfirmation, mbYesNoCancel, 0) <> ID_YES) then |
| begin |
| if FallBackToCache then |
| begin |
| result := FileGetContents(cacheFileName); |
| Exit; |
| end |
| else Abort; |
| end; |
| {$ENDREGION} |
| |
| doRetry := false; |
| |
| sJSON := GetPage(url); |
| |
| xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject; |
| if not assigned(xRoot) then raise EVtsCurConvException.Create('JSON file invalid'); |
| |
| xSuccess := xRoot.Field['success'] as TlkJSONboolean; |
| if not assigned(xSuccess) then raise EVtsCurConvException.Create('Cannot determinate status of the query.'); |
| |
| if xSuccess.Value then |
| begin |
| try |
| FilePutContents(cacheFileName, sJSON); |
| except |
| // Since this is only a cache, we should not break the whole process if only the saving fails |
| end; |
| end |
| else |
| begin |
| {$REGION 'Get information of the error'} |
| try |
| keyInvalid := xRoot.Field['error'].Field['code'].Value = 101; |
| msg := Format('%s (%s, %s)', [ |
| xRoot.Field['error'].Field['info'].Value, |
| xRoot.Field['error'].Field['code'].Value, |
| xRoot.Field['error'].Field['type'].Value]); |
| except |
| keyInvalid := false; |
| msg := 'Unknown error while loading JSON.'; |
| end; |
| {$ENDREGION} |
| |
| if keyInvalid then |
| begin |
| _HandleKeyInvalidOrMissing(cacheFileName, 'API key invalid.', doRetry, sJSON); |
| end |
| else // if not keyInvalid then |
| begin |
| if FallBackToCache then |
| begin |
| result := FileGetContents(cacheFileName); |
| Exit; |
| end |
| else |
| begin |
| raise EVtsCurConvException.Create(msg); |
| end; |
| end; |
| end; |
| until not doRetry; |
| {$ENDREGION} |
| end; |
| |
| result := sJSON; |
| finally |
| FreeAndNil(xRoot); |
| end; |
| end; |
| |
| end. |