Utilisation correcte de l'API HsOpenSSL pour mettre en œuvre un serveur TLS

Question

J'essaie de comprendre comment utiliser correctement la fonction OpenSSL.Session API dans un contexte concurrent

Par exemple, supposons que je veuille mettre en œuvre un stunnel-style ssl-wrapper Je m'attends à ce qu'il y ait la structure de base suivante, qui met en œuvre une fonction naïve de 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

Comment transformer le squelette ci-dessus en un fichier full-duplex ssl-wrapping tcp-forwarding proxy ? Quels sont les dangers liés à l'exécution concurrente/parallèle (dans le contexte du cas d'utilisation susmentionné) des appels de fonction fournis par l'API HsOpenSSL ?

PS : J'ai encore du mal à comprendre comment rendre le code robuste en ce qui concerne les exceptions et les fuites de ressources. Donc, bien que ce ne soit pas le but premier de cette question, si vous remarquez quelque chose de mauvais dans le code ci-dessus, merci de laisser un commentaire.

Answer 1

Pour ce faire, vous devez remplacer copySocket avec deux fonctions différentes, l'une pour gérer les données de la socket ordinaire vers SSL et l'autre de SSL vers la socket ordinaire :

  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

Vous devez alors modifier connectToServer afin qu'il établisse une connexion 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

et le changement finalize pour fermer la session 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

Enfin, n'oubliez pas d'exécuter vos principaux éléments dans la rubrique withOpenSSL comme dans

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