Penggunaan HsOpenSSL API yang tepat untuk mengimplementasikan Server TLS

Saya mencoba mencari cara untuk menggunakan API OpenSSL.Session dengan benar dalam konteks bersamaan

Misalkan saya ingin mengimplementasikan stunnel-style ssl-wrapper, saya berharap memiliki struktur kerangka dasar berikut, yang mengimplementasikan naiffull-duplex tcp-port-forwarder:

runProxy :: PortID -> AddrInfo -> IO ()
runProxy localPort@(PortNumber lpn) serverAddrInfo = do
  listener <- listenOn localPort

  forever $ do
    (sClient, clientAddr) <- accept listener

    let finalize sServer = do
            sClose sServer
            sClose sClient

    forkIO $ do
        tidToServer <- myThreadId
        bracket (connectToServer serverAddrInfo) finalize $ \sServer -> do
            -- execute one 'copySocket' thread for each data direction
            -- and make sure that if one direction dies, the other gets
            -- pulled down as well
            bracket (forkIO (copySocket sServer sClient
                             `finally` killThread tidToServer))
                    (killThread) $ \_ -> do
                copySocket sClient sServer -- "controlling" thread

 where
  -- |Copy data from source to dest until EOF occurs on source
  -- Copying may also be aborted due to exceptions
  copySocket :: Socket -> Socket -> IO ()
  copySocket src dst = go
   where
    go = do
        buf <- B.recv src 4096
        unless (B.null buf) $ do
            B.sendAll dst buf
            go

  -- |Create connection to given AddrInfo target and return socket
  connectToServer saddr = do
    sServer <- socket (addrFamily saddr) Stream defaultProtocol
    connect sServer (addrAddress saddr)
    return sServer

Bagaimana cara mengubah kerangka di atas menjadi full-duplex ssl-wrapping tcp-forwarding proxy? Di mana bahaya WRT untuk eksekusi bersamaan / paralel (dalam konteks kasus penggunaan di atas) dari pemanggilan fungsi yang disediakan oleh API HsOpenSSL?

PS: Saya masih berjuang untuk sepenuhnya memahami bagaimana membuat kode yang kuat untuk pengecualian dan kebocoran sumber daya. Jadi, meskipun tidak menjadi fokus utama dari pertanyaan ini, jika Anda melihat sesuatu yang buruk dalam kode di atas, silakan tinggalkan komentar.

Untuk melakukan ini, Anda perlu mengganti copySocketdengan dua fungsi berbeda, satu untuk menangani data dari soket biasa ke SSL dan yang lainnya dari SSL ke soket biasa:

  copyIn :: SSL.SSL -> Socket -> IO ()
  copyIn src dst = go
   where
    go = do
        buf <- SSL.read src 4096
        unless (B.null buf) $ do
            SB.sendAll dst buf
            go

  copyOut :: Socket -> SSL.SSL -> IO ()
  copyOut src dst = go
   where
    go = do
        buf <- SB.recv src 4096
        unless (B.null buf) $ do
            SSL.write dst buf
            go

Maka Anda perlu memodifikasi connectToServersehingga membangun koneksi SSL

  -- |Create connection to given AddrInfo target and return socket
  connectToServer saddr = do
    sServer <- socket (addrFamily saddr) Stream defaultProtocol
    putStrLn "connecting"
    connect sServer (addrAddress saddr)
    putStrLn "establishing ssl context"
    ctx <- SSL.context
    putStrLn "setting ciphers"
    SSL.contextSetCiphers ctx "DEFAULT"
    putStrLn "setting verfication mode"
    SSL.contextSetVerificationMode ctx SSL.VerifyNone
    putStrLn "making ssl connection"
    sslServer <- SSL.connection ctx sServer
    putStrLn "doing handshake"
    SSL.connect sslServer
    putStrLn "connected"
    return sslServer

dan ubah finalizeuntuk mematikan sesi SSL

let finalize sServer = do
        putStrLn "shutting down ssl"
        SSL.shutdown sServer SSL.Unidirectional
        putStrLn "closing server socket"
        maybe (return ()) sClose (SSL.sslSocket sServer)
        putStrLn "closing client socket"
        sClose sClient

Akhirnya, jangan lupa untuk menjalankan hal-hal utama Anda withOpenSSLseperti di dalam

main = withOpenSSL $ do
    let hints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }
    addrs <- getAddrInfo (Just hints) (Just "localhost") (Just "22222")
    let addr = head addrs
    print addr
    runProxy (PortNumber 11111) addr