' SMTP Client to send email via a gmail account using the CryptLib library #COMPILE EXE #INCLUDE "Cryptlib_Header.inc" ' v3.33 GLOBAL hDbg AS LONG $DEBUG_FILE = "CryptLib_dbg.txt" $MailHost = "smtp.gmail.com" ' SMTP Host $MailFrom = "noreply@gmail.com" $UserName = "fred@gmail.com" ' your gmail account $Password = "mypass" ' your gmail account %TCP_PORT = 465 $MailTo = "fred@gmail.com" ' %SMTP_RESPONSE_TIMEOUT = 5000 ' m/s '**************************************************************************************** FUNCTION Err2Str( RetVal AS LONG ) AS STRING IF RetVal = %CRYPT_OK THEN EXIT FUNCTION SELECT CASE RetVal CASE %CRYPT_ERROR_PARAM1 : FUNCTION = "Bad argument - parameter 1" CASE %CRYPT_ERROR_PARAM2 : FUNCTION = "Bad argument - parameter 2" CASE %CRYPT_ERROR_PARAM3 : FUNCTION = "Bad argument - parameter 3" CASE %CRYPT_ERROR_PARAM4 : FUNCTION = "Bad argument - parameter 4" CASE %CRYPT_ERROR_PARAM5 : FUNCTION = "Bad argument - parameter 5" CASE %CRYPT_ERROR_PARAM6 : FUNCTION = "Bad argument - parameter 6" CASE %CRYPT_ERROR_PARAM7 : FUNCTION = "Bad argument - parameter 7" CASE %CRYPT_ERROR_MEMORY : FUNCTION = "Out of memory" CASE %CRYPT_ERROR_NOTINITED : FUNCTION = "Data has not been initialised" CASE %CRYPT_ERROR_INITED : FUNCTION = "Data has already been init'd" CASE %CRYPT_ERROR_NOSECURE : FUNCTION = "Operation not avail at requested sec level" CASE %CRYPT_ERROR_RANDOM : FUNCTION = "No reliable random data available" CASE %CRYPT_ERROR_FAILED : FUNCTION = "Operation failed" CASE %CRYPT_ERROR_INTERNAL : FUNCTION = "Internal consistency check failed" CASE %CRYPT_ERROR_NOTAVAIL : FUNCTION = "This type of operation not available" CASE %CRYPT_ERROR_PERMISSION : FUNCTION = "No permission to perform this operation" CASE %CRYPT_ERROR_WRONGKEY : FUNCTION = "Incorrect key used to decrypt data" CASE %CRYPT_ERROR_INCOMPLETE : FUNCTION = "Operation incomplete/still in progress" CASE %CRYPT_ERROR_COMPLETE : FUNCTION = "Operation complete/can't continue" CASE %CRYPT_ERROR_TIMEOUT : FUNCTION = "Operation timed out before completion" CASE %CRYPT_ERROR_INVALID : FUNCTION = "Invalid/inconsistent information" CASE %CRYPT_ERROR_SIGNALLED : FUNCTION = "Resource destroyed by extnl.event" CASE %CRYPT_ERROR_OVERFLOW : FUNCTION = "Resources/space exhausted" CASE %CRYPT_ERROR_UNDERFLOW : FUNCTION = "Not enough data available" CASE %CRYPT_ERROR_BADDATA : FUNCTION = "Bad/unrecognised data format" CASE %CRYPT_ERROR_SIGNATURE : FUNCTION = "Signature/integrity check failed" CASE %CRYPT_ERROR_OPEN : FUNCTION = "Cannot open object" CASE %CRYPT_ERROR_READ : FUNCTION = "Cannot read item from object" CASE %CRYPT_ERROR_WRITE : FUNCTION = "Cannot write item to object" CASE %CRYPT_ERROR_NOTFOUND : FUNCTION = "Requested item not found in object" CASE %CRYPT_ERROR_DUPLICATE : FUNCTION = "Item already present in object" CASE %CRYPT_ENVELOPE_RESOURCE : FUNCTION = "Need resource to proceed" CASE ELSE : FUNCTION = "Unknown error code!" END SELECT END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤' FUNCTION MimeEncode( BYVAL sFileData AS STRING ) AS STRING LOCAL lBlock, lcBlocks, lByte1, lByte2, lByte3, lIndex1, lIndex2, lIndex3, lIndex4 AS LONG LOCAL pInput, pOutput, pTable AS BYTE PTR LOCAL sBase64, sResult, mPad AS STRING sBase64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" ' Set up Base64 translation table mPad = STRING$(2 - (LEN(sFileData) - 1) MOD 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) THEN sFileData = LSET$(sFileData, lcBlocks * 3 USING $NUL) 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 FUNCTION = sResult END FUNCTION '**************************************************************************************** FUNCTION ErrorExStr( hCrypt AS LONG ) AS STRING LOCAL MsgLen, RetVal AS LONG LOCAL sErr AS STRING sErr = NUL$(512) ' Should be big enough for most messages RetVal = CryptGetAttributeString( hCrypt, %CRYPT_ATTRIBUTE_INT_ERRORMESSAGE, STRPTR(sErr), VARPTR(MsgLen) ) FUNCTION = LEFT$(sErr, MsgLen) ' PRINT #hDbg, "RetVal="+Err2Str(RetVal) + " " + ", MsgLen="+STR$(MsgLen) + " " + TRIM$(zErr) : EXIT LOOP END FUNCTION '**************************************************************************************** FUNCTION TLSPushPop( hCrypt AS LONG, sErr AS STRING, sReply AS STRING, sSend AS STRING ) AS LONG STATIC k, RetVal, BytesSent, BytesReply, Last, Totms AS LONG STATIC pByte AS BYTE PTR STATIC sBuff AS STRING IF LEN(sSend) < 1 THEN sErr = "No data sent" : FUNCTION = -21 : EXIT FUNCTION ' IF LEN(sBuff) = 0 THEN sBuff = NUL$(256) ' Create buffer '- Trap unexpected returns RetVal = CryptPopData( hCrypt, STRPTR(sBuff), LEN(sBuff), VARPTR(BytesReply) ) IF RetVal <> %CRYPT_OK THEN sErr = "CryptPopData ERROR: "+Err2Str(RetVal) FUNCTION = -22 : EXIT FUNCTION ELSEIF BytesReply > 0 THEN sErr = "ERROR:"+STR$(LEN(BytesReply))+" unexpected bytes in buffer: "+ LEFT$(sBuff, BytesReply) FUNCTION = -23 : EXIT FUNCTION END IF ' '- Push data PRINT #hDbg, "Sent:" + STR$(LEN(sSend)) + " Bytes: " + PARSE$(sSend, $CRLF, 1) RetVal = CryptPushData( hCrypt, STRPTR(sSend), LEN(sSend), VARPTR(BytesSent) ) IF RetVal <> %CRYPT_OK THEN sErr = "CryptPushData ERROR "+Err2Str(RetVal) : FUNCTION = -24 : EXIT FUNCTION IF LEN(sSend) <> BytesSent THEN sErr = "LEN(sSend)="+STR$(LEN(sSend))+", BytesSent="+STR$(BytesSent) : FUNCTION = -24 : EXIT FUNCTION '- Flush outgoing data RetVal = CryptFlushData(hCrypt) IF RetVal <> %CRYPT_OK THEN sErr = "CryptFlushData ERROR "+Err2Str(RetVal) : FUNCTION = -25 : EXIT FUNCTION '- Recover response sReply = "" Totms = 0 DO SLEEP 20 ' Wait for a response Totms = Totms + 20 ' IF Totms > %SMTP_RESPONSE_TIMEOUT THEN sErr = "Response timeout >" + STR$(%SMTP_RESPONSE_TIMEOUT) + "m/s" FUNCTION = -27 : EXIT FUNCTION END IF ' PRINT #hDbg, STR$(Totms) + "m/s" RetVal = CryptPopData( hCrypt, STRPTR(sBuff), LEN(sBuff), VARPTR(BytesReply) ) IF RetVal <> %CRYPT_OK THEN sErr = "CryptPopData ERROR "+Err2Str(RetVal) : FUNCTION = -29 : EXIT FUNCTION IF BytesReply > 0 THEN sReply = sReply + LEFT$(sBuff, BytesReply) ' Last = LEN(sReply) ' PRINT #hDbg, "Rply:" + STR$(BytesReply) + " Bytes: " + LEFT$(sBuff, BytesReply) pByte = STRPTR(sReply) ' Check last line for SMTP code follwed by space IF Last > 7 AND @pByte[Last-1] = 10 AND @pByte[Last-2] = 13 THEN ' CRLF FOR k = 3 TO Last ' PRINT #hDbg, "CharNum=" + STR$(Last-k+1) + ", " + CHR$(@pByte[Last-k]) IF @pByte[Last-k] = 10 AND @pByte[Last-k+4] = 32 THEN EXIT DO ' Space not a hyphen "-", Response complete IF k = last AND @pByte[Last-k+3] = 32 THEN EXIT DO ' Space not a hyphen "-", Response complete NEXT END IF END IF LOOP ' PRINT #hDbg, BytesToHexPtr( STRPTR(sBuff), BytesReply ) FUNCTION = VAL(sReply) ' PRINT #hDbg, "----------------------" END FUNCTION '**************************************************************************************** FUNCTION SendGmail( sSrvr AS STRING,_ sUser AS STRING,_ sPass AS STRING,_ sFrom AS STRING,_ sTo AS STRING,_ sBody AS STRING,_ sRet AS STRING ) AS LONG ' Returns 1 = message sent ' -ve = Error (sRet = error description) LOCAL RetVal, hSess, BytesReply AS LONG LOCAL sReply, sEnc, sErr AS STRING IF LEN(sSrvr) = 0 OR LEN(sUser) = 0 OR LEN(sPass) = 0 OR LEN(sFrom) = 0 OR LEN(sTo) = 0 OR LEN(sBody) = 0 THEN sRet = "A required parameter string is missing" FUNCTION = -1 EXIT FUNCTION END IF ' Initialize the Library RetVal = CryptInit() IF RetVal <> %CRYPT_OK THEN sRet = Err2Str(RetVal) : FUNCTION = -2 : EXIT FUNCTION DO ' Create the session RetVal = CryptCreateSession( VARPTR(hSess), %CRYPT_UNUSED, %CRYPT_SESSION_SSL ) IF RetVal <> %CRYPT_OK THEN sRet = Err2Str(RetVal) : FUNCTION = -4 : EXIT DO ' Add the server name "smtp.gmail.com" RetVal = CryptSetAttributeString( hSess, %CRYPT_SESSINFO_SERVER_NAME, STRPTR(sSrvr), LEN(sSrvr) ) IF RetVal <> %CRYPT_OK THEN sRet = Err2Str(RetVal) : FUNCTION = -6 : EXIT DO ' Specify the Port RetVal = CryptSetAttribute( hSess, %CRYPT_SESSINFO_SERVER_PORT, 465 ) IF RetVal <> %CRYPT_OK THEN sRet = Err2Str(RetVal) : FUNCTION = -8 : EXIT DO ' Activate the session RetVal = CryptSetAttribute( hSess, %CRYPT_SESSINFO_ACTIVE, 1 ) IF RetVal <> %CRYPT_OK THEN sRet = Err2Str(RetVal) : FUNCTION = -9 : EXIT DO ' Remove any response created by connecting sReply = NUL$(255) RetVal = CryptPopData( hSess, STRPTR(sReply), LEN(sReply), VARPTR(BytesReply) ) IF RetVal <> %CRYPT_OK THEN sErr = "CryptPopData1 ERROR "+Err2Str(RetVal) : FUNCTION = -10 : EXIT DO ' MIME dialog RetVal = TLSPushPop(hSess, sErr, sReply, "EHLO " + $CRLF) ' IF RetVal <> 250 THEN sRet = "EHLO Failed: "+sErr : FUNCTION = -11 : EXIT DO RetVal = TLSPushPop(hSess, sErr, sReply, "AUTH LOGIN " + $CRLF) ' IF RetVal <> 334 THEN sRet = "AUTH Failed: "+sErr : FUNCTION = -12 : EXIT DO RetVal = TLSPushPop(hSess, sErr, sReply, MimeEncode(sUser) + $CRLF) ' Username IF RetVal <> 334 THEN sRet = "user Failed: "+sErr : FUNCTION = -13 : EXIT DO RetVal = TLSPushPop(hSess, sErr, sReply, MimeEncode(sPass) + $CRLF) ' Password IF RetVal <> 235 THEN sRet = "pass Failed: "+sErr : FUNCTION = -14 : EXIT DO RetVal = TLSPushPop(hSess, sErr, sReply, "MAIL FROM: <" + sFrom + ">" + $CRLF) ' Sender IF RetVal <> 250 THEN sRet = "MAIL FROM Failed: "+sErr : FUNCTION = -15 : EXIT DO RetVal = TLSPushPop(hSess, sErr, sReply, "RCPT TO: <" + sTo + ">" + $CRLF) ' Recipient IF RetVal <> 250 THEN sRet = "RCPT TO Failed: "+sErr : FUNCTION = -16 : EXIT DO RetVal = TLSPushPop(hSess, sErr, sReply, "DATA " + $CRLF) ' Body begins IF RetVal <> 354 THEN sRet = "DATA Failed: "+sErr : FUNCTION = -17 : EXIT DO RetVal = TLSPushPop(hSess, sErr, sReply, sBody + $CRLF + "." + $CRLF) ' Body IF RetVal <> 250 THEN sRet = "body Failed: "+sErr : FUNCTION = -18 : EXIT DO FUNCTION = 1 ' 250 2.0.0 OK - Message sent RetVal = TLSPushPop(hSess, sErr, sReply, "QUIT " + $CRLF) ' Terminate MIME IF RetVal <> 221 THEN sRet = "QUIT Failed: "+sErr : FUNCTION = -19 : EXIT DO EXIT LOOP ' done LOOP IF hSess THEN CALL CryptDestroySession(hSess) ' Close the session CALL CryptEnd() ' Close the Library END FUNCTION '**************************************************************************************** FUNCTION PBMAIN() LOCAL RetVal AS LONG LOCAL sBody, sRet AS STRING hDbg = FREEFILE : OPEN $DEBUG_FILE FOR OUTPUT LOCK SHARED AS hDbg ' PRINT #hDbg, "-------- "+DATE$+" "+TIME$+" ---------" sBody = "" sBody = sBody + "From: " + $MailFrom + $CRLF sBody = sBody + "To: " + $MailTo + $CRLF sBody = sBody + "Subject: " + "Gmail Test using TLS Encryption" + $CRLF + $CRLF sBody = sBody + "Dear John, this email is brought to you courtesy of cryptlib" RetVal = SendGmail( "smtp.gmail.com", $UserName, $Password, $MailFrom, $MailTo, sBody, sRet ) IF RetVal < 0 THEN PRINT #hDbg, "ERROR: "+sRet CLOSE #hDbg MSGBOX "DONE" END FUNCTION '**************************************************************************************** |