使用tls-extra进行简单的smtp

Question

我正在尝试编写一个简单的脚本来通过我的Gmail帐户发送邮件.但我是一个初学者,所以它并不那么简单.我尝试谷歌,但为了hackage,没有任何帮助或例子.

问题是我没有找到使用tls-extra(或tls)来启动STARTTLS交换的方法.

好的,这是代码:

import Network
import Network.TLS.Extra
import System.IO
import Text.Printf

server = "smtp.gmail.com"
port   = 25 --that has to chage, I think

forever a = a >> forever a

main = test1

write :: Handle -> String -> IO ()
write h s  = do
    hPrintf h "%s\r\n" s
    printf    "> %s\n" s

listen :: Handle -> IO () 
listen h = forever $ hGetLine h >>= putStrLn

test1 = do h <- connectTo server (PortNumber (fromIntegral port))
           hSetBuffering h NoBuffering
           write h "EHLO"
           write h "STARTTLS"
           listen h

另一件事是我使用listen函数来了解发生了什么.但我无法弄清楚如何使用它与写.也就是说,我希望能够在发送一些数据时看到服务器端的内容.

我找到了两个可以解决我的问题的函数:

connectionClient :: CryptoRandomGen g => String -> String -> TLSParams -> g -> IO (TLSCtx Handle)
forkIO :: IO () -> IO ThreadId

第一个用于tls,第二个用于同时发送和接收.但似乎无法使它们发挥作用.

我希望我不要在这里凌乱,任何帮助都会受到赞赏.

PS:英语不是我的母语.

编辑:所以,我取得了一些进展.

import Network
import Network.TLS
import Network.TLS.Extra
import System.IO
import Text.Printf
import Control.Monad (forever)
import Control.Concurrent (threadDelay)
import qualified Data.ByteString.Char8 as B
import Crypto.Random

serv :: String
serv = "smtp.gmail.com"
port :: Int
port   = 25 --that has to chage, I think

main :: IO ()
main = test1

write :: Handle -> String -> IO ()
write h s  = do
    hPrintf h "%s\r\n" s
    printf    "> %s\n" s

listen :: Handle -> IO ()
listen h = forever $ hGetLine h >>= putStrLn

printSock :: Handle -> String -> IO ()
printSock h s = do write h s
                   hGetLine h >>= putStrLn
                   threadDelay 25

params :: TLSParams
params=defaultParams {pConnectVersion=TLS12
                     ,pAllowedVersions=[TLS10, TLS11, TLS12]
                     ,pCiphers=ciphersuite_all}

test1 = do h <- connectTo serv (PortNumber (fromIntegral port))
           hSetBuffering h NoBuffering
           printSock h "EHLO"
           printSock h "STARTTLS"
           --google waits for tls handshake
           --the problem is from here
           g <- newGenIO :: IO SystemRandom
           tlsH <- client params g h
           handshake tlsH --the handshake is failling

不过,我无法弄清楚如何协商那次握手.

我不得不说,我对缺乏答案感到非常惊讶.其他几次我遇到了问题,社区很快就帮忙了.但这似乎并不是强调(只是一个常设).在SO,甚至在#haskell或developpez.com.

无论如何,谷歌和tls的一些指针将受到欢迎.我看了一下msmtp客户端代码,但坦率地说我没有所需的级别.

Answer 1

您可以使用连接包来简化客户端连接并为此提供所有必需的位.以下代码将用于连接到smtp.gmail.com:

{-# LANGUAGE OverloadedStrings #-}
import qualified Data.ByteString as B
import Data.ByteString.Char8 ()
import Network.Connection
import Data.Default

readHeader con = do
    l <- connectionGetLine 1024 con
    putStrLn $ show l
    if B.isPrefixOf "250 " l
        then return ()
        else readHeader con

main = do
    ctx <- initConnectionContext
    con <- connectTo ctx $ ConnectionParams
                            { connectionHostname  = "smtp.gmail.com"
                            , connectionPort      = 25
                            , connectionUseSecure = Nothing
                            , connectionUseSocks  = Nothing
                            }

    -- read the server banner
    connectionGetLine 1024 con >>= putStrLn . show
    -- say ehlo to the smtp server
    connectionPut con "EHLO\n"
    -- wait for a reply and print
    readHeader con
    -- Tell the server to start a TLS context.
    connectionPut con "STARTTLS\n"
    -- wait for a reply and print
    connectionGetLine 1024 con >>= putStrLn . show

    -- negociate the TLS context
    connectionSetSecure ctx con def

    ------- connection is secure now
    -- send credential, passwords, ask question, etc.

    -- then quit politely.
    connectionPut con "QUIT\n"
    connectionClose con