El uso adecuado de la API HsOpenSSL para implementar un servidor TLS

Question

Estoy tratando de encontrar la manera de utilizar correctamente la API OpenSSL.Session en un contexto concurrente

P. ej Asumo que quiero implementar un stunnel-style ssl-wrapper, me gustaría esperar a tener la siguiente estructura de esqueleto básico, que implementa una ingenua full-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 

¿Cómo transformar el esqueleto anterior en un full-duplex ssl-wrapping tcp-forwarding proxy? ¿Dónde están los peligros W.R.T a la ejecución simultánea/paralela (en el contexto del caso de uso anterior) de las llamadas a funciones proporcionadas por la API HsOpenSSL?

PD: Todavía estoy luchando por comprender por completo cómo hacer que el código sea robusto w.r.t. a excepciones y pérdidas de recursos. Entonces, aunque no sea el foco principal de esta pregunta, si nota algo malo en el código anterior, por favor deje un comentario.

Answer 1

Para hacer esto es necesario sustituir copySocket, con dos funciones diferentes, uno para manejar los datos de la toma de llanura de SSL y la otra de SSL para la toma de llanura:

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 

Luego hay que modificar connectToServer para que establezca una conexión 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 

y cambiar finalize de cerrar la sesión 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 

Por último, no se olvide de ejecutar su materia principal dentro withOpenSSL como en

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