SMTPS - sending emails via gmail using SSL/TLS

[Uncle B]

Hi guys,

don't know if this is of any use to you but below is my translation of the VB code (Just practicing ).
It seems to work fine up to the 'AUTH LOGIN' command. See debugger output below.
I'm not sure why I'm getting an error there..
Would be nice to get this going though.

Code: Select all

;BASIC SMTPS 
; SMTP Client to send email via a gmail account using the CryptLib library

;#COMPILE EXE
  
XIncludeFile "Cryptlib_Header.pb"  ; v3.33
           
Global hDbg.l
          
;$DEBUG_FILE       = "CryptLib_dbg.txt"
  

#TCP_PORT         = 465               

  
    
#SMTP_RESPONSE_TIMEOUT = 5000 ; m/s      
                   
 
;****************************************************************************************
Procedure.s Err2Str(RetVal.l)

    If RetVal <> #CRYPT_OK

    Select RetVal 
        Case #CRYPT_ERROR_PARAM1      : ProcedureReturn  "Bad argument - parameter 1"
        Case #CRYPT_ERROR_PARAM2      : ProcedureReturn  "Bad argument - parameter 2"
        Case #CRYPT_ERROR_PARAM3      : ProcedureReturn  "Bad argument - parameter 3"
        Case #CRYPT_ERROR_PARAM4      : ProcedureReturn  "Bad argument - parameter 4"
        Case #CRYPT_ERROR_PARAM5      : ProcedureReturn  "Bad argument - parameter 5"
        Case #CRYPT_ERROR_PARAM6      : ProcedureReturn  "Bad argument - parameter 6"
        Case #CRYPT_ERROR_PARAM7      : ProcedureReturn  "Bad argument - parameter 7"
        Case #CRYPT_ERROR_MEMORY      : ProcedureReturn  "Out of memory"
        Case #CRYPT_ERROR_NOTINITED   : ProcedureReturn  "Data has not been initialised"
        Case #CRYPT_ERROR_INITED      : ProcedureReturn  "Data has already been init;d"
        Case #CRYPT_ERROR_NOSECURE    : ProcedureReturn  "Operation not avail at requested sec level"
        Case #CRYPT_ERROR_RANDOM      : ProcedureReturn  "No reliable random data available"
        Case #CRYPT_ERROR_FAILED      : ProcedureReturn  "Operation failed"
        Case #CRYPT_ERROR_INTERNAL    : ProcedureReturn  "Internal consistency check failed"
        Case #CRYPT_ERROR_NOTAVAIL    : ProcedureReturn  "This type of operation not available"
        Case #CRYPT_ERROR_PERMISSION  : ProcedureReturn  "No permission to perform this operation"
        Case #CRYPT_ERROR_WRONGKEY    : ProcedureReturn  "Incorrect key used to decrypt data"
        Case #CRYPT_ERROR_INCOMPLETE  : ProcedureReturn  "Operation incomplete/still in progress"
        Case #CRYPT_ERROR_COMPLETE    : ProcedureReturn  "Operation complete/can;t continue"
        Case #CRYPT_ERROR_TIMEOUT     : ProcedureReturn  "Operation timed out before completion"
        Case #CRYPT_ERROR_INVALID     : ProcedureReturn  "Invalid/inconsistent information"
        Case #CRYPT_ERROR_SIGNALLED   : ProcedureReturn  "Resource destroyed by extnl.event"
        Case #CRYPT_ERROR_OVERFLOW    : ProcedureReturn  "Resources/space exhausted"
        Case #CRYPT_ERROR_UNDERFLOW   : ProcedureReturn  "Not enough data available"
        Case #CRYPT_ERROR_BADDATA     : ProcedureReturn  "Bad/unrecognised data format"
        Case #CRYPT_ERROR_SIGNATURE   : ProcedureReturn  "Signature/integrity check failed"
        Case #CRYPT_ERROR_OPEN        : ProcedureReturn  "Cannot open object"
        Case #CRYPT_ERROR_READ        : ProcedureReturn  "Cannot read item from object"
        Case #CRYPT_ERROR_WRITE       : ProcedureReturn  "Cannot write item to object"
        Case #CRYPT_ERROR_NOTFOUND    : ProcedureReturn  "Requested item not found in object"
        Case #CRYPT_ERROR_DUPLICATE   : ProcedureReturn  "Item already present in object"
        Case #CRYPT_ENVELOPE_RESOURCE : ProcedureReturn  "Need resource to proceed"
        Default                       : ProcedureReturn  "Unknown error code!"
    EndSelect
    EndIf
EndProcedure

;¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤;
Procedure.s MimeEncode(sFileData.s)

string$ = sFileData

outputlength = Len(string$) * 1.4
If outputlength < 64
    outputlength = 64
EndIf


*InputBuffer = AllocateMemory(Len(string$))
*OutputBuffer = AllocateMemory(outputlength)

PokeS(*InputBuffer, string$)

length = Base64Encoder(*InputBuffer, Len(string$), *OutputBuffer, outputlength) 

If length
result$ = PeekS(*OutputBuffer, length)
Else
result$ = ""
EndIf

ProcedureReturn result$

;  Protected lBlock.l, lcBlocks.l, lByte1.l, lByte2.l, lByte3.l, lIndex1.l, lIndex2.l, lIndex3.l, lIndex4.l
;  Protected pInput.b, pOutput.b, pTable.b
;  Protected sBase64.s, sResult.s, mPad.s
  
;    sBase64  = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" ; Set up Base64 translation table
;    ;mPad     = STRING$(2 - (Len(sFileData) - 1) MOD 3, "=") ; Calculate padding for Base64 stream
;    mPad     = Str(2 - (Len(sFileData) - 1) % 3) ; Calculate padding for Base64 stream
;    lcBlocks = (Len(sFileData) + 2) \ 3 ; Round up the length of the input data to a multiple of three
;    If lcBlocks * 3 > Len(sFileData) : sFileData = LSET$(sFileData, lcBlocks * 3 USING $NUL) : EndIf
    
;    sResult  = SPACE$(lcBlocks * 4) ; Allocate the space for the output string
;    pInput   = STRPTR(sFileData) ; Set up pointers so we can treat the data as byte streams
;    pOutput  = STRPTR(sResult)
;    pTable   = STRPTR(sBase64)
;    For lBlock = 1 To lcBlocks ; Loop through our entire input buffer
;      lByte1 = @pInput ; Get the next three binary data bytes to process
;      INCR pInput
;      lByte2 = @pInput
;      INCR pInput
;      lByte3 = @pInput
;      INCR pInput
;      lIndex1  =  lByte1 \ 4  ; Translate the three data bytes into four Base64 table indices
;      lIndex2  = (lByte1 And 3) * 16 + lByte2 \ 16
;      lIndex3  = (lByte2 And 15)* 4  + lByte3 \ 64
;      lIndex4  =  lByte3 And 63
;      @pOutput = @pTable[lIndex1] ; Use the Base64 table to encode the output string
;      INCR pOutput
;      @pOutput = @pTable[lIndex2]
;      INCR pOutput
;      @pOutput = @pTable[lIndex3]
;      INCR pOutput
;      @pOutput = @pTable[lIndex4]
;      INCR pOutput
;    Next
;    RSET ABS sResult = mPad ; Merge in the padding bytes 


  

  ;ProcedureReturn  sResult 

EndProcedure   
       
;****************************************************************************************
Procedure.s ErrorExStr(hCrypt.l)
                      
  Protected MsgLen.l, RetVal.l
  Protected sErr.s

    sErr   = Space(512) ; Should be big enough for most messages
    RetVal = CryptGetAttributeString(hCrypt, #CRYPT_ATTRIBUTE_INT_ERRORMESSAGE, @sErr, @MsgLen)
              
  ProcedureReturn  Left(sErr, MsgLen) ; PRINT #hDbg, "RetVal="+Err2Str(RetVal) + " " + ", MsgLen="+STR$(MsgLen) + " " + TRIM$(zErr) : EXIT LOOP   

EndProcedure
;****************************************************************************************

Procedure.l TLSPushPop( hCrypt.l, sErr.s, sReply.s, sSend.s )
                      
  Define k.l, RetVal.l, BytesSent.l, BytesReply.l, Last.l, Totms.l 
  Define pByte.b
  ;Global sBuff.s 
          
    If Len(sSend) < 1 : sErr = "No data sent" : ProcedureReturn -21 : EndIf 

    If sBuff = 0 : sBuff = AllocateMemory(256) : EndIf; sBuff = Space(256) :EndIf; Create buffer
            
    
    ;- Trap unexpected returns
    RetVal = CryptPopData( hCrypt, sBuff, 256, @BytesReply )  
    If RetVal <> #CRYPT_OK 
      sErr = "CryptPopData ERROR: "+Err2Str(RetVal)
      ProcedureReturn -22  
    ElseIf BytesReply > 0
      sErr = "ERROR:"+Str(BytesReply)+" unexpected bytes in buffer: "+ Left(PeekS(sBuff,256), BytesReply) 
      ProcedureReturn -23
    EndIf  


    ;- Push Data  PRINT #hDbg, "Sent:" + STR$(Len(sSend)) + " Bytes: " + PARSE$(sSend, $CRLF, 1) 
    RetVal = CryptPushData( hCrypt, @sSend, Len(sSend), @BytesSent ) 
    If RetVal <> #CRYPT_OK : sErr = "CryptPushData ERROR "+Err2Str(RetVal) : ProcedureReturn -24 : EndIf   
    If Len(sSend) <> BytesSent : sErr = "LEN(sSend)="+Str(Len(sSend))+", BytesSent="+Str(BytesSent) : ProcedureReturn -24 : EndIf
    
    Debug "<C>: " + sSend

    ;"Flush outgoing data"  
    RetVal = CryptFlushData(hCrypt)
    If RetVal <> #CRYPT_OK : sErr = "CryptFlushData ERROR "+Err2Str(RetVal) : ProcedureReturn -25 : EndIf 
         

    ;"Recover response" 
    sReply = "" 
    Totms  = 0
    Repeat  
      Delay(20) ; Wait For a response  
      Totms = Totms + 20 
      If Totms > #SMTP_RESPONSE_TIMEOUT 
        sErr = "Response timeout >" + Str(#SMTP_RESPONSE_TIMEOUT) + "m/s" 
        ProcedureReturn -27
      EndIf ; PRINT #hDbg, STR$(Totms) + "m/s"


      RetVal = CryptPopData( hCrypt, sBuff, 256, @BytesReply )  ;Len(sBuff)
      If RetVal <> #CRYPT_OK : sErr = "CryptPopData ERROR "+Err2Str(RetVal) : Debug sErr : ProcedureReturn -29 : EndIf
      
      If BytesReply > 0 
        sReply = sReply + Left(PeekS(sBuff), BytesReply)
        Last = Len(sReply) ; PRINT #hDbg, "Rply:" + STR$(BytesReply) + " Bytes: " + LEFT$(sBuff, BytesReply) 
        pByte = @sReply ; Check last line For SMTP code follwed by space
        Break
        If Last > 7 And PeekS(pByte+Last-1) = Chr(10) And PeekS(pByte+Last-2) = Chr(13) : EndIf;' CRLF 
        If Last > 7 And Mid(sReply, Last-1, 1) = Chr(10) And Mid(sReply, Last-2,1) = Chr(13) ;' CRLF
          For k = 3 To Last ; PRINT #hDbg, "CharNum=" + STR$(Last-k+1) + ", " + CHR$(@pByte[Last-k]) 
            If Mid(sReply, Last-k) = Chr(10) And Mid(sReply, Last-k+4,1) = Chr(32) : Break : EndIf ; Space Not a hyphen "-", Response complete 
            If k = last            And Mid(sReply, Last-k+3,1) = Chr(32) : Break : EndIf ; Space Not a hyphen "-", Response complete 
          Next
        EndIf   
      EndIf  
    ForEver ; PRINT #hDbg, BytesToHexPtr( STRPTR(sBuff), BytesReply ) 
 
 
 Debug "<S>: " + sReply
 
 ;FreeMemory(sBuff)
  ProcedureReturn Val(StringField(sReply,1," ")) ; PRINT #hDbg, "----------------------"  

EndProcedure

;****************************************************************************************
Procedure.l SendGmail( sSrvr.s, sUser.s, sPass.s, sFrom.s, sTo.s, sBody.s, sRet.s)

; Returns   1 = message sent
;         -ve = Error (sRet = error description) 
     
  Protected RetVal.l, hSess.l, BytesReply.l
  Protected sReply.s, sEnc.s, sErr.s
  
  CRLF$ = Chr(10) + Chr(13)
  
                
    If Len(sSrvr) = 0 Or Len(sUser) = 0 Or Len(sPass) = 0 Or Len(sFrom) = 0 Or Len(sTo) = 0 Or Len(sBody) = 0
      sRet = "A required parameter string is missing"
      ProcedureReturn  -1 
    EndIf

    ; Initialize the Library
    RetVal = CryptInit() 
    If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcedureReturn  -2 : EndIf  


    Repeat   
      ; Create the session
      RetVal = CryptCreateSession(@hSess, #CRYPT_UNUSED, #CRYPT_SESSION_SSL) 
      If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcedureReturn  -4 : EndIf  

      ;Debug "hSess = " + Str(hSess)

      ; Add the server name "smtp.gmail.com" 
      RetVal = CryptSetAttributeString( hSess, #CRYPT_SESSINFO_SERVER_NAME, @sSrvr, Len(sSrvr)) 
      If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcedureReturn  -6 : EndIf    
                     
      ; Specify the Port
      RetVal = CryptSetAttribute( hSess, #CRYPT_SESSINFO_SERVER_PORT, 465 ) 
      If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcedureReturn  -8 : EndIf  

      ; Activate the session
      RetVal = CryptSetAttribute( hSess, #CRYPT_SESSINFO_ACTIVE, 1 ) 
      If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcedureReturn  -9 : EndIf  

      ; Remove any response created by connecting   
      sReply = Space(255)
      RetVal = CryptPopData( hSess, @sReply, Len(sReply),@BytesReply )  
      If RetVal <> #CRYPT_OK : sErr = "CryptPopData1 ERROR "+Err2Str(RetVal) : ProcedureReturn -10 : EndIf          
      
      
      ; MIME dialog

      RetVal = TLSPushPop(hSess, sErr, sReply, "EHLO" + CRLF$) ;  
      If RetVal <> 250 : sRet = "EHLO Failed: "+sErr : Debug sRet : ProcedureReturn  -11 : EndIf
  
      RetVal = TLSPushPop(hSess, sErr, sReply, "AUTH LOGIN" + CRLF$); 
      If RetVal <> 334 : sRet = "AUTH Failed: "+sErr : Debug sRet : ProcedureReturn  -12 : EndIf

      RetVal = TLSPushPop(hSess, sErr, sReply, MimeEncode(sUser) + CRLF$) ; Username
      If RetVal <> 334 : sRet = "user Failed: "+sErr : Debug sRet : ProcedureReturn  -13 : EndIf 

      RetVal = TLSPushPop(hSess, sErr, sReply, MimeEncode(sPass) + CRLF$) ; Password
      If RetVal <> 235 : sRet = "pass Failed: "+sErr : Debug sRet : ProcedureReturn  -14 : EndIf  

      RetVal = TLSPushPop(hSess, sErr, sReply, "MAIL FROM: <" + sFrom + ">" + CRLF$) ; Sender
      If RetVal <> 250 : sRet = "MAIL FROM Failed: "+sErr : Debug sRet : ProcedureReturn  -15 : EndIf  

      RetVal = TLSPushPop(hSess, sErr, sReply, "RCPT TO: <" + sTo + ">" + CRLF$) ; Recipient
      If RetVal <> 250 : sRet = "RCPT TO Failed: "+sErr : Debug sRet : ProcedureReturn  -16 : EndIf   

      RetVal = TLSPushPop(hSess, sErr, sReply, "DATA " + Chr(10)) ; Body begins
      If RetVal <> 354 : sRet = "DATA Failed: "+sErr : Debug sRet : ProcedureReturn  -17 : EndIf   
    
      RetVal = TLSPushPop(hSess, sErr, sReply, sBody   + CRLF$ + "." + CRLF$) ; Body 
      If RetVal <> 250 : sRet = "body Failed: "+sErr : Debug sRet : ProcedureReturn  -18 : EndIf   
      ProcedureReturn  1 ; 250 2.0.0 OK - Message sent 

      RetVal = TLSPushPop(hSess, sErr, sReply, "QUIT " + CRLF$) ; Terminate MIME
      If RetVal <> 221 : sRet = "QUIT Failed: "+sErr : Debug sRet : ProcedureReturn  -19 : EndIf   

      Break ; done
    ForEver 
    
    If hSess : CryptDestroySession(hSess) : EndIf; Close the session
    
    CryptEnd() ; Close the Library

EndProcedure 
 

;****************************************************************************************
Procedure PBMAIN()
         
  Protected RetVal.l
  Protected sBody.s, sRet.s


MailHost$         = "smtp.gmail.com"      ; SMTP Host 
MailFrom$         = "noreply@gmail.com"                                                                
UserName$         = "justtesting@gmail.com"      ; your gmail account
Password$         = "testpassword"              ; your gmail account
MailTo$           = "anyone@hotmail.com" ;

;hDbg = FREEFILE : OPEN $DEBUG_FILE For OUTPUT LOCK Shared As hDbg ; 
;PRINT #hDbg, "--------  "+DATE$+"  "+TIME$+"  ---------"  

    sBody = ""
    sBody = sBody + "From: "    + Mailfrom$  + Chr(10)
    sBody = sBody + "To: "      + MailTo$    + Chr(10)
    sBody = sBody + "Subject: " + "Gmail Test using TLS Encryption"  + Chr(10) + Chr(10)
    sBody = sBody + "Dear John, this email is brought to you courtesy of cryptlib" 

    RetVal = SendGmail(MailHost$, UserName$, Password$, Mailfrom$, MailTo$, sBody, sRet)       
    If RetVal < 0 : Debug "ERROR: "+ Err2Str(retVal) : EndIf

;CLOSE #hDbg

  MessageRequester("","DONE")
         
EndProcedure   

;**************************************************************************************** 


PBMAIN()

debugger output:

<C>: EHLO
<S>: 250-mx.google.com at your service, [87.211.230.154]
250-SIZE 35651584
250-8BITMIME
250-AUTH LOGIN PLAIN
250-ENHANCEDSTATUSCODES
250 PIPELINING
<C>: AUTH LOGIN
<S>: 502 5.5.1 Unrecognized command. 13sm2265370ewy.13

AUTH Failed:
ERROR: Data has already been init;d

Cheers! B.

p.s. I've used PB's bas64 encoder for the MimeEncode function.. Think that should work alright.

[Mike Trader]

You are very close.
Check that you left a space on the end of "AUTH LOGIN ", that it is not getting trimmed off

Send the command by itself and wait for the response as detailed here:
http://www.coastrd.com/smtps

Check you mime code with a free online encoder.
(The username and password are the only items that need to be encoded) so these can be encoded and stored as string constants without needing to use a mime encode function.
http://base64-encoder-online.waraxe.us/

The 502 code is:
FUNCTION = STR$(502)+" - Command Not implemented"+$CRLF+_
"This response indicates that a feature or command requested of the server could"+$CRLF+_
"not be accommodated because it is disabled or is not implemented by MailEnable s SMTP connector"

Just a reminider, you do not need to mime encode the "AUTH LOGIN " text.

[Uncle B]

Hi Mike, thanks for your reply.
I have checked all of that but it doesn't make any difference.

In the cryptlib manual there's being referred to the functions cryptCreateEnvelope() and cryptDestroyEnvelope().
To my opinion these functions are creating and destroying a databuffer to be used for receiving and sending data.
In the VB code these functions are not beeing used. therefore I think the same databuffer is used over and over again resulting in a string containing leftovers of old commands. (Not quite sure if I'm making any sense here..)

I'm guessing the actual conversation may look something like this:

<C>: EHLO
<S>: 250-mx.google.com at your service, [87.211.230.154]250-SIZE 35651584250-8BITMIME250-AUTH LOGIN PLAIN250-ENHANCEDSTATUSCODES250 PIPELINING
<C>: AUTH LOGIN le.com at your service, [87.211.230.154]250-SIZE 35651584250-8BITMIME250-AUTH LOGIN PLAIN250-ENHANCEDSTATUSCODES250 PIPELINING
<S>: 502 5.5.1 Unrecognized command. 13sm2265370ewy.13

I'm not sure how I should implement the create- and destroyEnvelope commands or how to make sure the internal databuffer is empty to start with. Anyway please enlighten me...

regards, B

[Mike Trader]

Hi Uncle,
Yes I thought the same thing at first, but in fact data enveloping is NOT required.

My email address is on the website, please send me your code and I will see if I can compile, run and test it with the free purebasic compiler I have.

If you have got a response to EHLO you are VERY VERY close. The TLS pipe is in place and the SMTP dialog has begun (both send and receive) I am sure there is some small fragment that is missing. I would be happy to help you find it.

[Mike Trader]

Hi Bart,

You had the CR LF pair switched so the gmail server was not able to parse the "AUTH LOGIN " command and hence returned error
502 5.5.1 Unrecognized command.

I had to cut the header down to the bare minimum because there is a 600 line limit on the demo version, and then I decided to printed out the strings and looked at them in hex.

Thank you for converting the header. I know how much work that is.
I adjusted your code a little to use a string for the buffer instead of using AllocateMemory() for a buffer. Unless I am missing something it should be OK for cryptlib to change the string (unless it is a C++ string class in which the contract does not allow this and your buffer of bytes would be needed)

Also, you need to break instead of returning directly in the case of an error in the loops so that cleanup can be done. I suspect cryptlib is calling somem destructors that might leak memory if they are not called. There is a lot going on under the hood.

I removed the mime encoding to sneak in under the line limit and used this website instead.
http://base64-encoder-online.waraxe.us/
replace the user/pass with the mime encoded string constants.

Here is the code:

Code: Select all

;BASIC SMTPS 
; SMTP Client to send email via a gmail account using the CryptLib library

XIncludeFile "Cryptlib_Header.pb"  ; v3.33

#TCP_PORT              = 465               
#SMTP_RESPONSE_TIMEOUT = 5000 ; m/s      
                  
 
;****************************************************************************************
Procedure.s Err2Str(RetVal.l)

    If RetVal <> #CRYPT_OK

    Select RetVal 
        Case #CRYPT_ERROR_PARAM1      : ProcedureReturn  "Bad argument - parameter 1"
        Case #CRYPT_ERROR_PARAM2      : ProcedureReturn  "Bad argument - parameter 2"
        Case #CRYPT_ERROR_PARAM3      : ProcedureReturn  "Bad argument - parameter 3"
        Case #CRYPT_ERROR_PARAM4      : ProcedureReturn  "Bad argument - parameter 4"
        Case #CRYPT_ERROR_PARAM5      : ProcedureReturn  "Bad argument - parameter 5"
        Case #CRYPT_ERROR_PARAM6      : ProcedureReturn  "Bad argument - parameter 6"
        Case #CRYPT_ERROR_PARAM7      : ProcedureReturn  "Bad argument - parameter 7"
        Case #CRYPT_ERROR_MEMORY      : ProcedureReturn  "Out of memory"
        Case #CRYPT_ERROR_NOTINITED   : ProcedureReturn  "Data has not been initialised"
        Case #CRYPT_ERROR_INITED      : ProcedureReturn  "Data has already been init;d"
        Case #CRYPT_ERROR_NOSECURE    : ProcedureReturn  "Operation not avail at requested sec level"
        Case #CRYPT_ERROR_RANDOM      : ProcedureReturn  "No reliable random data available"
        Case #CRYPT_ERROR_FAILED      : ProcedureReturn  "Operation failed"
        Case #CRYPT_ERROR_INTERNAL    : ProcedureReturn  "Internal consistency check failed"
        Case #CRYPT_ERROR_NOTAVAIL    : ProcedureReturn  "This type of operation not available"
        Case #CRYPT_ERROR_PERMISSION  : ProcedureReturn  "No permission to perform this operation"
        Case #CRYPT_ERROR_WRONGKEY    : ProcedureReturn  "Incorrect key used to decrypt data"
        Case #CRYPT_ERROR_INCOMPLETE  : ProcedureReturn  "Operation incomplete/still in progress"
        Case #CRYPT_ERROR_COMPLETE    : ProcedureReturn  "Operation complete/can;t continue"
        Case #CRYPT_ERROR_TIMEOUT     : ProcedureReturn  "Operation timed out before completion"
        Case #CRYPT_ERROR_INVALID     : ProcedureReturn  "Invalid/inconsistent information"
        Case #CRYPT_ERROR_SIGNALLED   : ProcedureReturn  "Resource destroyed by extnl.event"
        Case #CRYPT_ERROR_OVERFLOW    : ProcedureReturn  "Resources/space exhausted"
        Case #CRYPT_ERROR_UNDERFLOW   : ProcedureReturn  "Not enough data available"
        Case #CRYPT_ERROR_BADDATA     : ProcedureReturn  "Bad/unrecognised data format"
        Case #CRYPT_ERROR_SIGNATURE   : ProcedureReturn  "Signature/integrity check failed"
        Case #CRYPT_ERROR_OPEN        : ProcedureReturn  "Cannot open object"
        Case #CRYPT_ERROR_READ        : ProcedureReturn  "Cannot read item from object"
        Case #CRYPT_ERROR_WRITE       : ProcedureReturn  "Cannot write item to object"
        Case #CRYPT_ERROR_NOTFOUND    : ProcedureReturn  "Requested item not found in object"
        Case #CRYPT_ERROR_DUPLICATE   : ProcedureReturn  "Item already present in object"
        Case #CRYPT_ENVELOPE_RESOURCE : ProcedureReturn  "Need resource to proceed"
        Default                       : ProcedureReturn  "Unknown error code!"
    EndSelect
    EndIf
EndProcedure
      
;****************************************************************************************
Procedure.s ErrorExStr(hCrypt.l)
                      
  Protected MsgLen.l, RetVal.l
  Protected sErr.s

    sErr   = Space(512) ; Should be big enough for most messages
    RetVal = CryptGetAttributeString(hCrypt, #CRYPT_ATTRIBUTE_INT_ERRORMESSAGE, @sErr, @MsgLen)
              
  ProcedureReturn  Left(sErr, MsgLen) ; WriteStringN(0, "RetVal="+Err2Str(RetVal) + " " + ", MsgLen="+STR$(MsgLen) + " " + TRIM$(zErr) : EXIT LOOP   

EndProcedure
;****************************************************************************************


Procedure.l TLSPushPop( hCrypt.l, sErr.s, sReply.s, sSend.s )
                      
  Protected k.l, RetVal.l, BytesSent.l, BytesReply.l, Last.l, Totms.l 
  Protected pByte.b
  Protected sBuff.s 
   
       
    If Len(sSend) < 1 : sErr = "No data sent" : ProcedureReturn -21 : EndIf 
    
    sBuff = Space(256) ; Create buffer
            
    
    ;- Trap unexpected returns
    RetVal = CryptPopData( hCrypt, @sBuff, 256, @BytesReply )  
    If RetVal <> #CRYPT_OK 
      sErr = "CryptPopData ERROR: "+Err2Str(RetVal)
      ProcedureReturn -22  
    ElseIf BytesReply > 0
      sErr = "ERROR:"+Str(BytesReply)+" unexpected bytes in buffer: "+ sBuff
      Debug sErr
      ProcedureReturn -23
    EndIf  


    ;- Push Data  
WriteStringN(0, "Sent:" + Str(Len(sSend)) + " Bytes>" + Left(sSend, Len(sSend)) + "<" )
    RetVal = CryptPushData( hCrypt, @sSend, Len(sSend), @BytesSent ) 
    If RetVal <> #CRYPT_OK : sErr = "CryptPushData ERROR "+Err2Str(RetVal) : ProcedureReturn -24 : EndIf   
    If Len(sSend) <> BytesSent : sErr = "LEN(sSend)="+Str(Len(sSend))+", BytesSent="+Str(BytesSent) : ProcedureReturn -24 : EndIf
    
   
;Debug "<C>: " + sSend

    ;"Flush outgoing data"  
    RetVal = CryptFlushData(hCrypt)
    If RetVal <> #CRYPT_OK : sErr = "CryptFlushData ERROR "+Err2Str(RetVal) : ProcedureReturn -25 : EndIf 
         

    ;"Recover response" 
    sReply = "" 
    Totms  = 0
    Repeat  
      Delay(20) ; Wait For a response  
      Totms = Totms + 20 
      If Totms > #SMTP_RESPONSE_TIMEOUT 
        sErr = "Response timeout >" + Str(#SMTP_RESPONSE_TIMEOUT) + "m/s"
        ProcedureReturn -27
      EndIf ; WriteStringN(0, STR$(Totms) + "m/s"


      RetVal = CryptPopData( hCrypt, @sBuff, 256, @BytesReply )  ;Len(sBuff)
      If RetVal <> #CRYPT_OK : sErr = "CryptPopData ERROR "+Err2Str(RetVal) : Debug sErr : ProcedureReturn -29 : EndIf
      
      If BytesReply > 0 
        sReply = sReply + Left(sBuff, BytesReply)
        Last = Len(sReply) ; WriteStringN(0, "Rply:" + STR$(BytesReply) + " Bytes: " + LEFT$(sBuff, BytesReply) 
        pByte = @sReply ; Check last line For SMTP code follwed by space
        Break
        If Last > 7 And Mid(sReply, Last-1, 1) = Chr(10) And Mid(sReply, Last-2,1) = Chr(13) ;' CRLF
          For k = 3 To Last ; WriteStringN(0, "CharNum=" + STR$(Last-k+1) + ", " + CHR$(@pByte[Last-k]) 
            If Mid(sReply, Last-k) = Chr(10) And Mid(sReply, Last-k+4,1) = Chr(32) : Break : EndIf ; Space Not a hyphen "-", Response complete 
            If k = last            And Mid(sReply, Last-k+3,1) = Chr(32) : Break : EndIf ; Space Not a hyphen "-", Response complete 
          Next
        EndIf   
      EndIf  
    ForEver ; 
WriteStringN(0, "Reply:" +sReply) 
Debug "<S>: " + sReply
 
  ProcedureReturn Val(StringField(sReply,1," ")) ; WriteStringN(0, "----------------------"  

EndProcedure

;****************************************************************************************
Procedure.l SendGmail( sSrvr.s, sUser.s, sPass.s, sFrom.s, sTo.s, sBody.s, sRet.s)

; Returns   1 = message sent
;         -ve = Error (sRet = error description) 
     
  Protected RetVal.l, hSess.l, BytesReply.l, ProcRet.l
  Protected sReply.s, sEnc.s, sErr.s
  
  CRLF$ = Chr(13) + Chr(10) ; CR LF
  
                
    If Len(sSrvr) = 0 Or Len(sUser) = 0 Or Len(sPass) = 0 Or Len(sFrom) = 0 Or Len(sTo) = 0 Or Len(sBody) = 0
      sRet = "A required parameter string is missing"
      ProcedureReturn  -1 
    EndIf

    ; Initialize the Library
    RetVal = CryptInit() 
    If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcedureReturn  -2 : EndIf  
Debug "CryptInit OK"


    Repeat   
      ; Create the session
WriteStringN(0, "#CRYPT_SESSION_SSL:" +Str(#CRYPT_SESSION_SSL)) 
      RetVal = CryptCreateSession(@hSess, #CRYPT_UNUSED, #CRYPT_SESSION_SSL) 
      If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcRet = -4 : Break : EndIf  

      ;Debug "hSess = " + Str(hSess)

      ; Add the server name "smtp.gmail.com" 
      RetVal = CryptSetAttributeString( hSess, #CRYPT_SESSINFO_SERVER_NAME, @sSrvr, Len(sSrvr)) 
      If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcRet = -6 : Break : EndIf    
                     
      ; Specify the Port
      RetVal = CryptSetAttribute( hSess, #CRYPT_SESSINFO_SERVER_PORT, 465 ) 
      If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcRet = -8 : Break : EndIf  

      ; Activate the session
      RetVal = CryptSetAttribute( hSess, #CRYPT_SESSINFO_ACTIVE, 1 ) 
      If RetVal <> #CRYPT_OK : sRet = Err2Str(RetVal) : ProcRet = -9 : Break : EndIf  

Debug "TLS connection active"

      ; Remove any response created by connecting   
      sReply = Space(255)
      RetVal = CryptPopData( hSess, @sReply, Len(sReply),@BytesReply ) 
WriteStringN(0, "Initial Reply:" +sReply) 
      If RetVal <> #CRYPT_OK : sErr = "CryptPopData1 ERROR "+Err2Str(RetVal) : ProcRet = -10 : Break : EndIf          
      
      
      ; 
Debug "Begin MIME dialog"

      RetVal = TLSPushPop(hSess, sErr, sReply, "EHLO" + CRLF$) ;  
      If RetVal <> 250 : sRet = "EHLO Failed: "+sErr : Debug sRet : ProcRet = -11 : Break : EndIf
  
      RetVal = TLSPushPop(hSess, sErr, sReply, "AUTH LOGIN " + CRLF$); 
      If RetVal <> 334 : sRet = "AUTH Failed: "+sErr : Debug sRet : ProcRet = -12 : Break : EndIf
      
      RetVal = TLSPushPop(hSess, sErr, sReply, sUser + CRLF$) ; Mime encoded Username
      If RetVal <> 334 : sRet = "user Failed: "+sErr : Debug sRet : ProcRet = -13 : Break : EndIf 

      RetVal = TLSPushPop(hSess, sErr, sReply, sPass + CRLF$) ; Mime encoded Password
      If RetVal <> 235 : sRet = "pass Failed: "+sErr : Debug sRet : ProcRet = -14 : Break : EndIf  

      RetVal = TLSPushPop(hSess, sErr, sReply, "MAIL FROM: <" + sFrom + ">" + CRLF$) ; Sender
      If RetVal <> 250 : sRet = "MAIL FROM Failed: "+sErr : Debug sRet : ProcRet = -15 : Break : EndIf  

      RetVal = TLSPushPop(hSess, sErr, sReply, "RCPT TO: <" + sTo + ">" + CRLF$) ; Recipient
      If RetVal <> 250 : sRet = "RCPT TO Failed: "+sErr : Debug sRet : ProcRet = -16 : Break : EndIf   

      RetVal = TLSPushPop(hSess, sErr, sReply, "DATA " + Chr(10)) ; Body begins
      If RetVal <> 354 : sRet = "DATA Failed: "+sErr : Debug sRet : ProcRet = -17 : Break : EndIf   
    
      RetVal = TLSPushPop(hSess, sErr, sReply, sBody   + CRLF$ + "." + CRLF$) ; Body 
      If RetVal <> 250 : sRet = "body Failed: "+sErr : Debug sRet : ProcRet = -18 : Break : EndIf   
      ProcRet =  1 ; 250 2.0.0 OK - Message sent 

      RetVal = TLSPushPop(hSess, sErr, sReply, "QUIT " + CRLF$) ; Terminate MIME
      If RetVal <> 221 : sRet = "QUIT Failed: "+sErr : Debug sRet : ProcRet = -19 : Break : EndIf   

      Break ; done
    ForEver ; 
Debug "Cleaning up"
    
    If hSess : CryptDestroySession(hSess) : EndIf; Close the session
    
    CryptEnd() ; Close the Library
    
    ProcedureReturn ProcRet

EndProcedure 
 
;****************************************************************************************
Procedure PBMAIN()
         
  Protected RetVal.l
  Protected sBody.s, sRet.s

MailHost$         = "smtp.gmail.com"      ; SMTP Host 
MailFrom$         = "noreply@gmail.com"                                                                
UserName$         = "justtesting@gmail.com"     ; your mime encoded gmail account
Password$         = "testpassword"              ; your mime encoded gmail account
MailTo$           = "test@aol.com" ;


  OpenFile(0, "GmailDebug.txt")    ; opens an existing file or creates one, if it doesn't exist yet
  FileSeek(0, Lof(0))         ; jump to the end of the file (result of Lof() is used)

    sBody = ""
    sBody = sBody + "From: "    + Mailfrom$  + Chr(10)
    sBody = sBody + "To: "      + MailTo$    + Chr(10)
    sBody = sBody + "Subject: " + "Gmail Test using TLS Encryption"  + Chr(10) + Chr(10)
    sBody = sBody + "Dear Jim, this email is brought to you courtesy of cryptlib and purebasic" 

    RetVal = SendGmail(MailHost$, UserName$, Password$, Mailfrom$, MailTo$, sBody, sRet)       
    If RetVal < 0 : Debug "SendGmail Failed ERROR: "+ sRet : EndIf

CloseFile(0)
Debug "ALL DONE"

  ;MessageRequester("","DONE")
         
EndProcedure   

;**************************************************************************************** 

PBMAIN()

Thank you for your help

[Uncle B]

I tested it and it works great!!
Thanks!! I would have been looking for ages to see the problem..
I assume you are planning to publish the pb code on your website?
The header may not be completely bullet proof. some procedures required structured parameters.
I'm not sure if PB supports that.. Non of these procedures are used for emailing though, so I haven't looked into that any further.

Regards!

Bart

[Mike Trader]

You're welcome. Its a tricky problem that I spent some time researching solutions too. I should mention that socket tools www.catalyst.com have an excellent suite of tools for SMTP/HTTP and a lot more. Mike Stefanik, the developer, has supported BASIC for many years. They used to sell the tools as a package which made it a little costly for providing email capability, but they have just announced that they will sell the products as separate packages. The quality of thier tools if first class, certainly better than the Kat stuff. Had it been available when I needed it I would not have wasted any time on this solution.

Code in three languages (including PB) is available in the downloads area at www.coastrd.com

[jpd]

Hi Mike Trader and Uncle B,

thanks for this Great Example works really fine.

Best
jpd

[srod]

Looks great - thanks.

[jpd]

Hi Mike and Bart,
I have adapted the Cryptolib_Header for PB 4.40

and in gmail.pb I have added one base64encode procedure for mime encoding username and password

here the link:
gmail Purebasic 4.40

Best
jpd

[Mike Trader]

Can you give me a breif overview of what is different between these versions please?

[jpd]

Hi Mike,
in PB 4.40 is following changed:
since 4.40:
- Changed: Call(C)Function(Fast) parameters have been changed from 'Any' to 'Integer'.

consequetaly
Calls like

ProcedureReturn CallFunctionFast(*cryptDeviceOpen, pDevice.l, cryptUser.l, deviceType.l, zName.s)

need to modified to

CallFunctionFast(*cryptDeviceOpen, pDevice.l, cryptUser.l, deviceType.l, @zName.s)

another possible way is using prototype

I hope this help you!
I'm secure here is some people that can describe and give you detailed info regarding this change.

Best
jpd

[Fred]

Interesting.

[Mike Trader]

is there a #DEF for the new version so that one header file can contain both function definitions:

Code: Select all

#IF DEF(VER440)
    CallFunctionFast(*cryptDeviceOpen, pDevice.l, cryptUser.l, deviceType.l, @zName.s)
#ELSE
    ProcedureReturn CallFunctionFast(*cryptDeviceOpen, pDevice.l, cryptUser.l, deviceType.l, zName.s)
#ENDIF

[idle]

there are a few ways to do it.

Code: Select all

#VER440 =1

Macro mCryptDeviceOpen(cryptDeviceOpen,pDevice,cryptUser,deviceType,zName)

CompilerIf #VER440
    CallFunctionFast(cryptDeviceOpen, pDevice, cryptUser, deviceType, @zName)
CompilerElse
    CallFunctionFast(cryptDeviceOpen, pDevice, cryptUser, deviceType, zName)
CompilerEndIf

EndMacro


Procedure CryptDeviceOpen(pDevice.i, cryptUser.i, deviceType.i,zName.s)
 
 Debug pDevice
 Debug cryptUser
 Debug deviceType
 Debug zName
 
EndProcedure 

*cryptDeviceOpen = @cryptDeviceOpen()

mCryptDeviceOpen(*cryptDeviceOpen,1,2,3,"BoB")