unit OAuth;
interface
uses
Classes, SysUtils, IdURI, Windows;
type
EOAuthException = class(Exception);
TOAuthConsumer = class;
TOAuthToken = class;
TOAuthRequest = class;
TOAuthSignatureMethod = class;
TOAuthSignatureMethod_HMAC_SHA1 = class;
TOAuthSignatureMethod_PLAINTEXT = class;
TOAuthConsumer = class
private
FKey: string;
FSecret: string;
FCallback_URL: string;
procedure SetKey(const Value: string);
procedure SetSecret(const Value: string);
procedure SetCallback_URL(const Value: string);
public
constructor Create(Key, Secret: string); overload;
constructor Create(Key, Secret: string; Callback_URL: string); overload;
property Key: string read FKey write SetKey;
property Secret: string read FSecret write SetSecret;
property Callback_URL: string read Fcallback_URL write SetCallback_URL;
end;
TOAuthToken = class
private
FKey: string;
FSecret: string;
procedure SetKey(const Value: string);
procedure SetSecret(const Value: string);
public
constructor Create(Key, Secret: string);
function AsString: string; virtual;
property Key: string read FKey write SetKey;
property Secret: string read FSecret write SetSecret;
end;
TOAuthRequest = class
private
FParameters: TStringList;
FHTTPURL: string;
FScheme: string;
FHost: string;
FPath: string;
FFields: string;
FVersion: string;
FBaseString: string;
FGetString: string;
procedure SetHTTPURL(const Value: string);
procedure SetBaseString(const Value: string);
procedure SetVersion(const Value: string);
function GenerateNonce: string;
function GenerateTimeStamp: string;
function GetSignableParameters: string;
public
constructor Create(HTTPURL: string);
function FromConsumerAndToken(Consumer: TOAuthConsumer; Token: TOAuthToken;
HTTPURL: string): TOAuthRequest;
procedure Sign_Request(Signature_Method: TOAuthSignatureMethod; Consumer: TOAuthConsumer;
Token: TOAuthToken);
function Build_Signature(Signature_Method: TOAuthSignatureMethod; Consumer: TOAuthConsumer;
Token: TOAuthToken): string;
property BaseString: string read FBaseString write SetBaseString;
property Version: string read FVersion write SetVersion;
property Parameters: TStringList read FParameters;
property HTTPURL: string read FHTTPURL write SetHTTPURL;
property Scheme: string read FScheme;
property Host: string read FHost;
property Path: string read FPath;
property Fields: string read FFields;
property GetString: string read FGetString;
end;
TOAuthSignatureMethod = class
public
function check_signature(Request: TOAuthRequest; Consumer: TOAuthConsumer;
Token: TOAuthToken; Signature: string): boolean;
function get_name(): string; virtual; abstract;
function build_signature(Request: TOAuthRequest; Consumer: TOAuthConsumer;
Token: TOAuthToken): string; virtual; abstract;
end;
TOAuthSignatureMethod_HMAC_SHA1 = class(TOAuthSignatureMethod)
public
function get_name(): string; override;
function build_signature(Request: TOAuthRequest; Consumer: TOAuthConsumer;
Token: TOAuthToken): string; override;
end;
TOAuthSignatureMethod_PLAINTEXT = class(TOAuthSignatureMethod)
public
function get_name(): string; override;
function build_signature(Request: TOAuthRequest; Consumer: TOAuthConsumer;
Token: TOAuthToken): string; override;
end;
TOAuthUtil = class
public
class function urlEncodeRFC3986(URL: string):string;
class function urlDecodeRFC3986(URL: string):string;
end;
const
UnixStartDate : TDateTime = ;
implementation
uses
IdGlobal, IdHash, IdHashMessageDigest, IdHMACSHA1, IdCoderMIME;
function DateTimeToUnix(ConvDate: TDateTime): Longint;
var
x: double;
lTimeZone: TTimeZoneInformation;
begin
GetTimeZoneInformation(lTimeZone);
ConvDate := ConvDate + (lTimeZone.Bias / );
x := (ConvDate - UnixStartDate) * ;
Result := Trunc(x);
end;
function _IntToHex(Value: Integer; Digits: Integer): String;
begin
Result := SysUtils.IntToHex(Value, Digits);
end;
function XDigit(Ch : Char) : Integer;
begin
if (Ch >= '') and (Ch <= '') then
Result := Ord(Ch) - Ord('')
else
Result := (Ord(Ch) and ) + ;
end;
function IsXDigit(Ch : Char) : Boolean;
begin
Result := ((Ch >= '') and (Ch <= '')) or
((Ch >= 'a') and (Ch <= 'f')) or
((Ch >= 'A') and (Ch <= 'F'));
end;
function htoin(Value : PChar; Len : Integer) : Integer;
var
I : Integer;
begin
Result := ;
I := ;
while (I < Len) and (Value[I] = ' ') do
I := I + ;
while (I < len) and (IsXDigit(Value[I])) do begin
Result := Result * + XDigit(Value[I]);
I := I + ;
end;
end;
function htoi2(Value : PChar) : Integer;
begin
Result := htoin(Value, );
end;
function UrlEncode(const S : String) : String;
var
I : Integer;
Ch : Char;
begin
Result := '';
for I := to Length(S) do begin
Ch := S[I];
if ((Ch >= '') and (Ch <= '')) or
((Ch >= 'a') and (Ch <= 'z')) or
((Ch >= 'A') and (Ch <= 'Z')) or
(Ch = '.') or (Ch = '-') or (Ch = '_') or (Ch = '~')then
Result := Result + Ch
else
Result := Result + '%' + _IntToHex(Ord(Ch), );
end;
end;
function UrlDecode(const Url : String) : String;
var
I, J, K, L : Integer;
begin
Result := Url;
L := Length(Result);
I := ;
K := ;
while TRUE do begin
J := I;
while (J <= Length(Result)) and (Result[J] <> '%') do begin
if J <> K then
Result[K] := Result[J];
Inc(J);
Inc(K);
end;
if J > Length(Result) then
break; { End of string }
if J > (Length(Result) - ) then begin
while J <= Length(Result) do begin
Result[K] := Result[J];
Inc(J);
Inc(K);
end;
break;
end;
Result[K] := Char(htoi2(@Result[J + ]));
Inc(K);
I := J + ;
Dec(L, );
end;
SetLength(Result, L);
end;
{ TOAuthConsumer }
constructor TOAuthConsumer.Create(Key, Secret: string);
begin
FKey := Key;
FSecret := Secret;
FCallBack_URL := '';
end;
constructor TOAuthConsumer.Create(Key, Secret, Callback_URL: string);
begin
FKey := Key;
FSecret := Secret;
FCallBack_URL := Callback_URL;
end;
procedure TOAuthConsumer.SetCallback_URL(const Value: string);
begin
FCallback_URL := Value;
end;
procedure TOAuthConsumer.SetKey(const Value: string);
begin
FKey := Value;
end;
procedure TOAuthConsumer.SetSecret(const Value: string);
begin
FSecret := Value;
end;
{ TOAuthToken }
function TOAuthToken.AsString: string;
begin
result := 'oauth_token=' + Self.Key + '&oauth_token_secret=' + Self.Secret;
end;
constructor TOAuthToken.Create(Key, Secret: string);
begin
FKey := Key;
FSecret := Secret;
end;
procedure TOAuthToken.SetKey(const Value: string);
begin
FKey := Value;
end;
procedure TOAuthToken.SetSecret(const Value: string);
begin
FSecret := Value;
end;
{ TOAuthRequest }
function TOAuthRequest.Build_Signature(Signature_Method: TOAuthSignatureMethod;
Consumer: TOAuthConsumer; Token: TOAuthToken): string;
begin
Result := Signature_Method.build_signature(Self, Consumer, Token);
end;
constructor TOAuthRequest.Create(HTTPURL: string);
var
x,y: integer;
begin
FHTTPURL := HTTPURL;
FScheme := Copy(FHTTPURL, , );
x := AnsiPos('.com', FHTTPURL);
y := AnsiPos('?', FHTTPURL);
FHost := Copy(FHTTPURL, , x-);
FPath := Copy(FHTTPURL, x + , Length(HTTPURL) - y - );
if y > then
FFields := Copy(FHTTPURL, y + , Length(HTTPURL));
FVersion := '1.0';
FParameters := TStringList.Create;
end;
function TOAuthRequest.FromConsumerAndToken(Consumer: TOAuthConsumer;
Token: TOAuthToken; HTTPURL: string): TOAuthRequest;
begin
Self.FParameters.Clear;
Self.FParameters.Add('oauth_consumer_key=' + Consumer.Key);
Self.FParameters.Add('oauth_nonce=' + Self.GenerateNonce);
Self.FParameters.Add('oauth_timestamp=' + Self.GenerateTimeStamp);
if Token <> nil then
FParameters.Add('oauth_token=' + Token.Key);
Self.FParameters.Add('oauth_version=' + Self.Version);
Result := Self;
end;
function TOAuthRequest.GenerateNonce: string;
var
md5: TIdHashMessageDigest;
begin
md5 := TIdHashMessageDigest5.Create;
Result := md5.HashStringAsHex(GenerateTimeStamp);
md5.Free;
end;
function TOAuthRequest.GenerateTimeStamp: string;
begin
Result := IntToStr(DateTimeToUnix(Now));
end;
function TOAuthRequest.GetSignableParameters: string;
var
x: integer;
parm: string;
begin
parm := '';
x := FParameters.IndexOfName('oauth_signature');
if x <> - then
FParameters.Delete(x);
for x := to FParameters.Count - do
begin
if x = then
begin
FParameters.ValueFromIndex[x] := TOAuthUtil.urlEncodeRFC3986(FParameters.ValueFromIndex[x]);
parm := FParameters.Names[x] + TOAuthUtil.urlEncodeRFC3986('=') + TIdURI.PathEncode(FParameters.ValueFromIndex[x]);
end
else
parm := parm + TOAuthUtil.urlEncodeRFC3986('&') +
FParameters.Names[x] + TOAuthUtil.urlEncodeRFC3986('=' + FParameters.ValueFromIndex[x])
end;
Result := parm;
end;
procedure TOAuthRequest.SetBaseString(const Value: string);
begin
FBaseString := Value;
end;
procedure TOAuthRequest.SetHTTPURL(const Value: string);
var
x,y: integer;
begin
FHTTPURL := Value;
FScheme := Copy(FHTTPURL, , );
x := AnsiPos('.com', FHTTPURL);
y := AnsiPos('?', FHTTPURL);
FHost := Copy(FHTTPURL, , x-);
if y > then
FPath := Copy(FHTTPURL, x + , y - (x + ))
else
FPath := Copy(FHTTPURL, x + , Length(HTTPURL) - y - );
if y > then
FFields := Copy(FHTTPURL, y + , Length(HTTPURL));
end;
procedure TOAuthRequest.SetVersion(const Value: string);
begin
FVersion := Value;
end;
procedure TOAuthRequest.Sign_Request(Signature_Method: TOAuthSignatureMethod;
Consumer: TOAuthConsumer; Token: TOAuthToken);
var
signature: string;
x: integer;
begin
FParameters.Insert( ,'oauth_signature_method=' + Signature_Method.get_name);
//FParameters.Sort;
signature := Self.Build_Signature(Signature_Method, Consumer, Token);
signature := TOAuthUtil.urlEncodeRFC3986(signature);
FParameters.Insert(, 'oauth_signature=' + signature);
for x := to FParameters.Count - do
begin
if x = then
FGetString := FParameters.Names[X] + '=' + FParameters.ValueFromIndex[x]
else
FGetString := FGetString + '&' + FParameters.Names[X] + '=' + FParameters.ValueFromIndex[x];
end;
end;
{ TOAuthUtil }
class function TOAuthUtil.urlDecodeRFC3986(URL: string): string;
begin
result := TIdURI.URLDecode(URL);
end;
class function TOAuthUtil.urlEncodeRFC3986(URL: string): string;
var
URL1: string;
begin
URL1 := URLEncode(URL);
URL1 := StringReplace(URL1, '+', ' ', [rfReplaceAll, rfIgnoreCase]);
result := URL1;
end;
{ TOAuthSignatureMethod }
function TOAuthSignatureMethod.check_signature(Request:TOAuthRequest;
Consumer: TOAuthConsumer; Token: TOAuthToken; Signature: string): boolean;
var
newsig: string;
begin
newsig:= Self.build_signature(Request, Consumer, Token);
if (newsig = Signature) then
Result := True
else
Result := False;
end;
{ TOAuthSignatureMethod_HMAC_SHA1 }
function TOAuthSignatureMethod_HMAC_SHA1.build_signature(Request: TOAuthRequest;
Consumer: TOAuthConsumer; Token: TOAuthToken): string;
function Base64Encode(const Input: TIdBytes): string;
begin
Result := TIdEncoderMIME.EncodeBytes(Input);
end;
function EncryptHMACSha1(Input, AKey: string): TIdBytes;
begin
with TIdHMACSHA1.Create do
try
Key := ToBytes(AKey);
Result := HashValue(ToBytes(Input));
finally
Free;
end;
end;
var
parm1, parm: string;
consec, toksec: string;
begin
parm1 := Request.GetSignableParameters;
parm := TOAuthUtil.urlEncodeRFC3986(Request.Scheme) +
TOAuthUtil.urlEncodeRFC3986(Request.Host) +
TOAuthUtil.urlEncodeRFC3986(Request.Path);
if Request.Fields <> '' then
begin
parm := parm + '&' + TOAuthUtil.urlEncodeRFC3986(Request.Fields);
parm := parm + TOAuthUtil.urlEncodeRFC3986('&') + parm1;
end
else
parm := parm + '&' + parm1;
Request.BaseString := 'GET&' + parm;
if Token <> nil then
begin
consec := TOAuthUtil.urlEncodeRFC3986(Consumer.Secret);
toksec := TOAuthUtil.urlEncodeRFC3986(Token.Secret);
consec := consec + '&' + toksec;
Result := Base64Encode(EncryptHMACSha1(Request.BaseString, consec))
end
else
begin
consec := TOAuthUtil.urlEncodeRFC3986(Consumer.Secret);
consec := consec + '&';
Result := Base64Encode(EncryptHMACSha1(Request.BaseString, consec));
end;
end;
function TOAuthSignatureMethod_HMAC_SHA1.get_name: string;
begin
result := 'HMAC-SHA1';
end;
{ TOAuthSignatureMethod_PLAINTEXT }
function TOAuthSignatureMethod_PLAINTEXT.build_signature(Request: TOAuthRequest;
Consumer: TOAuthConsumer; Token: TOAuthToken): string;
begin
if Token <> nil then
Result := TOAuthUtil.urlEncodeRFC3986((Consumer.Secret + '&' + Token.Secret))
else
Result := TOAuthUtil.urlEncodeRFC3986((Consumer.Secret));
end;
function TOAuthSignatureMethod_PLAINTEXT.get_name: string;
begin
Result := 'PLAINTEXT';
end;
end.

delphi 使用oauth的控件的更多相关文章

  1. JS调用Delphi编写的OCX控件

    原文:http://www.mamicode.com/info-detail-471283.html 一.使用Delphi XE2编写OCX控件 生成OCX工程: 1.File-New-Other,在 ...

  2. Delphi中使用TXMLDocument控件应注意的问题 转

    Delphi中使用TXMLDocument控件应注意的问题 delphiconstructorxmlclass今天写了一个类,其中用到了TXMLDocument控件.这个控件我是要动态生成的. 但是却 ...

  3. Delphi中的DBGrid控件

    在Delphi中,DBGrid控件是一个开发数据库软件不能不使用的控件,其功能非常强大,可以配合SQL语句实现几乎所有数据报表的显示,操作也非常简单,属性.过程.事件等都非常直观,但是使用中,有时侯还 ...

  4. Delphi中,indy控件实现收发邮件的几点学习记录( 可以考虑加入多线程,用多个邮箱做一个邮箱群发器) 转

    关于用Delphi中的Indy控件实现收发邮件的几点学习记录             这几天心里颇不宁静,不是因为项目延期,而是因为自己几个月前做的邮件发送程序至今无任何进展,虽然一向谦虚的人在网上发 ...

  5. 获取Delphi焦点所在的控件及通过控件名称访问控件

    方法一: Var I: Integer; Begin For I := To ComponentCount - Do //获取组件数量 Begin If Components[I] Is TWinCo ...

  6. delphi安装 Tclientsocket, Tserversocket控件

    菜单component->Install Packets按Add按钮,选择delphi目录里的bin目录下的dclsockets70.bpl(delphi2010是 dclsockets140. ...

  7. Delphi 7学习开发控件

    我们知道使用Delphi快速开发,很大的一方面就是其强大的VCL控件,另外丰富的第三方控件也使得Delphi程序员更加快速的开发出所需要的程序.在此不特别介绍一些概念,只记录自己学习开发控件的步骤.假 ...

  8. Delphi对象变成Windows控件的前世今生(关键是设置句柄和回调函数)goodx

    ----------------------------------------------------------------------第一步,准备工作:预定义一个全局Win控件变量,以及一个精简 ...

  9. Delphi中代替WebBrowser控件的第三方控件

    这几天,接触到在delphi中内嵌网页,用delphi7自带的TWebBrowser控件,显示的内容与本机IE8显示的不一样,但是跟装IE8之前的IE6显示一个效果.现在赶脚是下面两个原因中的一个: ...

随机推荐

  1. rsa 公钥 私钥

    如果用于加密解密,那就是用公钥加密私钥解密(仅你可读但别人不可读,任何人都可写)如果用于证书验证,那就是用私钥加密公钥解密(仅你可写但别人不可写,任何人都可读) 最后,RSA的公钥.私钥是互相对应的. ...

  2. DOS批处理前言

    -----------made by siwuxie095 1.批处理(Batch):望文知义,对某对象进行批量处理,实际上是一种脚本 2.DOS(Disk Operating System-磁盘操作 ...

  3. Web站点性能拨测脚本

    功能:检测自己本地访问目标网站的返回状态.访问质量信息 [root@localhost src]# cat get_site_status.sh #! /usr/bin/env bash if [[ ...

  4. 菜刀连接webshell

    中国菜刀,一个非常好用而又强大的webshell,它可不是用来切菜的做饭的道具哦,是一款专业的网站管理软件,大小只有300多KB,真是小巧实用啊!不过被不法分子利用到,就是一个黑站的利器了.我记得以前 ...

  5. Devexpress系列一 之 ChartControl 柱形图BarSideBySideSeries2D

    这一篇是讲的是简单的柱形图, 柱形图运行效果如下图: 新建WPF窗体应用程序后(WPF用户控件也可以),工程引用DevExpress.Xpf.Charts.v17.1.dll, 在XAML头部引用名称 ...

  6. SQL 将一个字段内用逗号分隔的内容分成多条记录

    转自:http://www.cnblogs.com/zfanlong1314/archive/2013/01/14/2859848.html --> 测试数据 if not object_id( ...

  7. 【转】MEF程序设计指南三:MEF中组合部件(Composable Parts)与契约(Contracts)的基本应用

    按照MEF的约定,任何一个类或者是接口的实现都可以通过[System.ComponentModel.Composition.ExportAttribute] 特性将其定义为组合部件(Composabl ...

  8. 在Excel中根据某一个单元格的出生日期自动精确计算年龄

    =IF(MONTH(NOW())<MONTH(G4),INT(YEAR(NOW())-YEAR(G4))-1,IF(MONTH(NOW())>MONTH(G4),YEAR(NOW())-Y ...

  9. 2017年UX设计流行的六大趋势

    UX设计在接下来的2017年会有怎样的发展趋势呢?让我们一起回顾去年用户体验设计领域中的变化,来展望新一年用户体验设计的发展趋势吧. 1. 原型制作的爆炸性增长   随着用户体验设计师和用户界面设计师 ...

  10. cubieboard网络设置

    1.1 配置静态ip vi /etc/network/interface auto lo iface lo inet loopback #以下是添加的内如 auto eth0 #iface eth0 ...