diff --git a/EmailOAuthDm.pas b/EmailOAuthDm.pas index 4467188..8a7521f 100644 --- a/EmailOAuthDm.pas +++ b/EmailOAuthDm.pas @@ -75,10 +75,15 @@ TEmailOAuthDataModule = class(TDataModule) FOAuth2_Enhanced : TEnhancedOAuth2Authenticator; FIniSettings : TIniFile; FIsAuthenticated : Boolean; + fPKCE: Boolean; procedure DoLog(const msg: String); procedure ForceForegroundNoActivate(hWnd: THandle); procedure DeleteSASL(SASLMechanisms: TIdSASLEntries; xClass: TIdSASLOAuthBaseClass); procedure DeleteSASLOAuth; + + procedure SetPKCE(const Value: Boolean); + public + property PKCE : Boolean read fPKCE write SetPKCE; public { Public declarations } SendAddress : string; @@ -207,7 +212,12 @@ procedure TEmailOAuthDataModule.IdHTTPServer1CommandGet(AContext: TIdContext; AR FOAuth2_Enhanced.AuthCode := LCode; FOAuth2_Enhanced.ChangeAuthCodeToAccesToken; LTokenName := Provider.AuthName + 'Token'; + FIniSettings.WriteString('Authentication', LTokenName, FOAuth2_Enhanced.RefreshToken); + FIniSettings.WriteBool('Authentication', LTokenName + '_PKCE', FOAuth2_Enhanced.UsePKCE ); + FIniSettings.WriteString('Authentication', LTokenName + '_PKCE_Verifier', FOAuth2_Enhanced.PKCEVerifier); + FIniSettings.WriteString('Authentication', LTokenName + '_PKCE_Challenge', FOAuth2_Enhanced.PKCEChallenge); + var jwt := TJWT.Create(FOAuth2_Enhanced.IDToken); if jwt.Payload.ContainsKey('email') then begin @@ -228,7 +238,7 @@ function TEmailOAuthDataModule.IsAuthenticated: boolean; function TEmailOAuthDataModule.ReadString(const Ident, Default: string): string; begin - Result := FIniSettings.ReadString('Authentication', Ident, ''); + Result := FIniSettings.ReadString('Authentication', Ident, Default); end; procedure TEmailOAuthDataModule.DeleteSASL(SASLMechanisms : TIdSASLEntries; xClass: TIdSASLOAuthBaseClass); @@ -689,6 +699,12 @@ procedure TEmailOAuthDataModule.CheckPOP; IdPOP3.Disconnect; end; +procedure TEmailOAuthDataModule.SetPKCE(const Value: Boolean); +begin + fPKCE := Value; + FOAuth2_Enhanced.UsePKCE := fPKCE; +end; + procedure TEmailOAuthDataModule.SetupAuthenticator; begin FOAuth2_Enhanced.ClientID := Provider.ClientID; @@ -699,6 +715,9 @@ procedure TEmailOAuthDataModule.SetupAuthenticator; FOAuth2_Enhanced.AccessTokenEndpoint := Provider.AccessTokenEndpoint; FOAuth2_Enhanced.RefreshToken := FIniSettings.ReadString('Authentication', Provider.TokenName, ''); + FOAuth2_Enhanced.UsePKCE := FIniSettings.ReadBool('Authentication', Provider.TokenName + '_PKCE', False); + FOAuth2_Enhanced.PKCEVerifier := FIniSettings.ReadString('Authentication', Provider.TokenName + '_PKCE_Verifier', ''); + FOAuth2_Enhanced.PKCEChallenge := FIniSettings.ReadString('Authentication', Provider.TokenName + '_PKCE_Challenge', ''); SendAddress := FIniSettings.ReadString('Authentication', Provider.TokenName + 'Email', ''); diff --git a/REST.Authenticator.EnhancedOAuth.pas b/REST.Authenticator.EnhancedOAuth.pas index 6c9a5c0..a79383d 100644 --- a/REST.Authenticator.EnhancedOAuth.pas +++ b/REST.Authenticator.EnhancedOAuth.pas @@ -1,372 +1,510 @@ -unit REST.Authenticator.EnhancedOAuth; - -interface - -uses - System.SysUtils - , REST.Authenticator.OAuth - , System.JSON - ; - -type - TJWTHeader = class - private - FHeaderJSON: TJSONObject; - public - constructor Create(const HeaderStr: string); - destructor Destroy; override; - function Algorithm: string; - function TokenType: string; - function KeyId: string; - end; - - TJWTPayload = class - private - FPayloadJSON: TJSONObject; - public - constructor Create(const PayloadStr: string); - destructor Destroy; override; - function Subject: string; - function Issuer: string; - function Expiration: Int64; - function ContainsKey(const Key: string): Boolean; - function GetValue(const Key: string): string; - end; - - TJWT = class - private - FHeader: TJWTHeader; - FPayload: TJWTPayload; - FSignature: string; - function Base64UrlDecode(const Input: string): string; - public - constructor Create(const Token: string); - destructor Destroy; override; - function GetSignature: string; - property Header: TJWTHeader read FHeader; - property Payload: TJWTPayload read FPayload; - end; - - TEnhancedOAuth2Authenticator = class (TOAuth2Authenticator) - private - procedure RequestAccessToken; - public - IDToken : string; - procedure ChangeAuthCodeToAccesToken; - procedure RefreshAccessTokenIfRequired; - function AuthorizationRequestURI: string; - end; - -implementation - -uses - System.NetEncoding - , System.Net.URLClient - , System.DateUtils - , IdSASL.Oauth.XOAUTH2 - , IdSASL.Oauth.OAuth2Bearer - , REST.Client - , REST.Consts - , REST.Types - ; - - -const - SClientIDNeeded = 'An ClientID is needed before a token can be requested'; - SRefreshTokenNeeded = 'An Refresh Token is needed before an Access Token can be requested'; - -function TEnhancedOAuth2Authenticator.AuthorizationRequestURI: string; -var - uri : TURI; -begin - uri := TURI.Create(AuthorizationEndpoint); - uri.AddParameter('response_type', OAuth2ResponseTypeToString(ResponseType)); - if ClientID <> '' then - uri.AddParameter('client_id', ClientID); - if RedirectionEndpoint <> '' then - uri.AddParameter('redirect_uri', RedirectionEndpoint); - if Scope <> '' then - uri.AddParameter('scope', Scope); - if LocalState <> '' then - uri.AddParameter('state', LocalState); - - Result := uri.ToString; -end; - -procedure TEnhancedOAuth2Authenticator.RefreshAccessTokenIfRequired; -begin - if AccessTokenExpiry < now then - begin - RequestAccessToken; - end; -end; - -procedure TEnhancedOAuth2Authenticator.RequestAccessToken; -var - LClient: TRestClient; - LRequest: TRESTRequest; - paramBody: TRESTRequestParameter; - LToken: string; - LIntValue: int64; - url : TURI; -begin - - // we do need an clientid here, because we want - // to send it to the servce and exchange the code into an - // access-token. - if ClientID = '' then - raise EOAuth2Exception.Create(SClientIDNeeded); - - if RefreshToken = '' then - raise EOAuth2Exception.Create(SRefreshTokenNeeded); - - LClient := TRestClient.Create(AccessTokenEndpoint); - try - LRequest := TRESTRequest.Create(LClient); // The LClient now "owns" the Request and will free it. - LRequest.Method := TRESTRequestMethod.rmPOST; - - url := TURI.Create('http://localhost'); - url.AddParameter('grant_type', 'refresh_token'); - url.AddParameter('refresh_token', RefreshToken); - url.AddParameter('client_id', ClientID); - if not ClientSecret.IsEmpty then - url.AddParameter('client_secret', ClientSecret); - paramBody := LRequest.Params.AddItem; - paramBody.Value := url.Query; - paramBody.Kind := pkREQUESTBODY; - paramBody.Options := [poDoNotEncode]; - paramBody.ContentType := TRESTContentType.ctAPPLICATION_X_WWW_FORM_URLENCODED; - - LRequest.Execute; - - if LRequest.Response.GetSimpleValue('access_token', LToken) then - AccessToken := LToken; - if LRequest.Response.GetSimpleValue('refresh_token', LToken) then - RefreshToken := LToken; - if LRequest.Response.GetSimpleValue('id_token', LToken) then - IDToken := LToken; - - // detect token-type. this is important for how using it later - if LRequest.Response.GetSimpleValue('token_type', LToken) then - TokenType := OAuth2TokenTypeFromString(LToken); - - // if provided by the service, the field "expires_in" contains - // the number of seconds an access-token will be valid - if LRequest.Response.GetSimpleValue('expires_in', LToken) then - begin - LIntValue := StrToIntdef(LToken, -1); - if (LIntValue > -1) then - AccessTokenExpiry := IncSecond(Now, LIntValue) - else - AccessTokenExpiry := 0.0; - end; - - // an authentication-code may only be used once. - // if we succeeded here and got an access-token, then - // we do clear the auth-code as is is not valid anymore - // and also not needed anymore. - if (AccessToken <> '') then - begin - AuthCode := ''; - end; - finally - FreeAndNil(LClient); - end; -end; - - -// This function is basically a copy of the ancestor... but is need so we can also get the id_token value. -procedure TEnhancedOAuth2Authenticator.ChangeAuthCodeToAccesToken; -var - LClient: TRestClient; - LRequest: TRESTRequest; - paramBody : TRESTRequestParameter; - LToken: string; - LIntValue: int64; - url : TURI; -begin - - // we do need an authorization-code here, because we want - // to send it to the servce and exchange the code into an - // access-token. - if AuthCode = '' then - raise EOAuth2Exception.Create(SAuthorizationCodeNeeded); - - LClient := TRestClient.Create(AccessTokenEndpoint); - try - LRequest := TRESTRequest.Create(LClient); // The LClient now "owns" the Request and will free it. - LRequest.Method := TRESTRequestMethod.rmPOST; - url := TURI.Create('http://localhost'); - url.AddParameter('grant_type', 'authorization_code'); - url.AddParameter('code', AuthCode); - url.AddParameter('client_id', ClientID); - url.AddParameter('client_secret', ClientSecret); - url.AddParameter('redirect_uri', RedirectionEndpoint); - - paramBody := LRequest.Params.AddItem; - paramBody.Value := url.Query; - paramBody.Kind := pkREQUESTBODY; - paramBody.Options := [poDoNotEncode]; - paramBody.ContentType := TRESTContentType.ctAPPLICATION_X_WWW_FORM_URLENCODED; - - - LRequest.Execute; - - if LRequest.Response.GetSimpleValue('access_token', LToken) then - AccessToken := LToken; - if LRequest.Response.GetSimpleValue('refresh_token', LToken) then - RefreshToken := LToken; - if LRequest.Response.GetSimpleValue('id_token', LToken) then - IDToken := LToken; - - - // detect token-type. this is important for how using it later - if LRequest.Response.GetSimpleValue('token_type', LToken) then - TokenType := OAuth2TokenTypeFromString(LToken); - - // if provided by the service, the field "expires_in" contains - // the number of seconds an access-token will be valid - if LRequest.Response.GetSimpleValue('expires_in', LToken) then - begin - LIntValue := StrToIntdef(LToken, -1); - if (LIntValue > -1) then - AccessTokenExpiry := IncSecond(Now, LIntValue) - else - AccessTokenExpiry := 0.0; - end; - - // an authentication-code may only be used once. - // if we succeeded here and got an access-token, then - // we do clear the auth-code as is is not valid anymore - // and also not needed anymore. - if (AccessToken <> '') then - AuthCode := ''; - finally - FreeAndNil(LClient); - end; -end; - -{ TJWTHeader } - -constructor TJWTHeader.Create(const HeaderStr: string); -begin - FHeaderJSON := TJSONObject.ParseJSONValue(HeaderStr) as TJSONObject; -end; - -destructor TJWTHeader.Destroy; -begin - FHeaderJSON.Free; - inherited; -end; - -function TJWTHeader.Algorithm: string; -begin - if Assigned(FHeaderJSON) and FHeaderJSON.TryGetValue('alg', Result) then - Exit; - Result := ''; -end; - -function TJWTHeader.TokenType: string; -begin - if Assigned(FHeaderJSON) and FHeaderJSON.TryGetValue('typ', Result) then - Exit; - Result := ''; -end; - -function TJWTHeader.KeyId: string; -begin - if Assigned(FHeaderJSON) and FHeaderJSON.TryGetValue('kid', Result) then - Exit; - Result := ''; -end; - -{ TJWTPayload } - -constructor TJWTPayload.Create(const PayloadStr: string); -begin - FPayloadJSON := TJSONObject.ParseJSONValue(PayloadStr) as TJSONObject; -end; - -destructor TJWTPayload.Destroy; -begin - FPayloadJSON.Free; - inherited; -end; - -function TJWTPayload.Subject: string; -begin - if Assigned(FPayloadJSON) and FPayloadJSON.TryGetValue('sub', Result) then - Exit; - Result := ''; -end; - -function TJWTPayload.Issuer: string; -begin - if Assigned(FPayloadJSON) and FPayloadJSON.TryGetValue('iss', Result) then - Exit; - Result := ''; -end; - -function TJWTPayload.Expiration: Int64; -begin - if Assigned(FPayloadJSON) and FPayloadJSON.TryGetValue('exp', Result) then - Exit; - Result := 0; -end; - -function TJWTPayload.ContainsKey(const Key: string): Boolean; -begin - Result := Assigned(FPayloadJSON) and (FPayloadJSON.Values[Key] <> nil); -end; - -function TJWTPayload.GetValue(const Key: string): string; -begin - if Assigned(FPayloadJSON) and FPayloadJSON.TryGetValue(Key, Result) then - Exit; - Result := ''; -end; - -{ TJWT } - -constructor TJWT.Create(const Token: string); -var - Parts: TArray; -begin - Parts := Token.Split(['.']); - if Length(Parts) = 3 then - begin - FHeader := TJWTHeader.Create(Base64UrlDecode(Parts[0])); - FPayload := TJWTPayload.Create(Base64UrlDecode(Parts[1])); - FSignature := Parts[2]; - end - else - raise Exception.Create('Invalid JWT token format'); -end; - -destructor TJWT.Destroy; -begin - FHeader.Free; - FPayload.Free; - inherited; -end; - -function TJWT.Base64UrlDecode(const Input: string): string; -var - Base64: string; - Bytes: TBytes; -begin - Base64 := Input; - Base64 := Base64.Replace('-', '+').Replace('_', '/'); - while (Length(Base64) mod 4) <> 0 do - Base64 := Base64 + '='; - - Bytes := TBase64Encoding.Base64.DecodeStringToBytes(Base64); - Result := TEncoding.UTF8.GetString(Bytes); -end; - -function TJWT.GetSignature: string; -begin - Result := FSignature; -end; - -end. +unit REST.Authenticator.EnhancedOAuth; + +interface + +uses + System.SysUtils + , REST.Authenticator.OAuth + , System.JSON + ; + +type + TJWTHeader = class + private + FHeaderJSON: TJSONObject; + public + constructor Create(const HeaderStr: string); + destructor Destroy; override; + function Algorithm: string; + function TokenType: string; + function KeyId: string; + end; + + TJWTPayload = class + private + FPayloadJSON: TJSONObject; + public + constructor Create(const PayloadStr: string); + destructor Destroy; override; + function Subject: string; + function Issuer: string; + function Expiration: Int64; + function ContainsKey(const Key: string): Boolean; + function GetValue(const Key: string): string; + end; + + TJWT = class + private + FHeader: TJWTHeader; + FPayload: TJWTPayload; + FSignature: string; + function Base64UrlDecode(const Input: string): string; + public + constructor Create(const Token: string); + destructor Destroy; override; + function GetSignature: string; + property Header: TJWTHeader read FHeader; + property Payload: TJWTPayload read FPayload; + end; + + TEnhancedOAuth2Authenticator = class (TOAuth2Authenticator) + private + fUsePKCE: boolean; + fPKCEVerifier : string; + fPKCEChallenge : string; + procedure InitPKCE; + procedure RequestAccessToken; + procedure SetUsePKCE(const Value: boolean); + public + IDToken : string; + procedure ChangeAuthCodeToAccesToken; + procedure RefreshAccessTokenIfRequired; + function AuthorizationRequestURI: string; + + property UsePKCE : boolean read fUsePKCE write SetUsePKCE; + property PKCEChallenge : string read fPKCEChallenge write fPKCEChallenge; + property PKCEVerifier : string read fPKCEVerifier write fPKCEVerifier; + end; + +implementation + +uses + System.NetEncoding + , System.Net.URLClient + , System.DateUtils + , System.Hash + , IdSASL.Oauth.XOAUTH2 + , IdSASL.Oauth.OAuth2Bearer + , REST.Client + , REST.Consts + , REST.Types + , IdHashSha + , IdGlobal + , Winapi.Windows + ; + + +const + SClientIDNeeded = 'An ClientID is needed before a token can be requested'; + SRefreshTokenNeeded = 'An Refresh Token is needed before an Access Token can be requested'; + +function TEnhancedOAuth2Authenticator.AuthorizationRequestURI: string; +var + uri : TURI; +begin + uri := TURI.Create(AuthorizationEndpoint); + uri.AddParameter('response_type', OAuth2ResponseTypeToString(ResponseType)); + if ClientID <> '' then + uri.AddParameter('client_id', ClientID); + if RedirectionEndpoint <> '' then + uri.AddParameter('redirect_uri', RedirectionEndpoint); + if Scope <> '' then + uri.AddParameter('scope', Scope); + if LocalState <> '' then + uri.AddParameter('state', LocalState); + + if fUsePKCE then + begin + InitPKCE; // create a new challenge for the authirization request! + + uri.AddParameter('code_challenge_method', 'S256'); + uri.AddParameter('code_challenge', fPKCEChallenge); + end; + + Result := uri.ToString; +end; + +procedure TEnhancedOAuth2Authenticator.RefreshAccessTokenIfRequired; +begin + if AccessTokenExpiry < now then + begin + RequestAccessToken; + end; +end; + +procedure TEnhancedOAuth2Authenticator.RequestAccessToken; +var + LClient: TRestClient; + LRequest: TRESTRequest; + paramBody: TRESTRequestParameter; + LToken: string; + LIntValue: int64; + url : TURI; + i : integer; +begin + + // we do need an clientid here, because we want + // to send it to the servce and exchange the code into an + // access-token. + if ClientID = '' then + raise EOAuth2Exception.Create(SClientIDNeeded); + + if RefreshToken = '' then + raise EOAuth2Exception.Create(SRefreshTokenNeeded); + + LClient := TRestClient.Create(AccessTokenEndpoint); + try + LRequest := TRESTRequest.Create(LClient); // The LClient now "owns" the Request and will free it. + LRequest.Method := TRESTRequestMethod.rmPOST; + + url := TURI.Create('http://localhost'); + url.AddParameter('grant_type', 'refresh_token'); + url.AddParameter('refresh_token', RefreshToken); + url.AddParameter('client_id', ClientID); + if not ClientSecret.IsEmpty then + url.AddParameter('client_secret', ClientSecret); + + for i := 0 to Length(url.Params) - 1 do + begin + paramBody := LRequest.Params.AddItem; + paramBody.Name := url.params[i].Name; + paramBody.Value := url.Params[i].Value; + paramBody.Kind := pkREQUESTBODY; + paramBody.Options := [poDoNotEncode]; + paramBody.ContentType := TRESTContentType.ctAPPLICATION_X_WWW_FORM_URLENCODED; + end; + + LRequest.Execute; + + if LRequest.Response.GetSimpleValue('access_token', LToken) then + AccessToken := LToken; + if LRequest.Response.GetSimpleValue('refresh_token', LToken) then + RefreshToken := LToken; + if LRequest.Response.GetSimpleValue('id_token', LToken) then + IDToken := LToken; + + // detect token-type. this is important for how using it later + if LRequest.Response.GetSimpleValue('token_type', LToken) then + TokenType := OAuth2TokenTypeFromString(LToken); + + // if provided by the service, the field "expires_in" contains + // the number of seconds an access-token will be valid + if LRequest.Response.GetSimpleValue('expires_in', LToken) then + begin + LIntValue := StrToIntdef(LToken, -1); + if (LIntValue > -1) then + AccessTokenExpiry := IncSecond(Now, LIntValue) + else + AccessTokenExpiry := 0.0; + end; + + // an authentication-code may only be used once. + // if we succeeded here and got an access-token, then + // we do clear the auth-code as is is not valid anymore + // and also not needed anymore. + if (AccessToken <> '') then + begin + AuthCode := ''; + end; + finally + FreeAndNil(LClient); + end; +end; + + +procedure TEnhancedOAuth2Authenticator.SetUsePKCE(const Value: boolean); +begin + fUsePKCE := Value; + + fPKCEVerifier := ''; + fPKCEChallenge := ''; +end; + +// This function is basically a copy of the ancestor... but is need so we can also get the id_token value. +procedure TEnhancedOAuth2Authenticator.ChangeAuthCodeToAccesToken; +var + LClient: TRestClient; + LRequest: TRESTRequest; + paramBody : TRESTRequestParameter; + LToken: string; + LIntValue: int64; + url : TURI; + i : integer; +begin + + // we do need an authorization-code here, because we want + // to send it to the servce and exchange the code into an + // access-token. + if AuthCode = '' then + raise EOAuth2Exception.Create(SAuthorizationCodeNeeded); + + LClient := TRestClient.Create(AccessTokenEndpoint); + try + LRequest := TRESTRequest.Create(LClient); // The LClient now "owns" the Request and will free it. + LRequest.Method := TRESTRequestMethod.rmPOST; + url := TURI.Create('http://localhost'); + url.AddParameter('grant_type', 'authorization_code'); + url.AddParameter('code', AuthCode); + url.AddParameter('client_id', ClientID); + url.AddParameter('client_secret', ClientSecret); + url.AddParameter('redirect_uri', RedirectionEndpoint); + + if fUsePKCE then + url.AddParameter('code_verifier', fPKCEVerifier); + + for i := 0 to Length(url.Params) - 1 do + begin + paramBody := LRequest.Params.AddItem; + paramBody.Name := url.params[i].Name; + paramBody.Value := url.Params[i].Value; + paramBody.Kind := pkREQUESTBODY; + paramBody.Options := [poDoNotEncode]; + paramBody.ContentType := TRESTContentType.ctAPPLICATION_X_WWW_FORM_URLENCODED; + end; + + try + LRequest.Execute; + except + on E : Exception do + begin + raise Exception.Create('error msg: ' + E.Message + #13#10 + 'Content: ' + LRequest.Response.Content); + end; + + end; + + if LRequest.Response.GetSimpleValue('access_token', LToken) then + AccessToken := LToken; + if lToken = '' then + raise Exception.Create('No Token: ' + LRequest.Response.Content); + if LRequest.Response.GetSimpleValue('refresh_token', LToken) then + RefreshToken := LToken; + if LRequest.Response.GetSimpleValue('id_token', LToken) then + IDToken := LToken; + + + // detect token-type. this is important for how using it later + if LRequest.Response.GetSimpleValue('token_type', LToken) then + TokenType := OAuth2TokenTypeFromString(LToken); + + // if provided by the service, the field "expires_in" contains + // the number of seconds an access-token will be valid + if LRequest.Response.GetSimpleValue('expires_in', LToken) then + begin + LIntValue := StrToIntdef(LToken, -1); + if (LIntValue > -1) then + AccessTokenExpiry := IncSecond(Now, LIntValue) + else + AccessTokenExpiry := 0.0; + end; + + // an authentication-code may only be used once. + // if we succeeded here and got an access-token, then + // we do clear the auth-code as is is not valid anymore + // and also not needed anymore. + if (AccessToken <> '') then + AuthCode := ''; + finally + FreeAndNil(LClient); + end; +end; + +// ########################################### +// #### Cryptographic random engine: +// ########################################### + +type + BCrypt_ALG_HANDLE = Pointer; + + // newer BCrypt.h API + TBCryptGenRandom = function (hAlgorith : BCRYPT_ALG_HANDLE; pbBuffer : PByte; + cbBuffer : ULong; dwFlags : ULong ) : Longint; stdcall; + +const BCRYPT_USE_SYSTEM_PREFERRED_RNG = $00000002; + STATUS_SUCCESS = 0; + +var locBcryptHdl : THandle = 0; + locBCrytGenRandom : TBCryptGenRandom = nil; + +function GetRandomBuffer( len : integer ) : TBytes; +var i : integer; +begin + // cryptographic secure os provided random generator + if locBcryptHdl = 0 then + begin + locBcryptHdl := LoadLibrary('BCrypt.dll'); + + if locBcryptHdl <> 0 + then + locBCrytGenRandom := TBCryptGenRandom( GetProcAddress(locBCryptHdl, 'BCryptGenRandom') ) + else + Randomize; + end; + + SetLength(Result, len); + + if Assigned(locBCrytGenRandom) and (len > 0) then + begin + if locBCrytGenRandom(nil, @Result[0], len, BCRYPT_USE_SYSTEM_PREFERRED_RNG) <> STATUS_SUCCESS then + RaiseLastOSError; + end + else + begin + // fallback to non cryptographic random generator + for i := 0 to Length(Result) - 1 do + Result[i] := Byte( Random($FF) ); + end; + +end; + +procedure TEnhancedOAuth2Authenticator.InitPKCE; +const cMaxRandLen = 128; // as of rfc7636 the base64 url encoded string hast to be >= 43 and <= 128 characters + cRndBufLen = 64; // recommended by RFC is 32 + + function EncBase64Url( buf : TBytes ) : string; + var enc : TBase64Encoding; + begin + enc := TBase64Encoding.Create(0); + try + Result := enc.EncodeBytesToString(buf); + + // convert base64 to base64 url encoded: + Result := StringReplace(Result, '+', '-', [rfReplaceAll]); // Replace + with - + Result := StringReplace(Result, '/', '_', [rfReplaceAll]); // Replace / with _ + Result := StringReplace(Result, '=', '', [rfReplaceAll]); // Remove padding, character = + finally + enc.Free; + end; + end; + function RandStringBase64 : string; + var buf : TBytes; + begin + buf := GetRandomBuffer(cRndBufLen); + + Result := EncBase64Url(buf); + end; + +var buf : TBytes; + hashsha256 : THashSHA2; +begin + fPKCEVerifier := RandStringBase64; + LocalState := RandStringBase64; + + // challange is: BASE64URL-ENCODE(SHA256(ASCII(code_verifier))) + buf := hashsha256.GetHashBytes(fPKCEVerifier, SHA256); // internally does a convertion to utf8 which is ansi for a base64 encoded string + fPKCEChallenge := EncBase64Url(buf); +end; + +{ TJWTHeader } + +constructor TJWTHeader.Create(const HeaderStr: string); +begin + FHeaderJSON := TJSONObject.ParseJSONValue(HeaderStr) as TJSONObject; +end; + +destructor TJWTHeader.Destroy; +begin + FHeaderJSON.Free; + inherited; +end; + +function TJWTHeader.Algorithm: string; +begin + if Assigned(FHeaderJSON) and FHeaderJSON.TryGetValue('alg', Result) then + Exit; + Result := ''; +end; + +function TJWTHeader.TokenType: string; +begin + if Assigned(FHeaderJSON) and FHeaderJSON.TryGetValue('typ', Result) then + Exit; + Result := ''; +end; + +function TJWTHeader.KeyId: string; +begin + if Assigned(FHeaderJSON) and FHeaderJSON.TryGetValue('kid', Result) then + Exit; + Result := ''; +end; + +{ TJWTPayload } + +constructor TJWTPayload.Create(const PayloadStr: string); +begin + FPayloadJSON := TJSONObject.ParseJSONValue(PayloadStr) as TJSONObject; +end; + +destructor TJWTPayload.Destroy; +begin + FPayloadJSON.Free; + inherited; +end; + +function TJWTPayload.Subject: string; +begin + if Assigned(FPayloadJSON) and FPayloadJSON.TryGetValue('sub', Result) then + Exit; + Result := ''; +end; + +function TJWTPayload.Issuer: string; +begin + if Assigned(FPayloadJSON) and FPayloadJSON.TryGetValue('iss', Result) then + Exit; + Result := ''; +end; + +function TJWTPayload.Expiration: Int64; +begin + if Assigned(FPayloadJSON) and FPayloadJSON.TryGetValue('exp', Result) then + Exit; + Result := 0; +end; + +function TJWTPayload.ContainsKey(const Key: string): Boolean; +begin + Result := Assigned(FPayloadJSON) and (FPayloadJSON.Values[Key] <> nil); +end; + +function TJWTPayload.GetValue(const Key: string): string; +begin + if Assigned(FPayloadJSON) and FPayloadJSON.TryGetValue(Key, Result) then + Exit; + Result := ''; +end; + +{ TJWT } + +constructor TJWT.Create(const Token: string); +var + Parts: TArray; +begin + Parts := Token.Split(['.']); + if Length(Parts) = 3 then + begin + FHeader := TJWTHeader.Create(Base64UrlDecode(Parts[0])); + FPayload := TJWTPayload.Create(Base64UrlDecode(Parts[1])); + FSignature := Parts[2]; + end + else + raise Exception.Create('Invalid JWT token format'); +end; + +destructor TJWT.Destroy; +begin + FHeader.Free; + FPayload.Free; + inherited; +end; + +function TJWT.Base64UrlDecode(const Input: string): string; +var + Base64: string; + Bytes: TBytes; +begin + Base64 := Input; + Base64 := Base64.Replace('-', '+').Replace('_', '/'); + while (Length(Base64) mod 4) <> 0 do + Base64 := Base64 + '='; + + Bytes := TBase64Encoding.Base64.DecodeStringToBytes(Base64); + Result := TEncoding.UTF8.GetString(Bytes); +end; + +function TJWT.GetSignature: string; +begin + Result := FSignature; +end; + +end. diff --git a/Unit2.dfm b/Unit2.dfm index bd24bac..d45d13e 100644 --- a/Unit2.dfm +++ b/Unit2.dfm @@ -1,308 +1,225 @@ -object Form2: TForm2 - Left = 0 - Top = 0 - Caption = 'Test OAUTH2 Gmail Send Message' - ClientHeight = 943 - ClientWidth = 1518 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -28 - Font.Name = 'Tahoma' - Font.Style = [] - OnCreate = FormCreate - OnDestroy = FormDestroy - PixelsPerInch = 240 - DesignSize = ( - 1518 - 943) - TextHeight = 34 - object btnAuthenticate: TButton - Left = 1200 - Top = 19 - Width = 321 - Height = 63 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Anchors = [akTop, akRight] - Caption = 'Authenticate' - TabOrder = 0 - OnClick = btnAuthenticateClick - end - object btnSendMsg: TButton - Left = 1200 - Top = 218 - Width = 314 - Height = 62 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Anchors = [akTop, akRight] - Caption = 'Send MSG' - TabOrder = 1 - OnClick = btnSendMsgClick - end - object rgEmailProviders: TRadioGroup - Left = 20 - Top = 20 - Width = 1023 - Height = 145 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Caption = 'Provider' - Columns = 3 - ItemIndex = 0 - Items.Strings = ( - 'GMail' - 'Microsoft' - 'Hotmail') - TabOrder = 2 - OnClick = rgEmailProvidersClick - end - object btnCheckMsg: TButton - Left = 1200 - Top = 524 - Width = 314 - Height = 63 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Anchors = [akTop, akRight] - Caption = 'Check MSG'#39's' - TabOrder = 3 - OnClick = btnCheckMsgClick - end - object btnClearAuthToken: TButton - Left = 1200 - Top = 98 - Width = 314 - Height = 62 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Anchors = [akTop, akRight] - Caption = 'Clear Auth Token' - TabOrder = 4 - OnClick = btnClearAuthTokenClick - end - object btnCheckIMAP: TButton - Left = 1200 - Top = 624 - Width = 314 - Height = 63 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Anchors = [akTop, akRight] - Caption = 'Check IMAP' - TabOrder = 5 - OnClick = btnCheckIMAPClick - end - object btnSendViaREST: TButton - Left = 1200 - Top = 402 - Width = 314 - Height = 62 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Anchors = [akTop, akRight] - Caption = 'Send MSG via REST' - TabOrder = 6 - OnClick = btnSendViaRESTClick - end - object PageControl1: TPageControl - Left = 20 - Top = 181 - Width = 1141 - Height = 749 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - ActivePage = tsEmail - Anchors = [akLeft, akTop, akRight, akBottom] - TabOrder = 7 - object tsEmail: TTabSheet - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Caption = 'Email' - DesignSize = ( - 1121 - 682) - object lblFrom: TLabel - Left = 88 - Top = 48 - Width = 181 - Height = 34 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Caption = 'From Address:' - end - object lblRecipientAddress: TLabel - Left = 40 - Top = 178 - Width = 229 - Height = 34 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Caption = 'Recipient Address:' - end - object lblFromName: TLabel - Left = 113 - Top = 98 - Width = 156 - Height = 34 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Caption = 'From Name:' - end - object lblRecipientName: TLabel - Left = 65 - Top = 228 - Width = 204 - Height = 34 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Caption = 'Recipient Name:' - end - object lblSubject: TLabel - Left = 167 - Top = 286 - Width = 102 - Height = 34 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Caption = 'Subject:' - end - object edtFromAddress: TEdit - Left = 285 - Top = 37 - Width = 776 - Height = 42 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - TabOrder = 0 - end - object edtFromName: TEdit - Left = 285 - Top = 95 - Width = 776 - Height = 42 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - TabOrder = 1 - end - object edtRecipientAddress: TEdit - Left = 285 - Top = 167 - Width = 776 - Height = 42 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - TabOrder = 2 - end - object edtRecipientName: TEdit - Left = 285 - Top = 225 - Width = 776 - Height = 42 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - TabOrder = 3 - end - object mmoBody: TMemo - Left = 65 - Top = 360 - Width = 1016 - Height = 314 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Anchors = [akLeft, akTop, akRight, akBottom] - Lines.Strings = ( - 'Body Text') - TabOrder = 4 - end - object edtSubject: TEdit - Left = 285 - Top = 283 - Width = 776 - Height = 42 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - TabOrder = 5 - Text = 'Test Subject' - end - end - object tsLogging: TTabSheet - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Caption = 'Logging' - ImageIndex = 1 - object mmoLogging: TMemo - Left = 0 - Top = 0 - Width = 1121 - Height = 682 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Align = alClient - Lines.Strings = ( - 'Memo1') - ScrollBars = ssBoth - TabOrder = 0 - end - end - end - object btnSendHTMLMsg: TButton - Left = 1200 - Top = 296 - Width = 314 - Height = 62 - Margins.Left = 8 - Margins.Top = 8 - Margins.Right = 8 - Margins.Bottom = 8 - Anchors = [akTop, akRight] - Caption = 'Send MSG HTML Test' - TabOrder = 8 - OnClick = btnSendHTMLMsgClick - end -end +object Form2: TForm2 + Left = 0 + Top = 0 + Margins.Left = 1 + Margins.Top = 1 + Margins.Right = 1 + Margins.Bottom = 1 + Caption = 'Test OAUTH2 Gmail Send Message' + ClientHeight = 556 + ClientWidth = 607 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OnCreate = FormCreate + OnDestroy = FormDestroy + DesignSize = ( + 607 + 556) + TextHeight = 13 + object btnAuthenticate: TButton + Left = 474 + Top = 8 + Width = 128 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Authenticate' + TabOrder = 0 + OnClick = btnAuthenticateClick + end + object btnSendMsg: TButton + Left = 474 + Top = 87 + Width = 126 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Send MSG' + TabOrder = 1 + OnClick = btnSendMsgClick + end + object rgEmailProviders: TRadioGroup + Left = 8 + Top = 8 + Width = 337 + Height = 58 + Caption = 'Provider' + Columns = 3 + ItemIndex = 0 + Items.Strings = ( + 'GMail' + 'Microsoft' + 'Hotmail') + TabOrder = 2 + OnClick = rgEmailProvidersClick + end + object btnCheckMsg: TButton + Left = 474 + Top = 210 + Width = 126 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Check MSG'#39's' + TabOrder = 3 + OnClick = btnCheckMsgClick + end + object btnClearAuthToken: TButton + Left = 474 + Top = 39 + Width = 126 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Clear Auth Token' + TabOrder = 4 + OnClick = btnClearAuthTokenClick + end + object btnCheckIMAP: TButton + Left = 474 + Top = 250 + Width = 126 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Check IMAP' + TabOrder = 5 + OnClick = btnCheckIMAPClick + end + object btnSendViaREST: TButton + Left = 474 + Top = 161 + Width = 126 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Send MSG via REST' + TabOrder = 6 + OnClick = btnSendViaRESTClick + end + object PageControl1: TPageControl + Left = 8 + Top = 72 + Width = 456 + Height = 479 + ActivePage = tsEmail + Anchors = [akLeft, akTop, akRight, akBottom] + TabOrder = 7 + object tsEmail: TTabSheet + Caption = 'Email' + DesignSize = ( + 448 + 451) + object lblFrom: TLabel + Left = 35 + Top = 19 + Width = 70 + Height = 13 + Caption = 'From Address:' + end + object lblRecipientAddress: TLabel + Left = 16 + Top = 71 + Width = 90 + Height = 13 + Caption = 'Recipient Address:' + end + object lblFromName: TLabel + Left = 45 + Top = 39 + Width = 58 + Height = 13 + Caption = 'From Name:' + end + object lblRecipientName: TLabel + Left = 26 + Top = 91 + Width = 78 + Height = 13 + Caption = 'Recipient Name:' + end + object lblSubject: TLabel + Left = 67 + Top = 114 + Width = 40 + Height = 13 + Caption = 'Subject:' + end + object edtFromAddress: TEdit + Left = 114 + Top = 15 + Width = 310 + Height = 21 + TabOrder = 0 + end + object edtFromName: TEdit + Left = 114 + Top = 38 + Width = 310 + Height = 21 + TabOrder = 1 + end + object edtRecipientAddress: TEdit + Left = 114 + Top = 67 + Width = 310 + Height = 21 + TabOrder = 2 + end + object edtRecipientName: TEdit + Left = 114 + Top = 90 + Width = 310 + Height = 21 + TabOrder = 3 + end + object mmoBody: TMemo + Left = 26 + Top = 144 + Width = 401 + Height = 79 + Anchors = [akLeft, akTop, akRight, akBottom] + Lines.Strings = ( + 'Body Text') + TabOrder = 4 + end + object edtSubject: TEdit + Left = 114 + Top = 113 + Width = 310 + Height = 21 + TabOrder = 5 + Text = 'Test Subject' + end + object mmoLogging: TMemo + Left = 26 + Top = 232 + Width = 401 + Height = 216 + Anchors = [akLeft, akTop, akBottom] + Lines.Strings = ( + 'Memo1') + ScrollBars = ssBoth + TabOrder = 6 + end + end + end + object btnSendHTMLMsg: TButton + Left = 474 + Top = 118 + Width = 126 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Send MSG HTML Test' + TabOrder = 8 + OnClick = btnSendHTMLMsgClick + end + object chkPKCE: TCheckBox + Left = 397 + Top = 12 + Width = 63 + Height = 17 + Caption = 'PKCE' + Checked = True + State = cbChecked + TabOrder = 9 + end +end diff --git a/Unit2.pas b/Unit2.pas index 615ca40..c06a4a5 100644 --- a/Unit2.pas +++ b/Unit2.pas @@ -1,262 +1,263 @@ -unit Unit2; - -interface - -uses - Winapi.Windows - , Winapi.Messages - , System.SysUtils - , System.Variants - , System.Classes - , Vcl.Graphics - , Vcl.Controls - , Vcl.StdCtrls - , Vcl.Forms - , Vcl.Dialogs - , Vcl.ExtCtrls - , Vcl.ComCtrls - , IdSASL - , IdSASLCollection - , IdExplicitTLSClientServerBase - , EmailOAuthDm - , IdSASL.Oauth.OAuth2Bearer - , IdSASL.Oauth.XOAUTH2 - , Email.Demo.Types - , Globals // rename from globals.sample.pas and update contents if missing - ; - -type - TForm2 = class(TForm) - btnAuthenticate: TButton; - btnSendMsg: TButton; - rgEmailProviders: TRadioGroup; - btnCheckMsg: TButton; - btnClearAuthToken: TButton; - btnCheckIMAP: TButton; - mmoLogging: TMemo; - btnSendViaREST: TButton; - PageControl1: TPageControl; - tsEmail: TTabSheet; - tsLogging: TTabSheet; - lblFrom: TLabel; - lblRecipientAddress: TLabel; - edtFromAddress: TEdit; - lblFromName: TLabel; - edtFromName: TEdit; - lblRecipientName: TLabel; - edtRecipientAddress: TEdit; - edtRecipientName: TEdit; - mmoBody: TMemo; - lblSubject: TLabel; - edtSubject: TEdit; - btnSendHTMLMsg: TButton; - procedure FormDestroy(Sender: TObject); - procedure FormCreate(Sender: TObject); - procedure btnCheckMsgClick(Sender: TObject); - procedure btnClearAuthTokenClick(Sender: TObject); - procedure rgEmailProvidersClick(Sender: TObject); - procedure btnCheckIMAPClick(Sender: TObject); - procedure btnAuthenticateClick(Sender: TObject); - procedure btnSendMsgClick(Sender: TObject); - procedure btnSendViaRESTClick(Sender: TObject); - procedure btnSendHTMLMsgClick(Sender: TObject); - private - { Private declarations } - EmailOAuthDataModule : TEmailOAuthDataModule; - procedure LogMsg(const msg: string); - public - { Public declarations } - procedure UpdateButtonsEnabled; - end; - -var - Form2: TForm2; - -implementation - -{$R *.dfm} - -uses - TaurusTLS; - -const - Providers : array[0..2] of TMailProviderInfo = - ( - ( AuthenticationType : TIdSASLXOAuth; - AuthorizationEndpoint : 'https://accounts.google.com/o/oauth2/auth?access_type=offline'; - AccessTokenEndpoint : 'https://accounts.google.com/o/oauth2/token'; - LogoutEndpoint : 'https://www.google.com/accounts/Logout'; - ClientID : google_clientid; - ClientSecret : google_clientsecret; - Scopes : 'https://mail.google.com/ openid email'; - SmtpHost : 'smtp.gmail.com'; - SmtpPort : 465; - PopHost : 'pop.gmail.com'; - PopPort : 995; - ImapHost : 'imap.gmail.com'; - ImapPort : 143; - AuthName : 'Google'; - TLS : utUseImplicitTLS; - Version : TTaurusTLSSSLVersion.TLSv1_3; - TwoLinePOPFormat: False - ), - ( AuthenticationType : TIdSASLXOAuth; - AuthorizationEndpoint : 'https://login.microsoftonline.com/common/oauth2/v2.0/authorize';//'https://login.live.com/oauth20_authorize.srf'; - AccessTokenEndpoint : 'https://login.microsoftonline.com/common/oauth2/v2.0/token';//'https://login.live.com/oauth20_token.srf'; - LogoutEndpoint : 'https://login.microsoftonline.com/common/oauth2/v2.0/logout'; - ClientID : microsoft_clientid; - ClientSecret : ''; - Scopes : 'https://outlook.office.com/IMAP.AccessAsUser.All https://outlook.office.com/POP.AccessAsUser.All https://outlook.office.com/SMTP.Send offline_access openid email profile'; - //'wl.imap offline_access'; - SmtpHost : 'smtp-mail.outlook.com'; - SmtpPort : 587; - PopHost : 'smtp-mail.outlook.com'; - PopPort : 995; - ImapHost : 'outlook.office365.com'; - ImapPort : 993; - AuthName : 'Microsoft'; - TLS : utUseExplicitTLS; - Version : TTaurusTLSSSLVersion.TLSv1_2; - TwoLinePOPFormat: True - ), - ( AuthenticationType : TIdSASLXOAuth; - AuthorizationEndpoint : 'https://login.live.com/oauth20_authorize.srf'; - AccessTokenEndpoint : 'https://login.live.com/oauth20_token.srf'; - LogoutEndpoint : 'https://login.live.com/logout.srf'; - ClientID : microsoft_clientid; - ClientSecret : ''; - // Scopes : 'https://outlook.office.com/IMAP.AccessAsUser.All https://outlook.office.com/POP.AccessAsUser.All https://outlook.office.com/SMTP.Send offline_access'; - Scopes : 'wl.imap wl.emails wl.offline_access openid email profile'; - SmtpHost : 'smtp-mail.outlook.com'; - SmtpPort : 587; - PopHost : 'outlook.office365.com'; - PopPort : 995; - ImapHost : 'imap-mail.outlook.com'; - ImapPort : 993; - AuthName : 'Hotmail'; - TLS : utUseExplicitTLS; - Version : TTaurusTLSSSLVersion.TLSv1_2; - ) - ); - -procedure TForm2.FormDestroy(Sender: TObject); -begin - FreeAndNil(EmailOAuthDataModule); -end; - -procedure TForm2.FormCreate(Sender: TObject); -begin - EmailOAuthDataModule := TEmailOAuthDataModule.Create(nil); - EmailOAuthDataModule.OnLog := LogMsg; - EmailOAuthDataModule.HWNDHandle := Self.Handle; - EmailOAuthDataModule.AppHandle := Application.Handle; - EmailOAuthDataModule.Provider := Providers[rgEmailProviders.ItemIndex]; - EmailOAuthDataModule.SetupAuthenticator; - edtFromAddress.Text := EmailOAuthDataModule.SendAddress; - edtFromName.Text := EmailOAuthDataModule.ReadString('FromName', ''); - edtSubject.Text := EmailOAuthDataModule.ReadString('Subject', ''); - edtRecipientAddress.Text := EmailOAuthDataModule.ReadString('RecipientAddress', ''); - edtRecipientName.Text := EmailOAuthDataModule.ReadString('RecipientName', ''); - UpdateButtonsEnabled; -end; - - -procedure TForm2.UpdateButtonsEnabled; -begin - btnAuthenticate.Enabled := not EmailOAuthDataModule.HasRefreshToken; - btnClearAuthToken.Enabled := EmailOAuthDataModule.HasRefreshToken; - btnSendViaREST.Enabled := rgEmailProviders.ItemIndex = 1; -end; - -procedure TForm2.btnAuthenticateClick(Sender: TObject); -begin - EmailOAuthDataModule.Authenticate; - UpdateButtonsEnabled; -end; - -procedure TForm2.btnCheckIMAPClick(Sender: TObject); -begin - EmailOAuthDataModule.CheckIMAP; -end; - -procedure TForm2.btnCheckMsgClick(Sender: TObject); -begin - EmailOAuthDataModule.CheckPOP; -end; - -procedure TForm2.btnClearAuthTokenClick(Sender: TObject); -begin - EmailOAuthDataModule.ClearAuthentication; - UpdateButtonsEnabled; -end; - -procedure TForm2.btnSendMsgClick(Sender: TObject); -begin - if string(edtRecipientAddress.Text).IsEmpty then - begin - ShowMessage('Recipient Email Address Required'); - Exit; - end; - - EmailOAuthDataModule.SendMessage(edtFromAddress.Text, edtFromName.Text, - edtRecipientAddress.Text, edtRecipientName.Text, - edtSubject.Text, mmoBody.Text, ''); - EmailOAuthDataModule.WriteString('FromName', edtFromName.Text); - EmailOAuthDataModule.WriteString('Subject', edtSubject.Text); - EmailOAuthDataModule.WriteString('RecipientAddress', edtRecipientAddress.Text); - EmailOAuthDataModule.WriteString('RecipientName', edtRecipientName.Text); -end; - -procedure TForm2.btnSendViaRESTClick(Sender: TObject); -begin - EmailOAuthDataModule.SendEmailUsingREST(edtFromAddress.Text, edtFromName.Text, - edtRecipientAddress.Text, edtRecipientName.Text, - edtSubject.Text, mmoBody.Text, ''); - EmailOAuthDataModule.WriteString('FromName', edtFromName.Text); - EmailOAuthDataModule.WriteString('Subject', edtSubject.Text); - EmailOAuthDataModule.WriteString('RecipientAddress', edtRecipientAddress.Text); - EmailOAuthDataModule.WriteString('RecipientName', edtRecipientName.Text); -end; - -procedure TForm2.btnSendHTMLMsgClick(Sender: TObject); -var - msg, body : string; - InlineImagePaths: array of string; - attachFile: string; -begin - if string(edtRecipientAddress.Text).IsEmpty then - begin - ShowMessage('Recipient Email Address Required'); - Exit; - end; - - msg := '
Hello'; - body := 'Body'; - SetLength(InlineImagePaths, 1); - InlineImagePaths[0] := '..\..\Images\SMTPServiceLogos.png'; - attachFile := '..\..\README.md'; - EmailOAuthDataModule.SendEmailWithAttachment(edtFromAddress.Text, edtFromName.Text, - edtRecipientAddress.Text, edtRecipientName.Text, - edtSubject.Text, body, msg, InlineImagePaths, attachFile); - - EmailOAuthDataModule.WriteString('FromName', edtFromName.Text); - EmailOAuthDataModule.WriteString('Subject', edtSubject.Text); - EmailOAuthDataModule.WriteString('RecipientAddress', edtRecipientAddress.Text); - EmailOAuthDataModule.WriteString('RecipientName', edtRecipientName.Text); -end; - -procedure TForm2.LogMsg(const msg: string); -begin - mmoLogging.Lines.Add(msg); -end; - -procedure TForm2.rgEmailProvidersClick(Sender: TObject); -begin - EmailOAuthDataModule.SelectedProvider := rgEmailProviders.ItemIndex; - EmailOAuthDataModule.Provider := Providers[rgEmailProviders.ItemIndex]; - EmailOAuthDataModule.SetupAuthenticator; - edtFromAddress.Text := EmailOAuthDataModule.SendAddress; - UpdateButtonsEnabled; -end; - -end. +unit Unit2; + +interface + +uses + Winapi.Windows + , Winapi.Messages + , System.SysUtils + , System.Variants + , System.Classes + , Vcl.Graphics + , Vcl.Controls + , Vcl.StdCtrls + , Vcl.Forms + , Vcl.Dialogs + , Vcl.ExtCtrls + , Vcl.ComCtrls + , IdSASL + , IdSASLCollection + , IdExplicitTLSClientServerBase + , EmailOAuthDm + , IdSASL.Oauth.OAuth2Bearer + , IdSASL.Oauth.XOAUTH2 + , Email.Demo.Types + , Globals // rename from globals.sample.pas and update contents if missing + ; + +type + TForm2 = class(TForm) + btnAuthenticate: TButton; + btnSendMsg: TButton; + rgEmailProviders: TRadioGroup; + btnCheckMsg: TButton; + btnClearAuthToken: TButton; + btnCheckIMAP: TButton; + btnSendViaREST: TButton; + PageControl1: TPageControl; + tsEmail: TTabSheet; + lblFrom: TLabel; + lblRecipientAddress: TLabel; + edtFromAddress: TEdit; + lblFromName: TLabel; + edtFromName: TEdit; + lblRecipientName: TLabel; + edtRecipientAddress: TEdit; + edtRecipientName: TEdit; + mmoBody: TMemo; + lblSubject: TLabel; + edtSubject: TEdit; + btnSendHTMLMsg: TButton; + mmoLogging: TMemo; + chkPKCE: TCheckBox; + procedure FormDestroy(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure btnCheckMsgClick(Sender: TObject); + procedure btnClearAuthTokenClick(Sender: TObject); + procedure rgEmailProvidersClick(Sender: TObject); + procedure btnCheckIMAPClick(Sender: TObject); + procedure btnAuthenticateClick(Sender: TObject); + procedure btnSendMsgClick(Sender: TObject); + procedure btnSendViaRESTClick(Sender: TObject); + procedure btnSendHTMLMsgClick(Sender: TObject); + private + { Private declarations } + EmailOAuthDataModule : TEmailOAuthDataModule; + procedure LogMsg(const msg: string); + public + { Public declarations } + procedure UpdateButtonsEnabled; + end; + +var + Form2: TForm2; + +implementation + +{$R *.dfm} + +uses + TaurusTLS; + +const + Providers : array[0..2] of TMailProviderInfo = + ( + ( AuthenticationType : TIdSASLXOAuth; + AuthorizationEndpoint : 'https://accounts.google.com/o/oauth2/auth?access_type=offline'; + AccessTokenEndpoint : 'https://accounts.google.com/o/oauth2/token'; + LogoutEndpoint : 'https://www.google.com/accounts/Logout'; + ClientID : google_clientid; + ClientSecret : google_clientsecret; + Scopes : 'https://mail.google.com/ openid email'; + SmtpHost : 'smtp.gmail.com'; + SmtpPort : 465; + PopHost : 'pop.gmail.com'; + PopPort : 995; + ImapHost : 'imap.gmail.com'; + ImapPort : 143; + AuthName : 'Google'; + TLS : utUseImplicitTLS; + Version : TTaurusTLSSSLVersion.TLSv1_3; + TwoLinePOPFormat: False + ), + ( AuthenticationType : TIdSASLXOAuth; + AuthorizationEndpoint : 'https://login.microsoftonline.com/common/oauth2/v2.0/authorize';//'https://login.live.com/oauth20_authorize.srf'; + AccessTokenEndpoint : 'https://login.microsoftonline.com/common/oauth2/v2.0/token';//'https://login.live.com/oauth20_token.srf'; + LogoutEndpoint : 'https://login.microsoftonline.com/common/oauth2/v2.0/logout'; + ClientID : microsoft_clientid; + ClientSecret : ''; + Scopes : 'https://outlook.office.com/IMAP.AccessAsUser.All https://outlook.office.com/POP.AccessAsUser.All https://outlook.office.com/SMTP.Send offline_access openid email profile'; + //'wl.imap offline_access'; + SmtpHost : 'smtp-mail.outlook.com'; + SmtpPort : 587; + PopHost : 'smtp-mail.outlook.com'; + PopPort : 995; + ImapHost : 'outlook.office365.com'; + ImapPort : 993; + AuthName : 'Microsoft'; + TLS : utUseExplicitTLS; + Version : TTaurusTLSSSLVersion.TLSv1_2; + TwoLinePOPFormat: True + ), + ( AuthenticationType : TIdSASLXOAuth; + AuthorizationEndpoint : 'https://login.live.com/oauth20_authorize.srf'; + AccessTokenEndpoint : 'https://login.live.com/oauth20_token.srf'; + LogoutEndpoint : 'https://login.live.com/logout.srf'; + ClientID : microsoft_clientid; + ClientSecret : ''; + // Scopes : 'https://outlook.office.com/IMAP.AccessAsUser.All https://outlook.office.com/POP.AccessAsUser.All https://outlook.office.com/SMTP.Send offline_access'; + Scopes : 'wl.imap wl.emails wl.offline_access openid email profile'; + SmtpHost : 'smtp-mail.outlook.com'; + SmtpPort : 587; + PopHost : 'outlook.office365.com'; + PopPort : 995; + ImapHost : 'imap-mail.outlook.com'; + ImapPort : 993; + AuthName : 'Hotmail'; + TLS : utUseExplicitTLS; + Version : TTaurusTLSSSLVersion.TLSv1_2; + ) + ); + +procedure TForm2.FormDestroy(Sender: TObject); +begin + FreeAndNil(EmailOAuthDataModule); +end; + +procedure TForm2.FormCreate(Sender: TObject); +begin + EmailOAuthDataModule := TEmailOAuthDataModule.Create(nil); + EmailOAuthDataModule.OnLog := LogMsg; + EmailOAuthDataModule.HWNDHandle := Self.Handle; + EmailOAuthDataModule.AppHandle := Application.Handle; + EmailOAuthDataModule.Provider := Providers[rgEmailProviders.ItemIndex]; + EmailOAuthDataModule.SetupAuthenticator; + edtFromAddress.Text := EmailOAuthDataModule.SendAddress; + edtFromName.Text := EmailOAuthDataModule.ReadString('FromName', ''); + edtSubject.Text := EmailOAuthDataModule.ReadString('Subject', ''); + edtRecipientAddress.Text := EmailOAuthDataModule.ReadString('RecipientAddress', ''); + edtRecipientName.Text := EmailOAuthDataModule.ReadString('RecipientName', ''); + UpdateButtonsEnabled; +end; + + +procedure TForm2.UpdateButtonsEnabled; +begin + btnAuthenticate.Enabled := not EmailOAuthDataModule.HasRefreshToken; + btnClearAuthToken.Enabled := EmailOAuthDataModule.HasRefreshToken; + btnSendViaREST.Enabled := rgEmailProviders.ItemIndex = 1; +end; + +procedure TForm2.btnAuthenticateClick(Sender: TObject); +begin + EmailOAuthDataModule.PKCE := chkPKCE.Checked; + EmailOAuthDataModule.Authenticate; + UpdateButtonsEnabled; +end; + +procedure TForm2.btnCheckIMAPClick(Sender: TObject); +begin + EmailOAuthDataModule.CheckIMAP; +end; + +procedure TForm2.btnCheckMsgClick(Sender: TObject); +begin + EmailOAuthDataModule.CheckPOP; +end; + +procedure TForm2.btnClearAuthTokenClick(Sender: TObject); +begin + EmailOAuthDataModule.ClearAuthentication; + UpdateButtonsEnabled; +end; + +procedure TForm2.btnSendMsgClick(Sender: TObject); +begin + if string(edtRecipientAddress.Text).IsEmpty then + begin + ShowMessage('Recipient Email Address Required'); + Exit; + end; + + EmailOAuthDataModule.SendMessage(edtFromAddress.Text, edtFromName.Text, + edtRecipientAddress.Text, edtRecipientName.Text, + edtSubject.Text, mmoBody.Text, ''); + EmailOAuthDataModule.WriteString('FromName', edtFromName.Text); + EmailOAuthDataModule.WriteString('Subject', edtSubject.Text); + EmailOAuthDataModule.WriteString('RecipientAddress', edtRecipientAddress.Text); + EmailOAuthDataModule.WriteString('RecipientName', edtRecipientName.Text); +end; + +procedure TForm2.btnSendViaRESTClick(Sender: TObject); +begin + EmailOAuthDataModule.SendEmailUsingREST(edtFromAddress.Text, edtFromName.Text, + edtRecipientAddress.Text, edtRecipientName.Text, + edtSubject.Text, mmoBody.Text, ''); + EmailOAuthDataModule.WriteString('FromName', edtFromName.Text); + EmailOAuthDataModule.WriteString('Subject', edtSubject.Text); + EmailOAuthDataModule.WriteString('RecipientAddress', edtRecipientAddress.Text); + EmailOAuthDataModule.WriteString('RecipientName', edtRecipientName.Text); +end; + +procedure TForm2.btnSendHTMLMsgClick(Sender: TObject); +var + msg, body : string; + InlineImagePaths: array of string; + attachFile: string; +begin + if string(edtRecipientAddress.Text).IsEmpty then + begin + ShowMessage('Recipient Email Address Required'); + Exit; + end; + + msg := '
Hello'; + body := 'Body'; + SetLength(InlineImagePaths, 1); + InlineImagePaths[0] := '..\..\Images\SMTPServiceLogos.png'; + attachFile := '..\..\README.md'; + EmailOAuthDataModule.SendEmailWithAttachment(edtFromAddress.Text, edtFromName.Text, + edtRecipientAddress.Text, edtRecipientName.Text, + edtSubject.Text, body, msg, InlineImagePaths, attachFile); + + EmailOAuthDataModule.WriteString('FromName', edtFromName.Text); + EmailOAuthDataModule.WriteString('Subject', edtSubject.Text); + EmailOAuthDataModule.WriteString('RecipientAddress', edtRecipientAddress.Text); + EmailOAuthDataModule.WriteString('RecipientName', edtRecipientName.Text); +end; + +procedure TForm2.LogMsg(const msg: string); +begin + mmoLogging.Lines.Add(msg); +end; + +procedure TForm2.rgEmailProvidersClick(Sender: TObject); +begin + EmailOAuthDataModule.SelectedProvider := rgEmailProviders.ItemIndex; + EmailOAuthDataModule.Provider := Providers[rgEmailProviders.ItemIndex]; + EmailOAuthDataModule.SetupAuthenticator; + edtFromAddress.Text := EmailOAuthDataModule.SendAddress; + UpdateButtonsEnabled; +end; + +end.