BASIC SSPI Schannel TLS example



// This example is a primitive implementation designed as more of a guide than a library to be plugged into an application
// The code that has all the TODO items completed required several major design changes and is available upon request.


' TLSclient.bas - SSPI Schannel gmail TLS connection example 

' TODO:
'  - Remove Global vars
'  - Implement a structure pointer to pass session variables to functions
'  - Replace GOTO statements
'  - Break code into Open() and Close() functions
'  - Handle long messages 
'  - Remove all Print statements
'  - Implement library level error handling
'  - Remove string concatenation in request/response handling
'  - Processing of EXTRA data received during handshake (gmail welcome message for example)


#COMPILE EXE 
#DIM ALL

#INCLUDE "WIN32API.inc"
#INCLUDE "WinTLS.inc" '  Corrected definitions from: WinCrypt.h, WinTrust.h, schannel.h, Security.h & Sspi.h 

GLOBAL hDbg AS LONG   
GLOBAL gpSSPI AS SecurityFunctionTableA PTR
GLOBAL ghMyCertStore AS DWORD ' HCERTSTORE
GLOBAL gSchannelCred AS SCHANNEL_CRED  

    
$DEBUG_FILE       = "SSPI_dbg.txt"
%fVerbose         = 0 
  
$MailHost         = "smtp.gmail.com" ' SMTP Host - alias for gmail-smtp.l.google.com
%TCP_PORT         = 465              ' Gmail  

$sUser            = "" ' if specified, a certificate in "MY" store is searched for

%dwProtocol       = %SP_PROT_TLS1 ' %SP_PROT_PCT1   %SP_PROT_SSL2   %SP_PROT_SSL3   0=default
                  
%aiKeyExch        = 0 ' = default,  %CALG_DH_EPHEM  %CALG_RSA_KEYX
                  
%fUseProxy        = 0 '%FALSE   
$pszProxyServer   = "proxy" 
%iProxyPort       = 80      

       
               
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤                                                                                               
FUNCTION HexDump( nBytes AS DWORD, BYVAL pBytes AS BYTE PTR  ) AS STRING  ' For Debugging
            
  LOCAL i AS LONG 
  LOCAL sRet AS STRING       
   
    FOR i = 0 TO nBytes-1 
      sRet = sRet + HEX$(@pBytes[i], 2) + " " ' Seperate Hex codes with a space 
    NEXT i ' 
         
  FUNCTION = sRet 

END FUNCTION  
        
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤                                                                                               
FUNCTION TextDump( nBytes AS DWORD, BYVAL pBytes AS BYTE PTR  ) AS STRING  ' For Debugging
            
  LOCAL i AS LONG  
  LOCAL sRet AS STRING
                    
    FOR i = 0 TO nBytes-1  
      sRet = sRet + CHR$(@pBytes[i]) ' Seperate Hex codes with a space  
    NEXT i ' 
         
  FUNCTION = sRet 

END FUNCTION  

'****************************************************************************************
FUNCTION DisplayWinVerifyTrustError( Code AS DWORD ) AS STRING   

    SELECT CASE Code
              CASE %CERT_E_UNTRUSTEDROOT          : FUNCTION = "CERT_E_UNTRUSTEDROOT - A certification chain processed correctly but terminated in a root certificate that is not trusted by the trust provider."
              CASE %CERT_E_UNTRUSTEDTESTROOT      : FUNCTION = "CERT_E_UNTRUSTEDTESTROOT - The root certificate is a testing certificate, and policy settings disallow test certificates."
              CASE %CERT_E_CHAINING               : FUNCTION = "CERT_E_CHAINING - A chain of certificates was not correctly created."
              CASE %CERT_E_WRONG_USAGE            : FUNCTION = "CERT_E_WRONG_USAGE - The certificate is not valid for the requested usage."
              CASE %CERT_E_EXPIRED                : FUNCTION = "CERT_E_EXPIRED - A required certificate is not within its validity period."
              CASE %CERT_E_INVALID_NAME           : FUNCTION = "CERT_E_INVALID_NAME - The certificate has an invalid name. Either the name is not included in the permitted list, or it is explicitly excluded."
              CASE %CERT_E_INVALID_POLICY         : FUNCTION = "CERT_E_INVALID_POLICY - The certificate has an invalid policy"
              CASE %CERT_E_CRITICAL               : FUNCTION = "CERT_E_CRITICAL - The certificate is being used for a purpose other than the purpose specified by its CA."
              CASE %CERT_E_VALIDITYPERIODNESTING  : FUNCTION = "CERT_E_VALIDITYPERIODNESTING - The validity periods of the certification chain do not nest correctly."
              CASE %CERT_E_PURPOSE                : FUNCTION = "CERT_E_PURPOSE - The certificate is being used for a purpose other than one specified by the issuing CA."
              CASE %CERT_E_REVOKED                : FUNCTION = "CERT_E_REVOKED - The certificate has been explicitly revoked by the issuer."
              CASE %CERT_E_REVOCATION_FAILURE     : FUNCTION = "CERT_E_REVOCATION_FAILURE - The revocation process could not continue, and the certificate could not be checked."
              CASE %CERT_E_UNTRUSTEDROOT          : FUNCTION = "CERT_E_UNTRUSTEDROOT - A certification chain processed correctly but terminated in a root certificate that is not trusted by the trust provider."
              CASE %CERT_E_CN_NO_MATCH            : FUNCTION = "CERT_E_CN_NO_MATCH - The certificate's CN name does not match the passed value."
              CASE %CERT_E_PURPOSE                : FUNCTION = "CERT_E_PURPOSE - The certificate is being used for a purpose other than the purposes specified by its CA."
              CASE %CERT_E_ROLE                   : FUNCTION = "CERT_E_ROLE - A certificate that can only be used as an end-entity is being used as a CA or vice versa."
              CASE %CERT_E_UNTRUSTEDROOT          : FUNCTION = "CERT_E_UNTRUSTEDROOT - A certification chain processed correctly but terminated in a root certificate that is not trusted by the trust provider."
              CASE %CERT_E_CHAINING               : FUNCTION = "CERT_E_CHAINING - The certificate chain to a trusted root authority could not be built."
              CASE %CERT_E_WRONG_USAGE            : FUNCTION = "CERT_E_WRONG_USAGE - The certificate is not valid for the requested usage."
            CASE %CERT_E_PATHLENCONST           : FUNCTION = "CERT_E_PATHLENCONST - A path length constraint in the certification chain has been violated."  
            CASE %CERT_E_ISSUERCHAINING         : FUNCTION = "CERT_E_ISSUERCHAINING - A parent of a given certificate in fact did not issue that child certificate."  
            CASE %CERT_E_MALFORMED              : FUNCTION = "CERT_E_MALFORMED - A certificate is missing or has an empty value for an important field, such as a subject or issuer name."                                  
            CASE %CERT_E_UNTRUSTEDCA            : FUNCTION = "CERT_E_UNTRUSTEDCA - A certification chain processed correctly, but one of the CA certificates is not trusted by the policy provider."
                 
              CASE %CRYPT_E_REVOKED               : FUNCTION = "CRYPT_E_REVOKED - The certificate or signature has been revoked."      
              CASE %CRYPT_E_NO_REVOCATION_CHECK   : FUNCTION = "CRYPT_E_NO_REVOCATION_CHECK - The revocation function was unable to check revocation for the certificate."
              CASE %CRYPT_E_REVOCATION_OFFLINE    : FUNCTION = "CRYPT_E_REVOCATION_OFFLINE - The revocation function was unable to check revocation because the revocation server was offline."

            CASE %TRUST_E_BAD_DIGEST            : FUNCTION = "TRUST_E_BAD_DIGEST - The digital signature of the object did not verify."
            CASE %TRUST_E_COUNTER_SIGNER        : FUNCTION = "TRUST_E_COUNTER_SIGNER -     One of the counter signatures was not valid."
            CASE %TRUST_E_EXPLICIT_DISTRUST     : FUNCTION = "TRUST_E_EXPLICIT_DISTRUST - The certificate was explicitly marked as untrusted by the user."
            CASE %TRUST_E_FINANCIAL_CRITERIA    : FUNCTION = "TRUST_E_FINANCIAL_CRITERIA - The certificate does not meet or contain the Authenticode financial extensions."
            CASE %TRUST_E_NO_SIGNER_CERT        : FUNCTION = "TRUST_E_NO_SIGNER_CERT - The certificate for the signer of the message is not valid or not found."
            CASE %TRUST_E_SYSTEM_ERROR          : FUNCTION = "TRUST_E_SYSTEM_ERROR - A system-level error occurred while verifying trust."
            CASE %TRUST_E_TIME_STAMP            : FUNCTION = "TRUST_E_TIME_STAMP - The time stamp signature or certificate could not be verified or is malformed."
              CASE %TRUST_E_BASIC_CONSTRAINTS     : FUNCTION = "TRUST_E_BASIC_CONSTRAINTS - The basic constraints of the certificate are not valid, or they are missing."
              CASE %TRUST_E_CERT_SIGNATURE        : FUNCTION = "TRUST_E_CERT_SIGNATURE - The signature of the certificate cannot be verified. "
              CASE %TRUST_E_FAIL                  : FUNCTION = "TRUST_E_FAIL - Generic Trust Failure."
              CASE %TRUST_E_BASIC_CONSTRAINTS     : FUNCTION = "TRUST_E_BASIC_CONSTRAINTS - The basic constraints of the certificate are not valid, or they are missing."

        CASE ELSE                           : FUNCTION = "Certificate verification failure code: 0x" + HEX$(Code)
    END SELECT

END FUNCTION    

'****************************************************************************************
FUNCTION DisplayWinSockError( Code AS DWORD ) AS STRING

    SELECT CASE Code ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms740668(v=vs.85).aspx
              CASE     00006 :  FUNCTION = "WSA_INVALID_HANDLE"
              CASE     00008 :  FUNCTION = "WSA_NOT_ENOUGH_MEMORY"
              CASE     00087 :  FUNCTION = "WSA_INVALID_PARAMETER"
                                   
              CASE     00995 :  FUNCTION = "WSA_OPERATION_ABORTED"
              CASE     00996 :  FUNCTION = "WSA_IO_INCOMPLETE"
              CASE     00997 :  FUNCTION = "WSA_IO_PENDING"
              CASE     10004 :  FUNCTION = "WSAEINTR"
              CASE     10009 :  FUNCTION = "WSAEBADF"
              CASE     10013 :  FUNCTION = "WSAEACCES"
              CASE     10014 :  FUNCTION = "WSAEFAULT"

              CASE     10022 :  FUNCTION = "WSAEINVAL"
              CASE     10024 :  FUNCTION = "WSAEMFILE"

              CASE     10035 :  FUNCTION = "WSAEWOULDBLOCK"
              CASE     10036 :  FUNCTION = "WSAEINPROGRESS"
              CASE     10037 :  FUNCTION = "WSAEALREADY"
              CASE     10038 :  FUNCTION = "WSAENOTSOCK"
              CASE     10039 :  FUNCTION = "WSAEDESTADDRREQ"
              CASE     10040 :  FUNCTION = "WSAEMSGSIZE"
              CASE     10041 :  FUNCTION = "WSAEPROTOTYPE"
              CASE     10042 :  FUNCTION = "WSAENOPROTOOPT"
              CASE     10043 :  FUNCTION = "WSAEPROTONOSUPPORT"
              CASE     10044 :  FUNCTION = "WSAESOCKTNOSUPPORT"
              CASE     10045 :  FUNCTION = "WSAEOPNOTSUPP"
              CASE     10046 :  FUNCTION = "WSAEPFNOSUPPORT"
              CASE     10047 :  FUNCTION = "WSAEAFNOSUPPORT"
              CASE     10048 :  FUNCTION = "WSAEADDRINUSE"
              CASE     10049 :  FUNCTION = "WSAEADDRNOTAVAIL"
              CASE     10050 :  FUNCTION = "WSAENETDOWN"
              CASE     10051 :  FUNCTION = "WSAENETUNREACH"
              CASE     10052 :  FUNCTION = "WSAENETRESET"
              CASE     10053 :  FUNCTION = "WSAECONNABORTED"
              CASE     10054 :  FUNCTION = "WSAECONNRESET"
              CASE     10055 :  FUNCTION = "WSAENOBUFS"
              CASE     10056 :  FUNCTION = "WSAEISCONN"
              CASE     10057 :  FUNCTION = "WSAENOTCONN"
              CASE     10058 :  FUNCTION = "WSAESHUTDOWN"
              CASE     10059 :  FUNCTION = "WSAETOOMANYREFS"
              CASE     10060 :  FUNCTION = "WSAETIMEDOUT"
              CASE     10061 :  FUNCTION = "WSAECONNREFUSED"
              CASE     10062 :  FUNCTION = "WSAELOOP"
              CASE     10063 :  FUNCTION = "WSAENAMETOOLONG"
              CASE     10064 :  FUNCTION = "WSAEHOSTDOWN"
              CASE     10065 :  FUNCTION = "WSAEHOSTUNREACH"
              CASE     10066 :  FUNCTION = "WSAENOTEMPTY"
              CASE     10067 :  FUNCTION = "WSAEPROCLIM"
              CASE     10068 :  FUNCTION = "WSAEUSERS"
              CASE     10069 :  FUNCTION = "WSAEDQUOT"
              CASE     10070 :  FUNCTION = "WSAESTALE"
              CASE     10071 :  FUNCTION = "WSAEREMOTE"

              CASE     10091 :  FUNCTION = "WSASYSNOTREADY"
              CASE     10092 :  FUNCTION = "WSAVERNOTSUPPORTED"
              CASE     10093 :  FUNCTION = "WSANOTINITIALISED"  

              CASE     10101 :  FUNCTION = "WSAEDISCON"
              CASE     10102 :  FUNCTION = "WSAENOMORE"
              CASE     10103 :  FUNCTION = "WSAECANCELLED" 
              CASE     10104 :  FUNCTION = "WSAEINVALIDPROCTABLE"
              CASE     10105 :  FUNCTION = "WSAEINVALIDPROVIDER"
              CASE     10106 :  FUNCTION = "WSAEPROVIDERFAILEDINIT"
              CASE     10107 :  FUNCTION = "WSASYSCALLFAILURE"
              CASE     10108 :  FUNCTION = "WSASERVICE_NOT_FOUND"
              CASE     10109 :  FUNCTION = "WSATYPE_NOT_FOUND"
              CASE     10110 :  FUNCTION = "WSA_E_NO_MORE"
              CASE     10111 :  FUNCTION = "WSA_E_CANCELLED"
              CASE     10112 :  FUNCTION = "WSAEREFUSED"

              CASE     11001 :  FUNCTION = "WSAHOST_NOT_FOUND"
              CASE     11002 :  FUNCTION = "WSATRY_AGAIN"
              CASE     11003 :  FUNCTION = "WSANO_RECOVERY"
              CASE     11004 :  FUNCTION = "WSANO_DATA"
              CASE     11005 :  FUNCTION = "WSA_QOS_RECEIVERS"
              CASE     11006 :  FUNCTION = "WSA_QOS_SENDERS"
              CASE     11007 :  FUNCTION = "WSA_QOS_NO_SENDERS"
              CASE     11008 :  FUNCTION = "WSA_QOS_NO_RECEIVERS"
              CASE     11009 :  FUNCTION = "WSA_QOS_REQUEST_CONFIRMED"
              CASE     11010 :  FUNCTION = "WSA_QOS_ADMISSION_FAILURE"
              CASE     11011 :  FUNCTION = "WSA_QOS_POLICY_FAILURE"
              CASE     11012 :  FUNCTION = "WSA_QOS_BAD_STYLE"
              CASE     11013 :  FUNCTION = "WSA_QOS_BAD_OBJECT"
              CASE     11014 :  FUNCTION = "WSA_QOS_TRAFFIC_CTRL_ERROR"
              CASE     11015 :  FUNCTION = "WSA_QOS_GENERIC_ERROR"
              CASE     11016 :  FUNCTION = "WSA_QOS_ESERVICETYPE"
              CASE     11017 :  FUNCTION = "WSA_QOS_EFLOWSPEC"
              CASE     11018 :  FUNCTION = "WSA_QOS_EPROVSPECBUF"
              CASE     11019 :  FUNCTION = "WSA_QOS_EFILTERSTYLE"
              CASE     11020 :  FUNCTION = "WSA_QOS_EFILTERTYPE"
              CASE     11021 :  FUNCTION = "WSA_QOS_EFILTERCOUNT"
              CASE     11022 :  FUNCTION = "WSA_QOS_EOBJLENGTH"
              CASE     11023 :  FUNCTION = "WSA_QOS_EFLOWCOUNT"
              CASE     11024 :  FUNCTION = "WSA_QOS_EUNKOWNPSOBJ"
              CASE     11025 :  FUNCTION = "WSA_QOS_EPOLICYOBJ"
              CASE     11026 :  FUNCTION = "WSA_QOS_EFLOWDESC"
              CASE     11027 :  FUNCTION = "WSA_QOS_EPSFLOWSPEC"
              CASE     11028 :  FUNCTION = "WSA_QOS_EPSFILTERSPEC"
              CASE     11029 :  FUNCTION = "WSA_QOS_ESDMODEOBJ"
              CASE     11030 :  FUNCTION = "WSA_QOS_ESHAPERATEOBJ"
              CASE     11031 :  FUNCTION = "WSA_QOS_RESERVED_PETYPE"

        CASE  ELSE  :  FUNCTION = "WinSock error code: 0x" + HEX$(Code)
    END SELECT

END FUNCTION

'****************************************************************************************
FUNCTION DisplaySECError( Code AS LONG ) AS STRING

    SELECT CASE Code
      CASE     %SEC_E_WRONG_PRINCIPAL                : FUNCTION = "SEC_E_WRONG_PRINCIPAL - The target principal name is incorrect"
      CASE     %SEC_E_INVALID_HANDLE                 : FUNCTION = "SEC_E_INVALID_HANDLE - The handle specified is invalid"
      CASE     %SEC_E_BUFFER_TOO_SMALL               : FUNCTION = "SEC_E_BUFFER_TOO_SMALL - The message buffer is too small. Used with the Digest SSP."
      CASE     %SEC_E_CRYPTO_SYSTEM_INVALID          : FUNCTION = "SEC_E_CRYPTO_SYSTEM_INVALID - The cipher chosen for the security context is not supported. Used with the Digest SSP."
      CASE     %SEC_E_INCOMPLETE_MESSAGE             : FUNCTION = "%SEC_E_INCOMPLETE_MESSAGE - The data in the input buffer is incomplete. The application needs to read more data from the server and call DecryptMessage (General) again."
      CASE     %SEC_E_INVALID_HANDLE                 : FUNCTION = "SEC_E_INVALID_HANDLE - A context handle that is not valid was specified in the hContext Ptr parameter. Used with the Digest and Schannel SSPs."
      CASE     %SEC_E_INVALID_TOKEN                  : FUNCTION = "SEC_E_INVALID_TOKEN - The buffers are of the wrong type or no buffer of type %SECBUFFER_DATA was found. Used with the Schannel SSP."
      CASE     %SEC_E_MESSAGE_ALTERED                : FUNCTION = "SEC_E_MESSAGE_ALTERED - The message has been altered. Used with the Digest and Schannel SSPs."
      CASE     %SEC_E_OUT_OF_SEQUENCE                : FUNCTION = "SEC_E_OUT_OF_SEQUENCE - The message was not received in the correct sequence."
      CASE     %SEC_E_QOP_NOT_SUPPORTED              : FUNCTION = "SEC_E_QOP_NOT_SUPPORTED - Neither confidentiality nor integrity are supported by the security context. Used with the Digest SSP."
      CASE     %SEC_I_CONTEXT_EXPIRED                : FUNCTION = "%SEC_I_CONTEXT_EXPIRED - The message sender has finished using the connection and has initiated a shutdown."
      CASE     %SEC_I_RENEGOTIATE                    : FUNCTION = "%SEC_I_RENEGOTIATE - The remote party requires a new handshake sequence or the application has just initiated a shutdown."
      CASE     %SEC_E_ENCRYPT_FAILURE                : FUNCTION = "SEC_E_ENCRYPT_FAILURE - The specified data could not be encrypted."
      CASE     %SEC_E_DECRYPT_FAILURE                : FUNCTION = "SEC_E_DECRYPT_FAILURE - The specified data could not be decrypted."
      CASE  %SEC_E_NO_SPM                         : FUNCTION = "SEC_E_INTERNAL_ERROR"
      CASE  %SEC_E_NOT_SUPPORTED                  : FUNCTION = "SEC_E_UNSUPPORTED_FUNCTION"
      CASE  %SEC_E_OK                             : FUNCTION = "SEC_E_OK"
      CASE  %SEC_E_INSUFFICIENT_MEMORY            : FUNCTION = "SEC_E_INSUFFICIENT_MEMORY"
      CASE  %SEC_E_INVALID_HANDLE                 : FUNCTION = "SEC_E_INVALID_HANDLE"
      CASE  %SEC_E_UNSUPPORTED_FUNCTION           : FUNCTION = "SEC_E_UNSUPPORTED_FUNCTION"
      CASE  %SEC_E_TARGET_UNKNOWN                 : FUNCTION = "SEC_E_TARGET_UNKNOWN      "
      CASE  %SEC_E_INTERNAL_ERROR                 : FUNCTION = "SEC_E_INTERNAL_ERROR      "
      CASE  %SEC_E_SECPKG_NOT_FOUND               : FUNCTION = "SEC_E_SECPKG_NOT_FOUND    "
      CASE  %SEC_E_NOT_OWNER                      : FUNCTION = "SEC_E_NOT_OWNER           "
      CASE  %SEC_E_CANNOT_INSTALL                 : FUNCTION = "SEC_E_CANNOT_INSTALL      "
      CASE  %SEC_E_INVALID_TOKEN                  : FUNCTION = "SEC_E_INVALID_TOKEN       "
      CASE  %SEC_E_CANNOT_PACK                    : FUNCTION = "SEC_E_CANNOT_PACK         "
      CASE  %SEC_E_QOP_NOT_SUPPORTED              : FUNCTION = "SEC_E_QOP_NOT_SUPPORTED   "
      CASE  %SEC_E_NO_IMPERSONATION               : FUNCTION = "SEC_E_NO_IMPERSONATION    "
      CASE  %SEC_E_LOGON_DENIED                   : FUNCTION = "SEC_E_LOGON_DENIED        "
      CASE  %SEC_E_UNKNOWN_CREDENTIALS            : FUNCTION = "SEC_E_UNKNOWN_CREDENTIALS "
      CASE  %SEC_E_NO_CREDENTIALS                 : FUNCTION = "SEC_E_NO_CREDENTIALS      "
      CASE  %SEC_E_MESSAGE_ALTERED                : FUNCTION = "SEC_E_MESSAGE_ALTERED     "
      CASE  %SEC_E_OUT_OF_SEQUENCE                : FUNCTION = "SEC_E_OUT_OF_SEQUENCE     "
      CASE  %SEC_E_NO_AUTHENTICATING_AUTHORITY    : FUNCTION = "SEC_E_NO_AUTHENTICATING_AUTHORITY"
      CASE  %SEC_I_CONTINUE_NEEDED                : FUNCTION = "SEC_I_CONTINUE_NEEDED       "
      CASE  %SEC_I_COMPLETE_NEEDED                : FUNCTION = "SEC_I_COMPLETE_NEEDED       "
      CASE  %SEC_I_COMPLETE_AND_CONTINUE          : FUNCTION = "SEC_I_COMPLETE_AND_CONTINUE "
      CASE  %SEC_I_LOCAL_LOGON                    : FUNCTION = "SEC_I_LOCAL_LOGON           "
      CASE  %SEC_E_BAD_PKGID                      : FUNCTION = "SEC_E_BAD_PKGID             "
      CASE  %SEC_E_CONTEXT_EXPIRED                : FUNCTION = "SEC_E_CONTEXT_EXPIRED       "
      CASE  %SEC_E_INCOMPLETE_CREDENTIALS         : FUNCTION = "SEC_E_INCOMPLETE_CREDENTIALS"
      CASE  %SEC_E_BUFFER_TOO_SMALL               : FUNCTION = "SEC_E_BUFFER_TOO_SMALL      "
      CASE  %SEC_I_INCOMPLETE_CREDENTIALS         : FUNCTION = "SEC_I_INCOMPLETE_CREDENTIALS"
      CASE  %SEC_I_RENEGOTIATE                    : FUNCTION = "SEC_I_RENEGOTIATE           "
      CASE  %SEC_E_WRONG_PRINCIPAL                : FUNCTION = "SEC_E_WRONG_PRINCIPAL       "
      CASE  %SEC_E_INSUFFICIENT_MEMORY            : FUNCTION = "SEC_E_INSUFFICIENT_MEMORY "
      CASE  %SEC_E_INVALID_HANDLE                 : FUNCTION = "SEC_E_INVALID_HANDLE      "
      CASE  %SEC_E_UNSUPPORTED_FUNCTION           : FUNCTION = "SEC_E_UNSUPPORTED_FUNCTION"
      CASE  %SEC_E_TARGET_UNKNOWN                 : FUNCTION = "SEC_E_TARGET_UNKNOWN      "
      CASE  %SEC_E_INTERNAL_ERROR                 : FUNCTION = "SEC_E_INTERNAL_ERROR      "
      CASE  %SEC_E_SECPKG_NOT_FOUND               : FUNCTION = "SEC_E_SECPKG_NOT_FOUND    "
      CASE  %SEC_E_NOT_OWNER                      : FUNCTION = "SEC_E_NOT_OWNER           "
      CASE  %SEC_E_CANNOT_INSTALL                 : FUNCTION = "SEC_E_CANNOT_INSTALL      "
      CASE  %SEC_E_INVALID_TOKEN                  : FUNCTION = "SEC_E_INVALID_TOKEN       "
      CASE  %SEC_E_CANNOT_PACK                    : FUNCTION = "SEC_E_CANNOT_PACK         "
      CASE  %SEC_E_QOP_NOT_SUPPORTED              : FUNCTION = "SEC_E_QOP_NOT_SUPPORTED   "
      CASE  %SEC_E_NO_IMPERSONATION               : FUNCTION = "SEC_E_NO_IMPERSONATION    "
      CASE  %SEC_E_LOGON_DENIED                   : FUNCTION = "SEC_E_LOGON_DENIED        "
      CASE  %SEC_E_UNKNOWN_CREDENTIALS            : FUNCTION = "SEC_E_UNKNOWN_CREDENTIALS "
      CASE  %SEC_E_NO_CREDENTIALS                 : FUNCTION = "SEC_E_NO_CREDENTIALS      "
      CASE  %SEC_E_MESSAGE_ALTERED                : FUNCTION = "SEC_E_MESSAGE_ALTERED     "
      CASE  %SEC_E_OUT_OF_SEQUENCE                : FUNCTION = "SEC_E_OUT_OF_SEQUENCE     "
      CASE  %SEC_E_NO_AUTHENTICATING_AUTHORITY    : FUNCTION = "SEC_E_NO_AUTHENTICATING_AUTHORITY"
      CASE  %SEC_I_CONTINUE_NEEDED                : FUNCTION = "SEC_I_CONTINUE_NEEDED       "
      CASE  %SEC_I_COMPLETE_NEEDED                : FUNCTION = "SEC_I_COMPLETE_NEEDED       "
      CASE  %SEC_I_COMPLETE_AND_CONTINUE          : FUNCTION = "SEC_I_COMPLETE_AND_CONTINUE "
      CASE  %SEC_I_LOCAL_LOGON                    : FUNCTION = "SEC_I_LOCAL_LOGON           "
      CASE  %SEC_E_BAD_PKGID                      : FUNCTION = "SEC_E_BAD_PKGID             "
      CASE  %SEC_E_CONTEXT_EXPIRED                : FUNCTION = "SEC_E_CONTEXT_EXPIRED       "
      CASE  %SEC_I_CONTEXT_EXPIRED                : FUNCTION = "SEC_I_CONTEXT_EXPIRED       "
      CASE  %SEC_E_INCOMPLETE_CREDENTIALS         : FUNCTION = "SEC_E_INCOMPLETE_CREDENTIALS"
      CASE  %SEC_E_BUFFER_TOO_SMALL               : FUNCTION = "SEC_E_BUFFER_TOO_SMALL      "
      CASE  %SEC_I_INCOMPLETE_CREDENTIALS         : FUNCTION = "SEC_I_INCOMPLETE_CREDENTIALS"
      CASE  %SEC_I_RENEGOTIATE                    : FUNCTION = "SEC_I_RENEGOTIATE           "
      CASE  %SEC_E_WRONG_PRINCIPAL                : FUNCTION = "SEC_E_WRONG_PRINCIPAL       "
      CASE  %SEC_I_NO_LSA_CONTEXT                 : FUNCTION = "SEC_I_NO_LSA_CONTEXT        "
      CASE  %SEC_E_TIME_SKEW                      : FUNCTION = "SEC_E_TIME_SKEW             "
      CASE  %SEC_E_UNTRUSTED_ROOT                 : FUNCTION = "SEC_E_UNTRUSTED_ROOT        "
      CASE  %SEC_E_ILLEGAL_MESSAGE                : FUNCTION = "SEC_E_ILLEGAL_MESSAGE       "
      CASE  %SEC_E_CERT_UNKNOWN                   : FUNCTION = "SEC_E_CERT_UNKNOWN          "
      CASE  %SEC_E_CERT_EXPIRED                   : FUNCTION = "SEC_E_CERT_EXPIRED          "
      CASE  %SEC_E_ENCRYPT_FAILURE                : FUNCTION = "SEC_E_ENCRYPT_FAILURE       "
      CASE  %SEC_E_DECRYPT_FAILURE                : FUNCTION = "SEC_E_DECRYPT_FAILURE       "
      CASE  %SEC_E_ALGORITHM_MISMATCH             : FUNCTION = "SEC_E_ALGORITHM_MISMATCH    "
      CASE  %SEC_E_SECURITY_QOS_FAILED            : FUNCTION = "SEC_E_SECURITY_QOS_FAILED   "
      CASE  %SEC_E_UNFINISHED_CONTEXT_DELETED     : FUNCTION = "SEC_E_UNFINISHED_CONTEXT_DELETED"
      CASE  %SEC_E_NO_TGT_REPLY                   : FUNCTION = "SEC_E_NO_TGT_REPLY           "
      CASE  %SEC_E_NO_IP_ADDRESSES                : FUNCTION = "SEC_E_NO_IP_ADDRESSES        "
      CASE  %SEC_E_WRONG_CREDENTIAL_HANDLE        : FUNCTION = "SEC_E_WRONG_CREDENTIAL_HANDLE"
      CASE  %SEC_E_CRYPTO_SYSTEM_INVALID          : FUNCTION = "SEC_E_CRYPTO_SYSTEM_INVALID  "
      CASE  %SEC_E_MAX_REFERRALS_EXCEEDED         : FUNCTION = "SEC_E_MAX_REFERRALS_EXCEEDED "
      CASE  %SEC_E_MUST_BE_KDC                    : FUNCTION = "SEC_E_MUST_BE_KDC            "
      CASE  %SEC_E_STRONG_CRYPTO_NOT_SUPPORTED    : FUNCTION = "SEC_E_STRONG_CRYPTO_NOT_SUPPORTED"
      CASE  %SEC_E_TOO_MANY_PRINCIPALS            : FUNCTION = "SEC_E_TOO_MANY_PRINCIPALS     "
      CASE  %SEC_E_NO_PA_DATA                     : FUNCTION = "SEC_E_NO_PA_DATA              "
      CASE  %SEC_E_PKINIT_NAME_MISMATCH           : FUNCTION = "SEC_E_PKINIT_NAME_MISMATCH    "
      CASE  %SEC_E_SMARTCARD_LOGON_REQUIRED       : FUNCTION = "SEC_E_SMARTCARD_LOGON_REQUIRED"
      CASE  %SEC_E_SHUTDOWN_IN_PROGRESS           : FUNCTION = "SEC_E_SHUTDOWN_IN_PROGRESS"
      CASE  %SEC_E_KDC_INVALID_REQUEST            : FUNCTION = "SEC_E_KDC_INVALID_REQUEST "
      CASE  %SEC_E_KDC_UNABLE_TO_REFER            : FUNCTION = "SEC_E_KDC_UNABLE_TO_REFER "
      CASE  %SEC_E_KDC_UNKNOWN_ETYPE              : FUNCTION = "SEC_E_KDC_UNKNOWN_ETYPE   "
      CASE  %SEC_E_UNSUPPORTED_PREAUTH            : FUNCTION = "SEC_E_UNSUPPORTED_PREAUTH "
      CASE  %SEC_E_DELEGATION_REQUIRED            : FUNCTION = "SEC_E_DELEGATION_REQUIRED "
      CASE  %SEC_E_BAD_BINDINGS                   : FUNCTION = "SEC_E_BAD_BINDINGS        "
      CASE  %SEC_E_MULTIPLE_ACCOUNTS              : FUNCTION = "SEC_E_MULTIPLE_ACCOUNTS   "
      CASE  %SEC_E_NO_KERB_KEY                    : FUNCTION = "SEC_E_NO_KERB_KEY         "
      CASE  %SEC_E_CERT_WRONG_USAGE               : FUNCTION = "SEC_E_CERT_WRONG_USAGE    "
      CASE  %SEC_E_DOWNGRADE_DETECTED             : FUNCTION = "SEC_E_DOWNGRADE_DETECTED  "
      CASE  %SEC_E_SMARTCARD_CERT_REVOKED         : FUNCTION = "SEC_E_SMARTCARD_CERT_REVOKED"
      CASE  %SEC_E_ISSUING_CA_UNTRUSTED           : FUNCTION = "SEC_E_ISSUING_CA_UNTRUSTED  "
      CASE  %SEC_E_REVOCATION_OFFLINE_C           : FUNCTION = "SEC_E_REVOCATION_OFFLINE_C  "
      CASE  %SEC_E_PKINIT_CLIENT_FAILURE          : FUNCTION = "SEC_E_PKINIT_CLIENT_FAILURE "
      CASE  %SEC_E_SMARTCARD_CERT_EXPIRED         : FUNCTION = "SEC_E_SMARTCARD_CERT_EXPIRED"
      CASE  %SEC_E_NO_S4U_PROT_SUPPORT            : FUNCTION = "SEC_E_NO_S4U_PROT_SUPPORT   "
      CASE  %SEC_E_CROSSREALM_DELEGATION_FAILURE  : FUNCTION = "SEC_E_CROSSREALM_DELEGATION_FAILURE" 

      CASE  %SEC_WINNT_AUTH_IDENTITY_ANSI         : FUNCTION = "SEC_WINNT_AUTH_IDENTITY_ANSI"
      CASE  %SEC_WINNT_AUTH_IDENTITY_UNICODE      : FUNCTION = "SEC_WINNT_AUTH_IDENTITY_UNICODE"
      
      CASE  %SECPKG_CRED_OUTBOUND                 : FUNCTION = "SECPKG_CRED_OUTBOUND"
      CASE  %SECPKG_CRED_INBOUND                  : FUNCTION = "SECPKG_CRED_INBOUND "

      CASE ELSE                                   : FUNCTION = "SEC error code:" + STR$(Code) + ", 0x" + HEX$(Code)
    END SELECT

END FUNCTION

'*****************************************************************************/
FUNCTION DisplayCertChain( BYVAL pServerCert AS CERT_CONTEXT PTR, fLocal AS LONG ) AS LONG ' pCERT_CONTEXT  pServerCert, BOOL fLocal )
               
  LOCAL dwVerificationFlags, dwRet AS DWORD ' 
  LOCAL szName AS ASCIIZ * 1000
  LOCAL pCurrentCert, pIssuerCert AS CERT_CONTEXT PTR ' pCERT_CONTEXT
  LOCAL PrevIssuerContext AS CERT_CONTEXT
                   

    PRINT #hDbg, ""
                     
    '- PRINT #hDbg, "Display leaf name"  
    dwRet = CertNameToStr( @pServerCert.dwCertEncodingType, _                    ' in DWORD dwCertEncodingType    
  VARPTR(@pServerCert.@pCertInfo.Subject), _            ' in PCERT_NAME_BLOB pName       
                    %CERT_X500_NAME_STR OR %CERT_NAME_STR_NO_PLUS_FLAG, _ ' in DWORD dwStrType             
  szName, _                                             ' out_opt LPSTR psz              
                           SIZEOF(szName) )                                      ' in DWORD csz  

    IF dwRet = 0 THEN                                   
      PRINT #hDbg, "**** Error: " + STR$(GetLastError()) +  " building leaf subject name"                             
    END IF   

    IF fLocal THEN 
      PRINT #hDbg, "Client subject:" + TRIM$(szName)
    ELSE
      PRINT #hDbg, "Server subject:" + TRIM$(szName) 
    END IF

          
                   
    dwRet = CertNameToStr( @pServerCert.dwCertEncodingType, _                    ' in DWORD dwCertEncodingType    
  VARPTR(@pServerCert.@pCertInfo.Issuer), _             ' __in PCERT_NAME_BLOB pName       
                    %CERT_X500_NAME_STR OR %CERT_NAME_STR_NO_PLUS_FLAG, _ ' in DWORD dwStrType             
  szName, _                                             ' out_opt LPSTR psz              
                           SIZEOF(szName) )                                      ' in DWORD csz  

    IF dwRet = 0 THEN   
      PRINT #hDbg, "**** Error: " + STR$(GetLastError()) +  " building leaf issuer name" 
    END IF
    IF fLocal THEN 
      PRINT #hDbg, "Client issuer:" + TRIM$(szName)
    ELSE
      PRINT #hDbg, "Server issuer:" + TRIM$(szName)
    END IF


    '- PRINT #hDbg, "Display certificate chain"
    pCurrentCert = pServerCert  
    WHILE( pCurrentCert <> %NULL )
        dwVerificationFlags = 0
        pIssuerCert = CertGetIssuerCertificateFromStore( @pServerCert.hCertStore, _ ' in HCERTSTORE hCertStore                  
                                                         pCurrentCert, _            ' in pCERT_CONTEXT pSubjectContext         
                                                         %NULL, _                   ' in_opt pCERT_CONTEXT pPrevIssuerContext  
                                                         dwVerificationFlags )      ' in_out DWORD *pdwFlags 
 
        IF pIssuerCert = %NULL THEN ' No Certificates to display - jump out 
            PRINT #hDbg, "No certificates to display" 
            IF pCurrentCert <> pServerCert THEN CertFreeCertificateContext(@pCurrentCert) ' CERT_CONTEXT
            EXIT LOOP
        END IF ' 
                   

        dwRet = CertNameToStr( @pIssuerCert.dwCertEncodingType, _                    ' in DWORD dwCertEncodingType  
  VARPTR(@pIssuerCert.@pCertInfo.Subject), _            ' in PCERT_NAME_BLOB pName     
  %CERT_X500_NAME_STR OR %CERT_NAME_STR_NO_PLUS_FLAG, _ ' in DWORD dwStrType           
  szName, _                                             ' out_opt LPSTR psz            
                               SIZEOF(szName) )                                      ' in DWORD csz  

        IF dwRet = 0 THEN  
          PRINT #hDbg, "**** Error: " + STR$(GetLastError()) +  " building cert subject name" 
        END IF      
        PRINT #hDbg, "CA subject: " + TRIM$(szName)


                         
        dwRet = CertNameToStr( @pIssuerCert.dwCertEncodingType, _                    ' in DWORD dwCertEncodingType  
  VARPTR(@pIssuerCert.@pCertInfo.Issuer), _             ' in PCERT_NAME_BLOB pName     
  %CERT_X500_NAME_STR OR %CERT_NAME_STR_NO_PLUS_FLAG, _ ' in DWORD dwStrType           
  szName, _                                             ' out_opt LPSTR psz            
                               SIZEOF(szName) )                                      ' in DWORD csz 

        IF dwRet = 0 THEN  
          PRINT #hDbg, "**** Error: " + STR$(GetLastError()) +  " building cert Issuer name" 
        END IF
        PRINT #hDbg, "CA issuer: " + TRIM$(szName)
                         

        IF pCurrentCert <> pServerCert THEN CertFreeCertificateContext(@pCurrentCert) ' CERT_CONTEXT
        pCurrentCert = pIssuerCert
        pIssuerCert  = %NULL
    WEND

END FUNCTION


'*****************************************************************************/
FUNCTION DisplayConnectionInfo( BYVAL phContext AS CtxtHandle PTR ) AS LONG ' CtxtHandle *phContext
                      
  LOCAL SecStatus AS LONG ' SECURITY_STATUS
  LOCAL ConnectionInfo AS SecPkgContext_ConnectionInfo  
               
    
    PRINT #hDbg, ""

    CALL DWORD @gpSSPI.QueryContextAttributesA USING QueryContextAttributes( _
                phContext, _                    ' PCtxtHandle phContext      // Context to query      
                %SECPKG_ATTR_CONNECTION_INFO, _ ' unsigned long ulAttribute  // Attribute to query    
                VARPTR(ConnectionInfo) ) _      ' void SEC_FAR * pBuffer     // Buffer for attributes
                TO SecStatus 

    IF SecStatus <> %SEC_E_OK THEN 
      PRINT #hDbg, "Error querying connection info" + STR$(SecStatus) 
      EXIT FUNCTION     
    END IF

    SELECT CASE ConnectionInfo.dwProtocol
        CASE %SP_PROT_TLS1_CLIENT:  PRINT #hDbg, "Protocol: TLS1"
        CASE %SP_PROT_SSL3_CLIENT:  PRINT #hDbg, "Protocol: SSL3"
        CASE %SP_PROT_PCT1_CLIENT:  PRINT #hDbg, "Protocol: PCT"
        CASE %SP_PROT_SSL2_CLIENT:  PRINT #hDbg, "Protocol: SSL2"
        CASE ELSE:                  PRINT #hDbg, "Protocol:" +STR$(ConnectionInfo.dwProtocol)
    END SELECT
            

    SELECT CASE ConnectionInfo.aiCipher
        CASE %CALG_RC4:                   PRINT #hDbg, "Cipher: RC4"
        CASE %CALG_3DES:                  PRINT #hDbg, "Cipher: Triple DES"
        CASE %CALG_RC2:                   PRINT #hDbg, "Cipher: RC2"
        CASE %CALG_DES, %CALG_CYLINK_MEK: PRINT #hDbg, "Cipher: DES"
        CASE %CALG_SKIPJACK:              PRINT #hDbg, "Cipher: Skipjack"
        CASE ELSE:                        PRINT #hDbg, "Cipher:" + STR$(ConnectionInfo.aiCipher)
    END SELECT
    PRINT #hDbg, "Cipher strength:" + STR$(ConnectionInfo.dwCipherStrength)
               

    SELECT CASE ConnectionInfo.aiHash
        CASE %CALG_MD5: PRINT #hDbg, "Hash: MD5"
        CASE %CALG_SHA: PRINT #hDbg, "Hash: SHA"
        CASE ELSE:      PRINT #hDbg, "Hash:" + STR$(ConnectionInfo.aiHash)
    END SELECT
    PRINT #hDbg, "Hash strength:" + STR$(ConnectionInfo.dwHashStrength)
       

    SELECT CASE ConnectionInfo.aiExch
        CASE %CALG_RSA_KEYX, %CALG_RSA_SIGN:  PRINT #hDbg, "Key exchange: RSA"
        CASE %CALG_KEA_KEYX:                  PRINT #hDbg, "Key exchange: KEA"
        CASE %CALG_DH_EPHEM:                  PRINT #hDbg, "Key exchange: DH Ephemeral"
        CASE ELSE:                            PRINT #hDbg, "Key exchange:" + STR$(ConnectionInfo.aiExch)
    END SELECT
    PRINT #hDbg, "Key exchange strength:"+ STR$(ConnectionInfo.dwExchStrength)       

END FUNCTION

'/*****************************************************************************/
FUNCTION UnloadSecurityLibrary( hSecurity AS DWORD ) AS LONG 

    CALL FreeLibrary( hSecurity ) ' hLibModule AS DWORD
    hSecurity = 0   

END FUNCTION
         

'/*****************************************************************************/
FUNCTION VerifyServerCertificate( BYVAL pServerCert AS CERT_CONTEXT PTR, pszServerName AS ASCIIZ, dwCertFlags AS DWORD ) AS LONG
                 
  LOCAL RetVal AS LONG
  LOCAL cUsages, SecStatus, dwID AS DWORD  
  LOCAL sTemp AS STRING
  LOCAL rgszUsages() AS ASCIIZ * 64       

  LOCAL polHttps       AS HTTPSPolicyCallbackData  
  LOCAL PolicyPara     AS CERT_CHAIN_POLICY_PARA   
  LOCAL PolicyStatus   AS CERT_CHAIN_POLICY_STATUS 
  LOCAL ChainPara      AS CERT_CHAIN_PARA          
  LOCAL pChainContext  AS CERT_CHAIN_CONTEXT PTR      

            

    IF pServerCert = 0        THEN SecStatus = %SEC_E_WRONG_PRINCIPAL : GOTO cleanup
    IF LEN(pszServerName) = 0 THEN SecStatus = %SEC_E_WRONG_PRINCIPAL : GOTO cleanup 
      
                            
    cUsages = 3 ' SIZEOF(rgszUsages) / SIZEOF(LPSTR)
    DIM rgszUsages(cUsages-1)
    rgszUsages(0) = $szOID_PKIX_KP_SERVER_AUTH ' "1.3.6.1.5.5.7.3.1"
    rgszUsages(1) = $szOID_SERVER_GATED_CRYPTO ' "1.3.6.1.4.1.311.10.3.3"
    rgszUsages(2) = $szOID_SGC_NETSCAPE        ' "2.16.840.1.113730.4.1" 
                 
    LOCAL OID() AS DWORD  
    DIM OID(cUsages-1) 
    OID(0) = VARPTR( rgszUsages(0) )
    OID(1) = VARPTR( rgszUsages(1) )
    OID(2) = VARPTR( rgszUsages(2) )

    '- Build certificate chain.
    ChainPara.cbSize                                    = SIZEOF(ChainPara)
    ChainPara.RequestedUsage.dwType                     = %USAGE_MATCH_TYPE_OR
    ChainPara.RequestedUsage.Usage.cUsageIdentifier     = cUsages 
    ChainPara.RequestedUsage.Usage.rgpszUsageIdentifier = VARPTR(OID(0)) ' Array of pointers  

    ' http://msdn.microsoft.com/en-us/library/ms937660.aspx                     
    RetVal = CertGetCertificateChain( %NULL, _                   ' in_opt hChainEngine       
   pServerCert, _             ' in     pCertContext             
   %NULL, _                   ' in_opt pTime                    
   @pServerCert.hCertStore, _ ' in_opt hAdditionalStore         
   VARPTR(ChainPara), _       ' in     pChainPara             
   0, _                       ' in     dwFlags                           
   %NULL, _                   ' in     pvReserved                       
   VARPTR(pChainContext) )    ' out    ppChainContext  

    IF RetVal = 0 THEN                                                            
      SecStatus = GetLastError()
      PRINT #hDbg, "**** Error:" + STR$(SecStatus) + " returned by CertGetCertificateChain"
      GOTO cleanup
    END IF
        

    '- Validate certificate chain.
    polHttps.cbStruct             = SIZEOF(HTTPSPolicyCallbackData)
    polHttps.dwAuthType           = %AUTHTYPE_SERVER
    polHttps.fdwChecks            = dwCertFlags ' PRINT #hDbg, "pwszServerName>"+ pszServerName + "<"

    sTemp = UCODE$( TRIM$(pszServerName) ) ' Convert to Unicode Wide
    polHttps.pwszServerName       = STRPTR(sTemp) ' PRINT #hDbg, "pwszServerName="+ sTemp ' Convert to Unicode Wide

    PolicyPara.cbSize             = SIZEOF(PolicyPara)
    PolicyPara.pvExtraPolicyPara  = VARPTR(polHttps)

    PolicyStatus.cbSize           = SIZEOF(PolicyStatus)
                                                                                 
    dwID   = %CERT_CHAIN_POLICY_SSL ' cookie/handle/ID
    RetVal = CertVerifyCertificateChainPolicy( dwID, _            ' in DWORD ID value                         
  @pChainContext, _  ' in PCCERT_CHAIN_CONTEXT pChainContext           
  PolicyPara, _      ' in PCERT_CHAIN_POLICY_PARA pPolicyPara          
  PolicyStatus )     ' in_out PCERT_CHAIN_POLICY_STATUS pPolicyStatus  

    IF RetVal = 0 THEN
      SecStatus = GetLastError() 
      PRINT #hDbg, "**** Error:" + STR$(SecStatus) + " returned by CertVerifyCertificateChainPolicy"
      GOTO cleanup
    END IF ' PRINT #hDbg, "PolicyStatus.dwError="+ STR$(PolicyStatus.dwError)         

    IF PolicyStatus.dwError THEN
      SecStatus = PolicyStatus.dwError  
      PRINT #hDbg, "**** Error:" + STR$(SecStatus) + " returned by PolicyStatus"
      DisplayWinVerifyTrustError(SecStatus) 
      GOTO cleanup
    END IF

    SecStatus = %SEC_E_OK ' 

cleanup:
    IF pChainContext  THEN CertFreeCertificateChain(@pChainContext)

  FUNCTION = SecStatus ' PRINT #hDbg, "SecStatus="+ STR$(SecStatus)   

END FUNCTION


'/*****************************************************************************/
FUNCTION CreateCredentials( sUser AS STRING, BYVAL phCreds AS CredHandle PTR ) AS LONG   
'                             IN                      OUT   

  LOCAL cSupportedAlgs AS DWORD 
  LOCAL rgbSupportedAlgs() AS DWORD ' ALG_ID 
  LOCAL tsExpiry  AS QUAD ' TimeStamp        
  LOCAL SecStatus AS LONG ' SECURITY_STATUS 
  LOCAL pszPackage AS ASCIIZ * 64 ' "Microsoft Unified Security Protocol Provider" 
  LOCAL pszPrincipal AS ASCIIZ * 16 ' 
  LOCAL pszUser AS ASCIIZ * 255        
  LOCAL pCertContext AS CERT_CONTEXT PTR    
          
                    
    pszUser = sUser
    DIM rgbSupportedAlgs(16)
             

    '- OPEN the "MY" certificate store, where IE stores CLIENT certificates.
    IF ghMyCertStore = 0 THEN
      ghMyCertStore = CertOpenSystemStore(0, "MY") ' Windows maintains 4 stores -- MY, CA, ROOT, SPC. 
      IF ghMyCertStore = 0 THEN   
        PRINT #hDbg, "**** Error:" + STR$(GetLastError()) + " returned by CertOpenSystemStore"
        FUNCTION = %SEC_E_NO_CREDENTIALS   
        EXIT FUNCTION
      END IF
    END IF ' PRINT #hDbg, "ghMyCertStore=" + STR$(ghMyCertStore)


    '- If user name is specified, attempt to find a CLIENT certificate. Otherwise, just create a NULL credential.
    IF LEN(pszUser) THEN
        '  Find CLIENT certificate. Note that this sample just searches for a certificate that contains
        '  the user name somewhere in the subject name. A real application should be a bit less casual.
        pCertContext = CertFindCertificateInStore( ghMyCertStore, _    '  hCertStore
                                                   %X509_ASN_ENCODING, _  '  dwCertEncodingType
                                                   0, _    '  dwFindFlags
                                                   %CERT_FIND_SUBJECT_STR_A, _  '  dwFindType
                                                   pszUser, _        ' *pvFindPara
                                                   BYVAL %NULL ) '  pPrevCertContext
        IF pCertContext = 0 THEN ' 
          PRINT #hDbg, "**** Error:" + STR$(GetLastError()) + " returned by CertFindCertificateInStore"
IF  GetLastError() = %CRYPT_E_NOT_FOUND THEN PRINT #hDbg, "%CRYPT_E_NOT_FOUND - property doesn't exist"
          FUNCTION = %SEC_E_NO_CREDENTIALS   
          EXIT FUNCTION
        END IF
    END IF 


    '- Build Schannel credential structure. Currently, this sample only specifies the protocol to be used  
    '  (and optionally the certificate). Real applications may wish to specify other parameters as well.
    gSchannelCred.dwVersion = %SCHANNEL_CRED_VERSION
    IF pCertContext THEN
      gSchannelCred.cCreds = 1
      gSchannelCred.paCred = pCertContext
    END IF 

    gSchannelCred.grbitEnabledProtocols = %dwProtocol

    IF %aiKeyExch THEN    
      INCR cSupportedAlgs
      rgbSupportedAlgs(cSupportedAlgs) = %aiKeyExch  
    END IF 

    IF cSupportedAlgs THEN
      gSchannelCred.cSupportedAlgs    = cSupportedAlgs
      gSchannelCred.palgSupportedAlgs = VARPTR(rgbSupportedAlgs(0)) ' May need to make this 1
    END IF ' 

    gSchannelCred.dwFlags = gSchannelCred.dwFlags OR %SCH_CRED_NO_DEFAULT_CREDS 

    '  The SCH_CRED_MANUAL_CRED_VALIDATION flag is specified because
    '  this sample verifies the SERVER certificate manually. 
    '  Applications that expect TO run ON WinNT, Win9x, OR WinME 
    '  should specify this flag AND also manually VERIFY the SERVER
    '  certificate. Applications running ON newer versions OF Windows can
    '  leave OFF this flag, IN which CASE the Initialize Security Context
    '  FUNCTION will validate the SERVER certificate automatically.
    gSchannelCred.dwFlags = gSchannelCred.dwFlags OR %SCH_CRED_MANUAL_CRED_VALIDATION ' 


    '- Create an SSPI credential. 
    pszPackage = $UNISP_NAME_A + CHR$(0)' gpSSPI.AcquireCredentialsHandleA  


    CALL DWORD @gpSSPI.AcquireCredentialsHandleA USING AcquireCredentialsHandle( _
                %NULL, _                 ' SEC_CHAR SEC_FAR * pszPrincipal // Name of principal           
      VARPTR(pszPackage), _    ' SEC_CHAR SEC_FAR * pszPackage   // Name of package             
      %SECPKG_CRED_OUTBOUND, _ ' unsigned long fCredentialUse    // Flags indicating use        
      %NULL, _                 ' void SEC_FAR * pvLogonId        // Pointer to logon ID         
      VARPTR(gSchannelCred), _ ' void SEC_FAR * pAuthData        // Package specific data       
      %NULL, _                 ' SEC_GET_KEY_FN pGetKeyFn        // Pointer to GetKey() func    
      %NULL, _                 ' void SEC_FAR * pvGetKeyArgument // Value to pass to GetKey()   
      phCreds, _               ' PCredHandle phCredential        // (out) Cred Handle           
      VARPTR(tsExpiry) ) _     ' PTimeStamp ptsExpiry 
                TO SecStatus  ' 

    IF SecStatus <> %SEC_E_OK THEN 
      PRINT #hDbg, "**** Error:" + STR$(SecStatus) + " returned by AcquireCredentialsHandle"
    END IF
           

    '- cleanup: Free the certificate context. Schannel has already made its own copy.
    IF pCertContext THEN CertFreeCertificateContext(@pCertContext) 


  FUNCTION = SecStatus ' PRINT #hDbg, "Returning SecStatus=" + STR$(SecStatus)  
 
END FUNCTION
    


'/*****************************************************************************/  
FUNCTION ConnectToServer( pszServerName AS ASCIIZ, iPortNumber AS LONG, SSLsocket AS DWORD ) AS LONG      
'                             IN                       IN                  OUT 
           
  LOCAL he_list   AS LONG 
  LOCAL cbMessage AS DWORD     
  LOCAL sMessage  AS STRING
  LOCAL zTemp     AS ASCIIZ * 64  
  LOCAL SockInfo  AS sockaddr_in ' struct 
  LOCAL HostInfo  AS hostent  
  LOCAL pHostInfo AS hostent PTR    ' struct 



    SSLsocket = socket( %PF_INET, %SOCK_STREAM, 0 )
    IF SSLsocket = %INVALID_SOCKET THEN    
      PRINT #hDbg, "**** Error:" + STR$(WSAGetLastError()) + " creating socket"
 DisplayWinSockError( WSAGetLastError() )
      FUNCTION = WSAGetLastError()  
      EXIT FUNCTION
    END IF
       

    IF %fUseProxy THEN   
        zTemp     = $pszProxyServer 
        pHostInfo = gethostbyname(zTemp)
        IF pHostInfo = 0 THEN  
          PRINT #hDbg, "**** Error:" + STR$(WSAGetLastError()) + " returned by gethostbyname using Proxy"
DisplayWinSockError( WSAGetLastError() )
          FUNCTION = WSAGetLastError()  
          EXIT FUNCTION
        END IF

        CopyMemory BYVAL VARPTR(hostinfo), BYVAL pHostinfo, LEN(hostinfo) ' Copy Structure locally
        he_list = hostinfo.h_list
        he_list = CVL(PEEK$(he_list,4))
        SockInfo.sin_addr.s_addr = CVL(PEEK$(he_list,4)) ' SockInfo.sin_addr.s = CHR$(0, 0, 0, 0)   '''''htonl(%INADDR_ANY)
        SockInfo.sin_family = %AF_INET
        SockInfo.sin_port   = htons(%iProxyPort) ' Convert to network ordering
        sockinfo.sin_zero   = STRING$(8, $NUL) 

    ELSE '  No proxy used
        pHostInfo = gethostbyname(pszServerName)   
        IF pHostInfo = 0 THEN
          PRINT #hDbg, "**** Error returned by gethostbyname" 
DisplayWinSockError( WSAGetLastError() )
          FUNCTION = WSAGetLastError()
          EXIT FUNCTION  
        END IF
                
        CopyMemory BYVAL VARPTR(hostinfo), BYVAL pHostinfo, LEN(hostinfo) ' Copy Structure locally
        he_list = hostinfo.h_list
        he_list = CVL(PEEK$(he_list,4))
        SockInfo.sin_addr.s_addr = CVL(PEEK$(he_list,4)) ' SockInfo.sin_addr.s = CHR$(0, 0, 0, 0)   '''''htonl(%INADDR_ANY)
        SockInfo.sin_family = %AF_INET
        SockInfo.sin_port   = htons(iPortNumber) ' Convert to network ordering
        sockinfo.sin_zero   = STRING$(8, $NUL)     
    END IF
'   LOCAL b AS BYTE PTR
'   b = VARPTR(SockInfo.sin_addr.s_addr) 'return IP address of connection
'   PRINT #hDbg, "ipAddress=" + USING$("#_.#_.#_.#", @b, @b[1], @b[2], @b[3])
        

    IF cconnect( SSLsocket, SockInfo, SIZEOF(SockInfo) ) = %SOCKET_ERROR  THEN  
      PRINT #hDbg, "**** Error:" + STR$(WSAGetLastError()) + " connecting to" + TRIM$(pszServerName)
      CALL closesocket(SSLsocket)
DisplayWinSockError( WSAGetLastError() )
      FUNCTION = WSAGetLastError() 
      EXIT FUNCTION
    END IF

    IF %fUseProxy THEN
        sMessage = "CONNECT " + TRIM$(pszServerName) + ":" + _
                    FORMAT$(iPortNumber) + " HTTP/1.0" + $CRLF + "User-Agent: webclient" +$CRLF+$CRLF + $NUL

        ' Send message to proxy server
        IF ssend( SSLsocket, STRPTR(sMessage), LEN(sMessage), 0 ) = %SOCKET_ERROR THEN 
          PRINT #hDbg, "**** Error:" + STR$(WSAGetLastError()) + " sending message to proxy"
DisplayWinSockError( WSAGetLastError() )
FUNCTION = WSAGetLastError() 
          EXIT FUNCTION
        END IF             

        ' Receive message from proxy server 
        sMessage  = NUL$(200)
        cbMessage = rrecv( SSLsocket, STRPTR(sMessage), LEN(sMessage), 0)
        IF cbMessage = %SOCKET_ERROR THEN  
          PRINT #hDbg, "**** Error:" + STR$(WSAGetLastError()) + " receiving message from proxy"
DisplayWinSockError( WSAGetLastError() )
FUNCTION = WSAGetLastError() 
          EXIT FUNCTION
        END IF ' this code is limited. In normal use it should continue to receive until CRLF CRLF is received 

    END IF  

  FUNCTION = %SEC_E_OK ' PRINT #hDbg, "1 SSLsocket=" + STR$(SSLsocket)

END FUNCTION
                    

'/*****************************************************************************/
FUNCTION DisconnectFromServer( SSLsocket AS DWORD, BYVAL phCreds AS CredHandle PTR, BYVAL phContext AS CtxtHandle PTR ) AS LONG 

  LOCAL pbMessage AS BYTE PTR
  LOCAL cbData AS LONG
  LOCAL dwType, dwSSPIFlags, dwSSPIOutFlags, cbMessage, SecStatus AS DWORD
  LOCAL OutBuffer AS SecBufferDesc 
  LOCAL OutBuffers() AS SecBuffer     
  LOCAL tsExpiry AS QUAD ' TimeStamp
           

    DIM OutBuffers(0)
    dwType = %SCHANNEL_SHUTDOWN ' 1 - NOTIFY schannel that we are about TO CLOSE the connection.

    OutBuffers(0).pvBuffer   = VARPTR(dwType)
    OutBuffers(0).BufferType = %SECBUFFER_TOKEN
    OutBuffers(0).cbBuffer   = SIZEOF(dwType)

    OutBuffer.cBuffers  = 1
    OutBuffer.pBuffers  = VARPTR(OutBuffers(0))
    OutBuffer.ulVersion = %SECBUFFER_VERSION ' PRINT #hDbg, "OutBuffer.pBuffers=" + STR$(OutBuffer.pBuffers)
                    
    CALL DWORD @gpSSPI.ApplyControlToken USING ApplyControlToken( phContext, VARPTR(OutBuffer) ) TO SecStatus
IF SecStatus < 0 THEN       
      PRINT #hDbg, "**** Error:" + STR$(SecStatus) + " returned by ApplyControlToken"
      GOTO cleanup 
    END IF


    '- Build an SSL CLOSE NOTIFY message.
    dwSSPIFlags = %ISC_REQ_SEQUENCE_DETECT OR %ISC_REQ_REPLAY_DETECT   OR %ISC_REQ_CONFIDENTIALITY  OR _
                  %ISC_RET_EXTENDED_ERROR  OR %ISC_REQ_ALLOCATE_MEMORY OR %ISC_REQ_STREAM

    OutBuffers(0).pvBuffer   = %NULL
    OutBuffers(0).BufferType = %SECBUFFER_TOKEN
    OutBuffers(0).cbBuffer   = 0

    OutBuffer.cBuffers  = 1
    OutBuffer.pBuffers  = VARPTR(OutBuffers(0))
    OutBuffer.ulVersion = %SECBUFFER_VERSION  

    CALL DWORD @gpSSPI.InitializeSecurityContextA USING InitializeSecurityContext( _ 
          phCreds, _               ' PCredHandle phCredential              ' Cred to base context      
phContext, _             ' PCtxtHandle phContext                 ' Existing context (OPT)    
%NULL, _                 ' SEC_WCHAR SEC_FAR * pszTargetName     ' Name of target            
dwSSPIFlags, _           ' unsigned long fContextReq             ' Context Requirements      
0, _                     ' unsigned long Reserved1               ' Reserved, MBZ             
%SECURITY_NATIVE_DREP, _ ' unsigned long TargetDataRep           ' Data rep of target        
%NULL, _                 ' PSecBufferDesc pInput                 ' Input Buffers             
0, _                     ' unsigned long Reserved2               ' Reserved, MBZ             
phContext, _             ' PCtxtHandle phNewContext              ' (out) New Context handle  
VARPTR(OutBuffer), _     ' PSecBufferDesc pOutput                ' (inout) Output Buffers    
VARPTR(dwSSPIOutFlags), _' unsigned long SEC_FAR * pfContextAttr ' (out) Context attrs       
VARPTR(tsExpiry) ) _     ' PTimeStamp ptsExpiry                  ' (out) Life span (OPT)     
          TO SecStatus

IF SecStatus < 0 THEN  
      PRINT #hDbg, "**** Error:" + STR$(SecStatus) + " returned by InitializeSecurityContext"
      GOTO cleanup 
    END IF
    pbMessage = OutBuffers(0).pvBuffer
    cbMessage = OutBuffers(0).cbBuffer


    '- Send the close notify message to the server.
    IF pbMessage <> %NULL AND cbMessage <> 0 THEN  
      cbData = ssend( SSLsocket, pbMessage, cbMessage, 0 )
      IF cbData = %SOCKET_ERROR OR cbData = 0 THEN
        SecStatus = WSAGetLastError()  
        PRINT #hDbg, "**** Error:" + STR$(SecStatus) + " sending close notify"
 DisplayWinSockError( WSAGetLastError() )
        GOTO cleanup
      END IF
      PRINT #hDbg, "Sending Close Notify"   
      PRINT #hDbg, STR$(cbData) + " bytes of handshake data sent"
IF %fVerbose THEN PRINT #hDbg, HexDump(cbData, pbMessage) + $CRLF 
      CALL DWORD @gpSSPI.FreeContextBuffer USING FreeContextBuffer(pbMessage) '  Free OUTPUT buffer.
    END IF
    
cleanup:
    CALL DWORD @gpSSPI.DeleteSecurityContext USING DeleteSecurityContext(phContext) ' Free the security context.
    CALL closesocket(SSLsocket) ' Close the socket.

    FUNCTION = SecStatus  ' PRINT #hDbg, "FUNCTION = SecStatus=" + STR$(SecStatus)

END FUNCTION



'/*****************************************************************************/
FUNCTION GetNewClientCredentials( BYVAL phCreds AS CredHandle PTR, BYVAL phContext AS CtxtHandle PTR ) AS LONG
            
' This sample code maintains a single credential handle, replacing it as necessary. This is a little 
' unusual. Many applications maintain a global credential handle that's  anonymous (ie it doesn't 
' contain a CLIENT certificate),  which is used to connect to all servers. If a particular server
' should require client authentication, then a new credential is created for use when connecting to that 
' SERVER. The global anonymous credential is retained for future connections to other servers.
' maintaining a single anonymous credential that's used whenever possible is most efficient, since 
' creating new credentials all the time is rather expensive. 

  LOCAL hCreds           AS CredHandle
  LOCAL IssuerListInfo   AS SecPkgContext_IssuerListInfoEx
  LOCAL FindByIssuerPara AS CERT_CHAIN_FIND_BY_ISSUER_PARA   
                  
  LOCAL ChainContext     AS CERT_CHAIN_CONTEXT
  LOCAL pChainContext    AS CERT_CHAIN_CONTEXT PTR

  LOCAL CertContext      AS CERT_CONTEXT
  LOCAL pCertContext     AS CERT_CONTEXT PTR  
  LOCAL SecStatus        AS LONG ' SECURITY_STATUS
  LOCAL tsExpiry AS QUAD ' TimeStamp 
  LOCAL zTemp AS ASCIIZ * 64  
  LOCAL pszPackage AS ASCIIZ * 64 ' "Microsoft Unified Security Protocol Provider" 

                      
    pChainContext = VARPTR(ChainContext)
    pCertContext  = VARPTR(CertContext)

    '- Read list of trusted issuers from schannel.
    CALL DWORD @gpSSPI.QueryContextAttributesA USING QueryContextAttributes( _ 
               phContext, _                    ' PCtxtHandle phContext     ' Context to query      
               %SECPKG_ATTR_ISSUER_LIST_EX, _  ' unsigned long ulAttribute ' Attribute to query    
               VARPTR(IssuerListInfo) ) _      ' void SEC_FAR * pBuffer    ' Buffer for attributes 
                TO SecStatus  

IF SecStatus <> %SEC_E_OK THEN  
      PRINT #hDbg, "**** Error:" + STR$(SecStatus) + " querying issuer list info"
      EXIT FUNCTION 
    END IF

    '- Enumerate the CLIENT certificates.                                           
    zTemp = $szOID_PKIX_KP_CLIENT_AUTH ' "1.3.6.1.5.5.7.3.2"
    FindByIssuerPara.cbSize             = SIZEOF(FindByIssuerPara)
    FindByIssuerPara.pszUsageIdentifier = VARPTR(zTemp)
    FindByIssuerPara.dwKeySpec          = 0
    FindByIssuerPara.cIssuer            = IssuerListInfo.cIssuers
    FindByIssuerPara.rgIssuer           = IssuerListInfo.aIssuers

    pChainContext = %NULL

    DO ' Find a certificate chain.
        pChainContext = CertFindChainInStore( ghMyCertStore, _              ' in HCERTSTORE hCertStore                   
                                              %X509_ASN_ENCODING, _         ' in DWORD dwCertEncodingType                
                                              0, _                          ' in DWORD dwFindFlags                       
                                              %CERT_CHAIN_FIND_BY_ISSUER, _ ' in DWORD dwFindType                        
                                              FindByIssuerPara, _           ' in const void *pvFindPara                  
                                              ChainContext )                ' in PCCERT_CHAIN_CONTEXT pPrevChainContext  
IF pChainContext = 0 THEN 
          PRINT #hDbg, "**** Error:" + STR$(GetLastError()) + " finding cert chain"
          EXIT DO 
        END IF
PRINT #hDbg, "ncertificate chain found"
               
        '- Get pointer to leaf certificate context.
        pCertContext = @pChainContext.@rgpChain.@rgpElement.pCertContext

        '- Create schannel credential.
        gSchannelCred.dwVersion = %SCHANNEL_CRED_VERSION
        gSchannelCred.cCreds    = 1
        gSchannelCred.paCred    = VARPTR(pCertContext)
                          
        pszPackage = $UNISP_NAME_A + CHR$(0) ' gpSSPI.AcquireCredentialsHandleA                   

        CALL DWORD @gpSSPI.AcquireCredentialsHandleA USING AcquireCredentialsHandle( _
                    %NULL, _                 ' SEC_CHAR SEC_FAR * pszPrincipal // Name of principal           
          VARPTR(pszPackage), _    ' SEC_CHAR SEC_FAR * pszPackage   // Name of package             
          %SECPKG_CRED_OUTBOUND, _ ' unsigned long fCredentialUse    // Flags indicating use        
          %NULL, _                 ' void SEC_FAR * pvLogonId        // Pointer to logon ID         
          VARPTR(gSchannelCred), _ ' void SEC_FAR * pAuthData        // Package specific data       
          %NULL, _                 ' SEC_GET_KEY_FN pGetKeyFn        // Pointer to GetKey() func    
          %NULL, _                 ' void SEC_FAR * pvGetKeyArgument // Value to pass to GetKey()   
          phCreds, _               ' PCredHandle phCredential        // (out) Cred Handle           
          VARPTR(tsExpiry) ) _     ' PTimeStamp ptsExpiry 
                    TO SecStatus  ' 

IF SecStatus <> %SEC_E_OK THEN 
          PRINT #hDbg, "**** Error:" + STR$(SecStatus) + " returned by AcquireCredentialsHandle"  
          ITERATE ' try again
        END IF ' 

PRINT #hDbg, "new schannel credential created"
        CALL DWORD @gpSSPI.FreeCredentialHandle USING FreeCredentialsHandle(phCreds) ' Destroy the old credentials.
        EXIT DO
    LOOP

END FUNCTION 



'/*****************************************************************************/
FUNCTION ClientHandshakeLoop( BYVAL SSLsocket AS DWORD, _                 ' IN
 BYVAL phCreds   AS CredHandle PTR, _        ' IN
       phContext AS DWORD, _                 ' IN / OUT
 BYVAL fDoRead AS LONG, _                    ' IN
 BYVAL pExtraData AS SecBuffer PTR ) AS LONG ' OUT SECURITY_STATUS
                                               


  LOCAL OutBuffer, InBuffer AS SecBufferDesc   
  LOCAL InBuffers(), OutBuffers() AS SecBuffer 
  LOCAL cbData AS LONG      
  LOCAL dwSSPIFlags, dwSSPIOutFlags, cbIoBuffer AS DWORD           
  LOCAL tsExpiry  AS QUAD ' TimeStamp      
  LOCAL scRet     AS LONG ' SECURITY_STATUS 
  LOCAL sIoBuffer AS STRING  
  LOCAL pIoBuffer, pFrom AS BYTE PTR                           


    dwSSPIFlags = %ISC_REQ_SEQUENCE_DETECT  OR %ISC_REQ_REPLAY_DETECT     OR %ISC_REQ_CONFIDENTIALITY OR _
                  %ISC_RET_EXTENDED_ERROR   OR %ISC_REQ_ALLOCATE_MEMORY   OR %ISC_REQ_STREAM
                          

    DIM InBuffers(2)
    DIM OutBuffers(1)

    '- Allocate DATA buffer.
    sIoBuffer = NUL$( %IO_BUFFER_SIZE ) ' application defined
    pIoBuffer = STRPTR(sIoBuffer)


    '- Loop until the handshake is finished or an error occurs.
    scRet = %SEC_I_CONTINUE_NEEDED

    WHILE( scRet = %SEC_I_CONTINUE_NEEDED    OR _
           scRet = %SEC_E_INCOMPLETE_MESSAGE OR _
           scRet = %SEC_I_INCOMPLETE_CREDENTIALS ) ' PRINT #hDbg, "Handshake Loop:" 

        IF cbIoBuffer = 0 OR scRet = %SEC_E_INCOMPLETE_MESSAGE THEN '  READ DATA FROM SERVER.
            IF fDoRead THEN
                cbData = rrecv(SSLsocket, pIoBuffer + cbIoBuffer, %IO_BUFFER_SIZE - cbIoBuffer, 0 )
                IF cbData = %SOCKET_ERROR THEN   
                    PRINT #hDbg, "**** Error:" + STR$(WSAGetLastError()) + " reading data from server"  
                    scRet = %SEC_E_INTERNAL_ERROR
                    EXIT LOOP 

                ELSEIF cbData = 0 THEN
                    PRINT #hDbg, "**** Server unexpectedly disconnected"
                    scRet = %SEC_E_INTERNAL_ERROR
                    EXIT LOOP  

                END IF  
                PRINT #hDbg, STR$(cbData) + " bytes of handshake data received"  
                IF %fVerbose THEN PRINT #hDbg, HexDump(cbData, pIoBuffer + cbIoBuffer) + $CRLF 
                cbIoBuffer = cbIoBuffer + cbData
            ELSE
              fDoRead = 1 ' %TRUE  
            END IF
        END IF



        '- Set up the input buffers. buffer 0 is used to pass in data received from the server. 
        '  schannel will consume some or all of this. leftover data (if any) will be placed in 
        '  buffer 1 and given a buffer type OF %SECBUFFER_EXTRA.
        InBuffers(0).pvBuffer    = pIoBuffer
        InBuffers(0).cbBuffer    = cbIoBuffer
        InBuffers(0).BufferType  = %SECBUFFER_TOKEN
                                 
        InBuffers(1).pvBuffer    = %NULL
        InBuffers(1).cbBuffer    = 0
        InBuffers(1).BufferType  = %SECBUFFER_EMPTY
                                 
        InBuffer.cBuffers        = 2
        InBuffer.pBuffers        = VARPTR(InBuffers(0))
        InBuffer.ulVersion       = %SECBUFFER_VERSION


        '- Setup output buffers. initialized TO %NULL to reduce attempts to free random garbage later.
        OutBuffers(0).pvBuffer   = %NULL
        OutBuffers(0).BufferType = %SECBUFFER_TOKEN
        OutBuffers(0).cbBuffer   = 0
                                 
        OutBuffer.cBuffers       = 1
        OutBuffer.pBuffers       = VARPTR(OutBuffers(0)) 
        OutBuffer.ulVersion      = %SECBUFFER_VERSION
                                 

        '- PRINT #hDbg, "CALL InitializeSecurityContext."
        CALL DWORD @gpSSPI.InitializeSecurityContextA USING InitializeSecurityContext(  _
                    phCreds, _                ' PCredHandle phCredential              ' Cred to base context      
phContext, _              ' PCtxtHandle phContext                 ' Existing context (OPT)    
%NULL, _                  ' SEC_WCHAR SEC_FAR * pszTargetName     ' Name of target            
dwSSPIFlags, _            ' unsigned long fContextReq             ' Context Requirements      
0, _                      ' unsigned long Reserved1               ' Reserved, MBZ             
%SECURITY_NATIVE_DREP, _  ' unsigned long TargetDataRep           ' Data rep of target        
VARPTR(InBuffer), _       ' PSecBufferDesc pInput                 ' Input Buffers             
0, _                      ' unsigned long Reserved2               ' Reserved, MBZ             
%NULL, _                  ' PCtxtHandle phNewContext              ' (out) New Context handle  
VARPTR(OutBuffer), _      ' PSecBufferDesc pOutput                ' (inout) Output Buffers    
VARPTR(dwSSPIOutFlags), _ ' unsigned long SEC_FAR * pfContextAttr ' (out) Context attrs       
VARPTR(tsExpiry) ) _      ' PTimeStamp ptsExpiry                  ' (out) Life span (OPT)     
                     TO scRet


        '- If InitializeSecurityContext was successful, or if the error was one of the special extended ones 

        IF scRet = %SEC_E_OK  OR  scRet = %SEC_I_CONTINUE_NEEDED  OR  scRet < 0 AND _
                                          (dwSSPIOutFlags AND %ISC_RET_EXTENDED_ERROR) THEN 

            IF OutBuffers(0).cbBuffer <> 0 AND OutBuffers(0).pvBuffer <> %NULL THEN ' PRINT #hDbg, "Send output buffer to server"
                cbData = ssend( SSLsocket, OutBuffers(0).pvBuffer, OutBuffers(0).cbBuffer, 0 )
                IF cbData = %SOCKET_ERROR OR cbData = 0 THEN  
                    PRINT #hDbg, "**** Error:" + STR$(WSAGetLastError()) + " sending data to server (2)"  
DisplayWinSockError( WSAGetLastError() )
                    CALL DWORD @gpSSPI.FreeContextBuffer     USING FreeContextBuffer(OutBuffers(0).pvBuffer)
                    CALL DWORD @gpSSPI.DeleteSecurityContext USING DeleteSecurityContext(phContext)
                    FUNCTION = %SEC_E_INTERNAL_ERROR 
                    EXIT FUNCTION
                END IF   
                PRINT #hDbg, STR$(cbData) + " bytes of handshake data sent"  
                IF %fVerbose THEN PRINT #hDbg, HexDump(cbData, OutBuffers(0).pvBuffer) + $CRLF 
                CALL DWORD @gpSSPI.FreeContextBuffer USING FreeContextBuffer(OutBuffers(0).pvBuffer) ' Free OUTPUT buffer.
                OutBuffers(0).pvBuffer = %NULL
            END IF
        END IF



        '- If InitializeSecurityContext returned %SEC_E_INCOMPLETE_MESSAGE - read more data, try again.
        IF scRet = %SEC_E_INCOMPLETE_MESSAGE THEN 
          PRINT #hDbg, "InitializeSecurityContext returned %SEC_E_INCOMPLETE_MESSAGE - read more data, try again"
          ITERATE ' Go around again.   
        END IF



        '- If InitializeSecurityContext returned %SEC_E_OK, then the handshake completed successfully.
        IF scRet = %SEC_E_OK THEN
            '  IF the "extra" buffer contains DATA, this is encrypted application protocol layer stuff. 
            '  It needs TO be saved. The application layer will later decrypt it WITH DecryptMessage.
            PRINT #hDbg, "Handshake was successful"

            IF InBuffers(1).BufferType = %SECBUFFER_EXTRA THEN
                @pExtraData.pvBuffer   = LocalAlloc( %LMEM_FIXED, InBuffers(1).cbBuffer )
                IF @pExtraData.pvBuffer = 0 THEN 
                  PRINT #hDbg, "**** Out of memory (2)" 
                  FUNCTION = %SEC_E_INTERNAL_ERROR 
                  EXIT FUNCTION
                END IF
                pFrom = pIoBuffer + (cbIoBuffer-InBuffers(1).cbBuffer)    
                MoveMemory( @pExtraData.pvBuffer, pFrom,  InBuffers(1).cbBuffer )
                @pExtraData.cbBuffer   = InBuffers(1).cbBuffer
                @pExtraData.BufferType = %SECBUFFER_TOKEN
                PRINT #hDbg, STR$(@pExtraData.cbBuffer) + " bytes of app data was bundled with handshake data"  

            ELSE
                @pExtraData.pvBuffer   = %NULL
                @pExtraData.cbBuffer   = 0
                @pExtraData.BufferType = %SECBUFFER_EMPTY   

            END IF
            EXIT LOOP ' Bail out to quit
        END IF



        '- Check for fatal error.
        IF scRet < 0 THEN  
          PRINT #hDbg, "**** Error:" + STR$(scRet) + " returned by InitializeSecurityContext (2)"  
          EXIT LOOP
        END IF

        '- If InitializeSecurityContext returned %SEC_I_INCOMPLETE_CREDENTIALS, server just requested client authentication. 
        IF scRet = %SEC_I_INCOMPLETE_CREDENTIALS THEN ' PRINT #hDbg, "server just requested client authentication."
            ' Busted. The server has requested client authentication and the credential we supplied didn't 
            ' contain a client certificate. This function will read the list of trusted certificate authorities 
            ' ("issuers") that was received from the server and attempt to find a suitable client certificate  
            ' that was issued by one of these. if this function is successful, then we will connect using the
            ' new certificate. otherwise, we will attempt to connect anonymously (using our current credentials).
            GetNewClientCredentials( phCreds, phContext )
            fDoRead = 0 ' %FALSE
            scRet   = %SEC_I_CONTINUE_NEEDED
            ITERATE ' Go around again.
        END IF

        '- Copy any leftover data from the "extra" buffer, and go around again.
        IF InBuffers(1).BufferType = %SECBUFFER_EXTRA THEN ' PRINT #hDbg, "Copy any leftover data from the 'extra' buffer, and go around again."
          pFrom = pIoBuffer + (cbIoBuffer-InBuffers(1).cbBuffer)
          MoveMemory( pIoBuffer,  pFrom, InBuffers(1).cbBuffer )
          cbIoBuffer = InBuffers(1).cbBuffer
        ELSE ' PRINT #hDbg, "cbIoBuffer = 0"
          cbIoBuffer = 0
        END IF
    WEND
         

    '- Delete the security context in the case of a fatal error.
    IF scRet < 0 THEN ' PRINT #hDbg, "Delete the security context"
      CALL DWORD @gpSSPI.DeleteSecurityContext USING DeleteSecurityContext(phContext)
      CALL LocalFree(pIoBuffer) 
    END IF

  FUNCTION = scRet ' 


END FUNCTION 


'/*****************************************************************************/
FUNCTION PerformClientHandshake(       SSLsocket  AS DWORD, _                ' IN
    BYVAL phCreds    AS CredHandle PTR, _       ' IN   
                                       pszServerName AS ASCIIZ, _            ' IN
    BYVAL phContext  AS CtxtHandle PTR, _       ' IN 
    BYVAL pExtraData AS SecBuffer PTR ) AS LONG ' OUT SECURITY_STATUS
                       
  LOCAL cbData AS LONG
  LOCAL dwSSPIFlags, dwSSPIOutFlags AS DWORD           
  LOCAL tsExpiry     AS QUAD ' TimeStamp      
  LOCAL scRet        AS LONG ' SECURITY_STATUS 
  LOCAL OutBuffer    AS SecBufferDesc   
  LOCAL OutBuffers() AS SecBuffer        


    DIM OutBuffers(0)

    dwSSPIFlags = %ISC_REQ_SEQUENCE_DETECT OR %ISC_REQ_REPLAY_DETECT   OR %ISC_REQ_CONFIDENTIALITY OR _
                  %ISC_RET_EXTENDED_ERROR  OR %ISC_REQ_ALLOCATE_MEMORY OR %ISC_REQ_STREAM
                      

    '- Initiate a ClientHello message AND generate a token.
    OutBuffers(0).pvBuffer   = %NULL
    OutBuffers(0).BufferType = %SECBUFFER_TOKEN
    OutBuffers(0).cbBuffer   = 0

    OutBuffer.cBuffers       = 1
    OutBuffer.pBuffers       = VARPTR(OutBuffers(0))
    OutBuffer.ulVersion      = %SECBUFFER_VERSION  ' PRINT #hDbg, "phContext=" + STR$(phContext)

    CALL DWORD @gpSSPI.InitializeSecurityContextA USING InitializeSecurityContext( _
                phCreds, _                ' PCredHandle phCredential              ' Cred to base context      
%NULL, _                  ' PCtxtHandle phContext                 ' Existing context (OPT)    
VARPTR(pszServerName), _  ' SEC_WCHAR SEC_FAR * pszTargetName     ' Name of target            
dwSSPIFlags, _            ' unsigned long fContextReq             ' Context Requirements      
0, _                      ' unsigned long Reserved1               ' Reserved, MBZ             
%SECURITY_NATIVE_DREP, _  ' unsigned long TargetDataRep           ' Data rep of target        
%NULL, _                  ' PSecBufferDesc pInput                 ' Input Buffers             
0, _                      ' unsigned long Reserved2               ' Reserved, MBZ             
phContext, _              ' PCtxtHandle phNewContext              ' (out) New Context handle  
VARPTR(OutBuffer), _      ' PSecBufferDesc pOutput                ' (inout) Output Buffers    
VARPTR(dwSSPIOutFlags), _ ' unsigned long SEC_FAR * pfContextAttr ' (out) Context attrs       
VARPTR(tsExpiry) ) _      ' PTimeStamp ptsExpiry                  ' (out) Life span (OPT)     
                  TO scRet 

    IF scRet <> %SEC_I_CONTINUE_NEEDED THEN 
      PRINT #hDbg, "**** Error:" + STR$(scRet) + " returned by InitializeSecurityContext (1)"  
      FUNCTION = scRet 
      EXIT FUNCTION
    END IF ' PRINT #hDbg, HexDump(OutBuffers(0).cbBuffer, OutBuffers(0).pvBuffer)

    '- Send response to server if there is one.
    IF OutBuffers(0).cbBuffer <> 0  AND  OutBuffers(0).pvBuffer <> %NULL THEN ' 
        cbData = ssend( SSLsocket, OutBuffers(0).pvBuffer, OutBuffers(0).cbBuffer, 0 ) ' 
        IF cbData = %SOCKET_ERROR OR cbData = 0 THEN   
          PRINT #hDbg, "**** Error:" + STR$(WSAGetLastError()) + " sending data to server (1)"  
          CALL DWORD @gpSSPI.FreeContextBuffer     USING FreeContextBuffer(OutBuffers(0).pvBuffer)  
          CALL DWORD @gpSSPI.DeleteSecurityContext USING DeleteSecurityContext(phContext) 
          FUNCTION = %SEC_E_INTERNAL_ERROR 
          EXIT FUNCTION
        END IF 
        PRINT #hDbg, STR$(cbData) + " bytes of handshake data sent" 
IF %fVerbose THEN PRINT #hDbg, HexDump(cbData, OutBuffers(0).pvBuffer) + $CRLF
        CALL DWORD @gpSSPI.FreeContextBuffer USING FreeContextBuffer(OutBuffers(0).pvBuffer) '  Free OUTPUT buffer.
        OutBuffers(0).pvBuffer = %NULL
    END IF

  FUNCTION = ClientHandshakeLoop( SSLsocket, phCreds, phContext, %TRUE, pExtraData )

END FUNCTION 


'/*****************************************************************************/
FUNCTION EncryptSend( BYVAL SSLsocket   AS DWORD, _                     ' IN
BYVAL phContext   AS CtxtHandle PTR, _            ' IN 
BYREF Sizes       AS SecPkgContext_StreamSizes, _ ' IN 
BYVAL pbIoBuffer  AS DWORD, _                     ' IN    
BYVAL sBuffer     AS STRING _                     ' IN  
                      ) AS LONG ' OUT SECURITY_STATUS

'  http://msdn.microsoft.com/en-us/library/aa375378(VS.85).aspx
'  The encrypted message is encrypted IN place, overwriting the original contents OF its buffer.
                 
  LOCAL cbData    AS LONG
  LOCAL cbMessage AS DWORD
  LOCAL scRet AS LONG           ' SECURITY_STATUS  
  LOCAL Message AS SecBufferDesc  ' unsigned LONG cbBuffer    '  SIZE OF the buffer, IN bytes  
  LOCAL Buffers() AS SecBuffer  ' unsigned LONG BufferType  '  TYPE OF the buffer (below)
  LOCAL pbMessage AS BYTE PTR      ' void SEC_FAR * pvBuffer  '  POINTER TO the buffer    
                         
        
    DIM Buffers(3)
                          
    pbMessage  = pbIoBuffer + Sizes.cbHeader ' message Offset by "header size" 
    POKE$ pbMessage, sBuffer ' message begins after the header
    cbMessage  = LEN(sBuffer)
    PRINT #hDbg, "Sending" + STR$(cbMessage) + " bytes of plaintext:" 
    PRINT #hDbg, TextDump(cbMessage, pbMessage) 
    IF %fVerbose THEN PRINT #hDbg, HexDump(cbMessage, pbMessage) + $CRLF 

 '- Encrypt the HTTP request.
    Buffers(0).pvBuffer     = pbIoBuffer        ' Pointer to buffer 1
    Buffers(0).cbBuffer     = Sizes.cbHeader ' length of header
    Buffers(0).BufferType   = %SECBUFFER_STREAM_HEADER ' Type of the buffer 

    Buffers(1).pvBuffer     = pbMessage  ' Pointer to buffer 2
    Buffers(1).cbBuffer     = cbMessage  ' length of the message
    Buffers(1).BufferType   = %SECBUFFER_DATA ' Type of the buffer 
    Buffers(2).pvBuffer     = pbMessage + cbMessage  ' Pointer to buffer 3
    Buffers(2).cbBuffer     = Sizes.cbTrailer  ' length of the trailor
    Buffers(2).BufferType   = %SECBUFFER_STREAM_TRAILER ' Type of the buffer 

Buffers(3).pvBuffer     = %SECBUFFER_EMPTY ' Pointer to buffer 4
    Buffers(3).cbBuffer     = %SECBUFFER_EMPTY ' length of buffer 4
    Buffers(3).BufferType   = %SECBUFFER_EMPTY ' Type of the buffer 4 


    Message.ulVersion       = %SECBUFFER_VERSION      ' Version number
    Message.cBuffers        = 4        ' Number of buffers - must contain four SecBuffer structures.
    Message.pBuffers        = VARPTR(Buffers(0)) ' Pointer to array of buffers


    CALL DWORD @gpSSPI.EncryptMessage USING EncryptMessage( phContext, 0, Message, 0 ) TO scRet '  must contain four SecBuffer structures.
    IF scRet < 0 THEN  
      PRINT #hDbg, "**** Error" + STR$(scRet) + " returned by EncryptMessage" 
      FUNCTION = scRet 
      EXIT FUNCTION
    END IF   


    '- SEND the encrypted DATA TO the SERVER. LEN flags
    cbData = ssend( SSLsocket, pbIoBuffer,    Buffers(0).cbBuffer + Buffers(1).cbBuffer + Buffers(2).cbBuffer,  0 )
    IF cbData = %SOCKET_ERROR OR cbData = 0 THEN 
      PRINT #hDbg, "**** Error" + STR$(WSAGetLastError()) + " sending data to server"  
      FUNCTION = %SEC_E_INTERNAL_ERROR  
      EXIT FUNCTION 

    ELSE                             
      PRINT #hDbg, STR$(cbData) + " bytes of encrypted data sent" 
      IF %fVerbose THEN PRINT #hDbg, HexDump(cbData, pbIoBuffer) + $CRLF

    END IF

  FUNCTION = cbData '

END FUNCTION 


'/*****************************************************************************/
FUNCTION ReadDecrypt( BYVAL SSLsocket        AS DWORD, _             ' IN 
                      BYVAL phCreds          AS CredHandle PTR, _    ' IN
BYVAL phContext        AS CtxtHandle PTR, _    ' IN  
BYVAL pbIoBuffer       AS DWORD, _             ' IN 
BYREF cbIoBufferLength AS DWORD, _             ' IN  
BYREF sBuffer          AS STRING _             ' OUT  
                      ) AS LONG ' OUT SECURITY_STATUS

'  calls rrecv() - blocking socket READ
'  http://msdn.microsoft.com/en-us/library/ms740121(VS.85).aspx

'  The encrypted message is decrypted IN place, overwriting the original contents OF its buffer.
'  http://msdn.microsoft.com/en-us/library/aa375211(VS.85).aspx

  LOCAL ExtraBuffer AS SecBuffer
  LOCAL pDataBuffer, pExtraBuffer AS SecBuffer PTR
             
  LOCAL scRet AS LONG ' SECURITY_STATUS
  LOCAL Message AS SecBufferDesc
  LOCAL Buffers() AS SecBuffer
         
  LOCAL cbData AS LONG   
  LOCAL cbIoBuffer, length AS DWORD
  LOCAL pBuff AS BYTE PTR
  LOCAL i AS LONG

                   

    DIM Buffers(3)
    sBuffer = "" ' Reset the buffer

    '- Read data from server until done.
    cbIoBuffer = 0
scRet      = 0
    DO '- READ some DATA.
IF cbIoBuffer = 0 OR scRet = %SEC_E_INCOMPLETE_MESSAGE THEN '  GET the DATA
            cbData = rrecv( SSLsocket, pbIoBuffer+cbIoBuffer, cbIoBufferLength - cbIoBuffer, 0 )
            IF cbData = %SOCKET_ERROR THEN
                PRINT #hDbg, "**** Error" + STR$(WSAGetLastError()) + " reading data from server" 
scRet = %SEC_E_INTERNAL_ERROR
EXIT LOOP  

            ELSEIF cbData = 0 THEN '  SERVER disconnected.
                IF cbIoBuffer THEN
                    PRINT #hDbg, "**** Server unexpectedly disconnected"
                    scRet = %SEC_E_INTERNAL_ERROR
                    FUNCTION = scRet 
                    EXIT FUNCTION
                ELSE
                  EXIT LOOP ' ALL Done   
                END IF   

            ELSE ' success 
                PRINT #hDbg, STR$(cbData) + " bytes of (encrypted) application data received" 
                IF %fVerbose THEN PRINT #hDbg, HexDump(cbData, pbIoBuffer+cbIoBuffer) + $CRLF 
                cbIoBuffer = cbIoBuffer + cbData ' PRINT #hDbg, "cbIoBuffer=" + STR$(cbIoBuffer)  

            END IF
        END IF


        '- Decrypt the received DATA. 
        Buffers(0).pvBuffer    = pbIoBuffer
        Buffers(0).cbBuffer    = cbIoBuffer
        Buffers(0).BufferType  = %SECBUFFER_DATA    ' Initial TYPE OF the buffer 1
Buffers(1).BufferType  = %SECBUFFER_EMPTY   ' Initial TYPE OF the buffer 2 
Buffers(2).BufferType  = %SECBUFFER_EMPTY   ' Initial TYPE OF the buffer 3 
Buffers(3).BufferType  = %SECBUFFER_EMPTY   ' Initial TYPE OF the buffer 4  
                                                      
Message.ulVersion      = %SECBUFFER_VERSION ' Version number
Message.cBuffers       = 4 ' Number of buffers - must contain four SecBuffer structures.
Message.pBuffers       = VARPTR(Buffers(0)) ' POINTER TO ARRAY OF buffers   

        CALL DWORD @gpSSPI.DecryptMessage USING DecryptMessage( phContext, Message, 0, %NULL ) TO scRet 
        IF scRet = %SEC_I_CONTEXT_EXPIRED THEN EXIT LOOP '  SERVER signalled END OF session
'       IF scRet = %SEC_E_INCOMPLETE_MESSAGE - INPUT buffer has partial encrypted record, READ more
        IF scRet <> %SEC_E_OK AND scRet <> %SEC_I_RENEGOTIATE AND scRet <> %SEC_I_CONTEXT_EXPIRED THEN
 PRINT #hDbg, "**** DecryptMessage"
DisplaySECError(scRet)
FUNCTION = scRet 
          EXIT FUNCTION
        END IF ' 

        '- Locate DATA AND (OPTIONAL) extra buffers. 
        pDataBuffer  = 0
        pExtraBuffer = 0
        FOR i = 1 TO 4 
          IF pDataBuffer  = 0 AND Buffers(i).BufferType = %SECBUFFER_DATA  THEN pDataBuffer  = VARPTR(Buffers(i))
          IF pExtraBuffer = 0 AND Buffers(i).BufferType = %SECBUFFER_EXTRA THEN pExtraBuffer = VARPTR(Buffers(i))
        NEXT


        '- Display the decrypted data.
        IF pDataBuffer THEN
length = @pDataBuffer.cbBuffer
IF length THEN ' Check if last two chars are CR LF
pBuff = @pDataBuffer.pvBuffer ' PRINT #hDbg,  "n-2= %d, n-1= %d \n", pBuff(length-2), pBuff(length-1) ) 
            PRINT #hDbg, "Decrypted data: " + STR$(length) + " bytes"  : PRINT #hDbg, TextDump( length, pBuff )
IF %fVerbose THEN PRINT #hDbg, HexDump(length, pBuff) + $CRLF 
            sBuffer = sBuffer + PEEK$( pBuff, length )  ' Add reply
IF @pBuff[length-2] = 13 AND @pBuff[length-1] = 10 THEN EXIT LOOP '  PRINT #hDbg, "Found CRLF"
          END IF
        END IF


        '- Move ANY "extra" DATA TO the INPUT buffer.
        IF pExtraBuffer THEN
          MoveMemory( pbIoBuffer, @pExtraBuffer.pvBuffer, @pExtraBuffer.cbBuffer )
          cbIoBuffer = @pExtraBuffer.cbBuffer '  PRINT #hDbg, "cbIoBuffer= %d  \n", cbIoBuffer)
        ELSE
          cbIoBuffer = 0
        END IF
              

'- The server wants to perform another handshake sequence.
        IF scRet = %SEC_I_RENEGOTIATE THEN
            PRINT #hDbg, "Server requested renegotiate!"
            scRet = ClientHandshakeLoop( SSLsocket, phCreds, phContext, %FALSE, VARPTR(ExtraBuffer) )
            IF scRet <> %SEC_E_OK THEN FUNCTION = scRet : EXIT FUNCTION

            IF ExtraBuffer.pvBuffer THEN ' Move ANY "extra" DATA TO the INPUT buffer. 
                MoveMemory( pbIoBuffer, ExtraBuffer.pvBuffer, ExtraBuffer.cbBuffer )
                cbIoBuffer = ExtraBuffer.cbBuffer
            END IF
        END IF
    LOOP ' LOOP till CRLF is found at the end of the data

FUNCTION = %SEC_E_OK

END FUNCTION 

'/*****************************************************************************/
FUNCTION SMTPsession( BYVAL SSLsocket   AS DWORD, _                ' IN 
                      BYVAL phCreds     AS CredHandle PTR, _       ' IN
BYVAL phContext   AS CtxtHandle PTR _        ' IN  
                            ) AS LONG ' OUT SECURITY_STATUS


  LOCAL Sizes AS SecPkgContext_StreamSizes  
  LOCAL scRet AS LONG ' SECURITY_STATUS
  LOCAL cbData AS LONG
  LOCAL cbIoBufferLength AS DWORD
  LOCAL sIoBuffer, sTemp, sRequest, sResponse AS STRING  
  LOCAL pIoBuffer, pFrom AS BYTE PTR  



    '- READ stream encryption properties.
    CALL DWORD @gpSSPI.QueryContextAttributesA USING QueryContextAttributes( phContext, %SECPKG_ATTR_STREAM_SIZES, VARPTR(Sizes) ) TO scRet
    IF scRet <> %SEC_E_OK THEN
      PRINT #hDbg, "**** Error" + STR$(scRet) + " reading SECPKG_ATTR_STREAM_SIZES"  
      FUNCTION = scRet 
      EXIT FUNCTION
    END IF ' PRINT #hDbg, "scRet=" + STR$(scRet)

    '- CREATE a buffer. 
    cbIoBufferLength = Sizes.cbHeader  +  Sizes.cbMaximumMessage  +  Sizes.cbTrailer
    sIoBuffer = NUL$(cbIoBufferLength)
    pIoBuffer = STRPTR(sIoBuffer)
              
    '- Receive a Response 
scRet = ReadDecrypt( SSLsocket, phCreds, phContext, pIoBuffer, cbIoBufferLength, sTemp )
    IF scRet <> %SEC_E_OK THEN FUNCTION = scRet : EXIT FUNCTION  

    '- SEND a request, must be < maximum message SIZE 
    sTemp  = "EHLO " + $CRLF
    cbData = EncryptSend( SSLsocket, phContext, Sizes, pIoBuffer, sTemp )
    IF cbData = %SEC_E_INTERNAL_ERROR THEN FUNCTION = cbData : EXIT FUNCTION

    '- Receive a Response 
scRet = ReadDecrypt( SSLsocket, phCreds, phContext, pIoBuffer, cbIoBufferLength, sTemp )
    IF scRet <> %SEC_E_OK THEN FUNCTION = scRet : EXIT FUNCTION
                    
                      
    ' authentication and email send go here


    '- SEND a request, must be < maximum message SIZE 
    sTemp = "QUIT " + $CRLF
    cbData = EncryptSend( SSLsocket, phContext, Sizes, pIoBuffer, sTemp )
    IF cbData = %SEC_E_INTERNAL_ERROR THEN FUNCTION = cbData : EXIT FUNCTION
  
    '- Receive a Response 
scRet = ReadDecrypt( SSLsocket, phCreds, phContext, pIoBuffer, cbIoBufferLength, sTemp )
    IF scRet <> %SEC_E_OK THEN FUNCTION = scRet
           
  FUNCTION = %SEC_E_OK 

END FUNCTION

        
'****************************************************************************************
FUNCTION PBMAIN() ' powerbasic WINMAIN()

  LOCAL RetVal, fCredsInitialized, fContextInitialized AS LONG
  LOCAL hSecurity, SSLsocket, ghMyCertStore AS DWORD   
  LOCAL sBody, sRet AS STRING  
  LOCAL SecStatus AS LONG ' SECURITY_STATUS  
  LOCAL pszServerName AS ASCIIZ * 255  
  LOCAL hClientCreds AS CredHandle 
  LOCAL hContext     AS CtxtHandle  
  LOCAL wd AS WSADATA
  LOCAL ExtraData AS SecBuffer  
  LOCAL RemoteCertContext  AS CERT_CONTEXT
  LOCAL pRemoteCertContext AS CERT_CONTEXT PTR 

hDbg = FREEFILE : OPEN $DEBUG_FILE FOR OUTPUT LOCK SHARED AS hDbg ' 
PRINT #hDbg, "--------  "+DATE$+"  "+TIME$+"  ---------"  
          

    '- Create dispatch table that contains pointers to the functions defined in SSPI.h
    gpSSPI = InitSecurityInterface()
    IF gpSSPI = 0 THEN 
      PRINT #hDbg, "Error" + STR$(GetLastError()) = " reading security interface" : GOTO cleanup 
    END IF
PRINT #hDbg, "----- SSPI Initialized"

                   
    '- Create credentials.
    RetVal = CreateCredentials( $sUser, VARPTR(hClientCreds) ) 
    IF RetVal THEN
      PRINT #hDbg, "Error creating credentials"
      GOTO cleanup  '    
    END IF
    fCredsInitialized = %TRUE '  
PRINT #hDbg, "----- Credentials Initialized"
    
         

    '- Initialize the WinSock subsystem. 
    RetVal = WSAStartup(&H101, wd)
    IF RetVal = %SOCKET_ERROR THEN
      PRINT #hDbg, "Error" +STR$(GetLastError())+ " returned by WSAStartup" : GOTO cleanup 
    END IF ' 
PRINT #hDbg, "----- WinSock Initialized"



    '- Connect to the SERVER
    SSLsocket     = %INVALID_SOCKET ' Default 
    pszServerName = $MailHost
    IF ConnectToServer( pszServerName, %TCP_PORT, SSLsocket ) THEN
      PRINT #hDbg, "Error connecting to server"
      GOTO cleanup  '    
    END IF  
PRINT #hDbg, "----- Connected To Server"


    '- Perform handshake
    IF PerformClientHandshake( SSLsocket, VARPTR(hClientCreds), pszServerName, VARPTR(hContext), VARPTR(ExtraData) ) THEN
      PRINT #hDbg, "Error performing handshake" 
      GOTO cleanup  '    
    END IF  
    fContextInitialized = %TRUE '  
PRINT #hDbg, "----- Client Handshake Performed"
                     
     
    '- Authenticate server's credentials. Get server's certificate. 
    pRemoteCertContext = VARPTR(RemoteCertContext)  
    CALL DWORD @gpSSPI.QueryContextAttributesA USING QueryContextAttributes( VARPTR(hContext), _  ' handle to the security context to be queried. 
                                                      %SECPKG_ATTR_REMOTE_CERT_CONTEXT, _ ' attribute of the context to be returned.
                                                      VARPTR(pRemoteCertContext) ) TO SecStatus    '  pointer to a structure PTR that receives the attributes
    IF SecStatus <> %SEC_E_OK THEN 
      PRINT #hDbg, "**** Error" + DisplaySECError(SecStatus) + " querying remote certificate" 
      GOTO cleanup  '    
    END IF  
PRINT #hDbg, "----- Server Credentials Authenticated "
                     


    '- Display server certificate chain.
    DisplayCertChain( pRemoteCertContext, %FALSE ) ' 
PRINT #hDbg, "----- Certificate Chain Displayed "

         

    '- Validate the SERVER certificate.
    SecStatus = VerifyServerCertificate( pRemoteCertContext, pszServerName, 0 )
IF SecStatus THEN     
      PRINT #hDbg, "**** Error" + DisplaySECError(SecStatus) + " authenticating server credentials!" 
      GOTO cleanup  '    
    END IF  
'  The server certificate did not validate correctly. at this point, we cannot tell 
'  if we are connecting to the correct server, or if we are connecting to a 
'  "man in the middle" attack SERVER - Best TO just abort the connection.
PRINT #hDbg, "----- Server Certificate Verified"

 

    '- Free the SERVER certificate context.
    CALL CertFreeCertificateContext(@pRemoteCertContext)
    pRemoteCertContext = %NULL ' 
PRINT #hDbg, "----- Server certificate context released "


    '- Display connection info. 
    DisplayConnectionInfo( VARPTR(hContext) ) ' 
PRINT #hDbg, "----- Secure Connection Info"
  

    '- SEND Request, recover response. LPSTR pszRequest = "EHLO"
    IF SMTPsession( SSLsocket, VARPTR(hClientCreds), VARPTR(hContext) ) <> %SEC_E_OK THEN 
      PRINT #hDbg, "Error SMTP Session " 
      GOTO cleanup  '    
    END IF
PRINT #hDbg, "----- SMTP session Complete "

               
    '- SEND a close_notify alert TO the SERVER AND CLOSE down the connection.
    IF DisconnectFromServer( SSLsocket, VARPTR(hClientCreds), VARPTR(hContext) ) THEN
      PRINT #hDbg, "Error disconnecting from server" 
      GOTO cleanup  
    END IF
    fContextInitialized = %FALSE
    SSLsocket           = %INVALID_SOCKET '  
PRINT #hDbg, "----- Disconnected From Server"

     



cleanup: ' gpSSPI does not need to be freed  
PRINT #hDbg, "----- Begin Cleanup"

    '- Free the SERVER certificate context.
    IF pRemoteCertContext THEN
      CertFreeCertificateContext(@pRemoteCertContext)
      pRemoteCertContext = 0
    END IF

    '- Free SSPI context HANDLE.
    IF fContextInitialized THEN
      CALL DWORD @gpSSPI.DeleteSecurityContext USING DeleteSecurityContext(VARPTR(hContext))
      fContextInitialized = 0
    END IF

    '- Free SSPI credentials HANDLE.
    IF fCredsInitialized THEN
      CALL DWORD @gpSSPI.FreeCredentialHandle USING FreeCredentialsHandle(VARPTR(hClientCreds))
      fCredsInitialized = 0
    END IF

    '- Close socket.
    IF SSLsocket <> %INVALID_SOCKET THEN closesocket(SSLsocket)

    '- Shutdown WinSock subsystem.
    WSACleanup()

    '- Close "MY" certificate store.
    IF ghMyCertStore THEN CertCloseStore(ghMyCertStore, 0)

    CALL UnloadSecurityLibrary(hSecurity)


PRINT #hDbg, "----- All Done ----- "


CLOSE #hDbg

  MSGBOX "DONE"
         
END FUNCTION   

'****************************************************************************************

example in powerbasic

Comments