How do I add TLS encryption to this TCP server?

Question

I've built a TCP server for a project and it's working fine, but it's time to add TLS. I tried Network.Simple.TCP.TLS, but when I went to integrate it into my larger project, I got some dependency conflicts that I couldn't resolve.

The code here is the simplified test server that I'll later integrate into the larger project. I hope this doesn't hide any important details.

Here's a working echo server without TLS:

import Control.Concurrent
import Network.Socket
import System.IO

main :: IO ()
main = do
  let port = 4653
  sock <- socket AF_INET Stream 0
  setSocketOption sock ReuseAddr 1
  bindSocket sock (SockAddrInet (fromInteger port) iNADDR_ANY)
  putStrLn $ "Listening on port " ++ show port
  listen sock 2
  mainLoop sock


mainLoop :: Socket -> IO ()
mainLoop sock = do
  conn <- accept sock
  _ <- forkIO $ runConn conn
  mainLoop sock


runConn :: (Socket, SockAddr) -> IO ()
runConn (sock, _) = do
  hdl <- socketToHandle sock ReadWriteMode
  hSetBuffering hdl NoBuffering

  request <- hGetLine hdl 
  hPrint hdl request

  hClose hdl

This is my attempt at TLS integration:

{-# LANGUAGE OverloadedStrings #-}

import Control.Concurrent
import qualified Crypto.Random.AESCtr       as AESCtr
import qualified Data.ByteString.Char8      as BSC
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Default.Class (def)
import Network.Socket
import qualified Network.TLS                as T
import qualified Network.TLS.Extra          as TE
import System.IO

main :: IO ()
main = do
  let port = 4653

  cred <- credentials
  let creds = case cred of
                Right c -> T.Credentials [c]
                Left e -> error e

  sock <- socket AF_INET Stream 0
  setSocketOption sock ReuseAddr 1
  bindSocket sock (SockAddrInet (fromInteger port) iNADDR_ANY)
  putStrLn $ "Listening on port " ++ show port
  listen sock 2
  mainLoop sock creds


mainLoop :: Socket -> T.Credentials -> IO ()
mainLoop sock creds = do
  conn <- accept sock
  _ <- forkIO $ runConn creds conn
  mainLoop sock creds


runConn :: T.Credentials -> (Socket, SockAddr) -> IO ()
runConn creds (sock, _) = do
  hdl <- socketToHandle sock ReadWriteMode
  hSetBuffering hdl NoBuffering

  ctx <- context creds hdl
  T.handshake ctx

  request <- T.recvData ctx
  T.sendData ctx (LBS.fromChunks [request])

  hClose hdl


context :: T.Credentials -> Handle -> IO T.Context
context creds hdl = T.contextNew (sockBackend hdl) (sockParams creds) =<< AESCtr.makeSystem


credentials :: IO (Either String T.Credential)
credentials = T.credentialLoadX509 "cert/server.crt" "cert/server.key"

sockBackend :: Handle -> T.Backend
sockBackend hdl = T.Backend { T.backendFlush = hFlush hdl
                            , T.backendClose = hClose hdl
                            , T.backendSend  = hPrint hdl
                            , T.backendRecv  = hRecv hdl BSC.empty
                            }


hRecv :: Handle -> BSC.ByteString -> Int -> IO BSC.ByteString
hRecv _ ack 0 = return ack
hRecv hdl ack n = do
  c <- hGetChar hdl
  hRecv hdl (ack `BSC.append` BSC.pack [c]) (n - 1)


sockParams :: T.Credentials -> T.ServerParams
sockParams creds = def { T.serverWantClientCert = False
                       , T.serverShared         = shared creds
                       , T.serverSupported      = supported
                       }

shared :: T.Credentials -> T.Shared
shared creds = def { T.sharedCredentials    = creds
                   }


supported :: T.Supported
supported = def { T.supportedVersions = [T.TLS10, T.TLS11, T.TLS12]
                , T.supportedCiphers  = ciphers
                }

ciphers :: [T.Cipher]
ciphers =
    [ TE.cipher_AES128_SHA1
    , TE.cipher_AES256_SHA1
    , TE.cipher_RC4_128_MD5
    , TE.cipher_RC4_128_SHA1
    ]

It compiles and runs, but whenever I try to hit it, it prints this error:

Main.hs: ConnectionNotEstablished

I'm feeling rather out of my depth here. Can anyone point me at the problem or a better way to add TLS encryption to this server?

EDIT: I found part of my problem. I was missing the T.handshake call. Now I'm having trouble connecting from the client. I'll update again if I get this running cleanly.

EDIT2: The new error, by the way, is:

HandshakeFailed (Error_Packet_Parsing "Failed reading: invalid header type: 34\nFrom:\theader\n\n")

I've found this error in a few places on the web, but I've yet to see an answer attached to it.

Answer 1

As I mentioned in the first edit to my question, I was originally missing the handshake call. That wasn't enough to fix this. Ultimately, I found that I could just pass the sock as the backend without mucking around creating an instance of Backend by hand. When I switched to that method, this started working with the Python client included below.

Haskell Server:

{-# LANGUAGE OverloadedStrings #-}

import Control.Applicative
import Control.Concurrent
import Control.Monad (void)
import qualified Crypto.Random.AESCtr       as AESCtr
import qualified Data.ByteString.Char8      as BSC 
import qualified Data.ByteString.Lazy.Char8 as LBS 
import Data.Default.Class (def)
import Network.Socket
import qualified Network.TLS                as T
import qualified Network.TLS.Extra          as TE

main :: IO ()
main = do
  let port = 4653

  cred <- credentials
  let creds = case cred of
                Right c -> T.Credentials [c] 
                Left e -> error e

  sock <- socket AF_INET Stream 0
  setSocketOption sock ReuseAddr 1
  bindSocket sock (SockAddrInet (fromInteger port) iNADDR_ANY)
  putStrLn $ "Listening on port " ++ show port
  listen sock 2
  mainLoop sock creds


mainLoop :: Socket -> T.Credentials -> IO ()
mainLoop sock creds = do
  conn <- accept sock
  _ <- forkIO $ runConn creds conn
  mainLoop sock creds


runConn :: T.Credentials -> (Socket, SockAddr) -> IO ()
runConn creds (sock, _) = do

  ctx <- T.contextNew sock (sockParams creds) =<< AESCtr.makeSystem
  T.handshake ctx 

  request <- T.recvData ctx
  print request
  T.sendData ctx (LBS.fromChunks [request])

  T.contextClose ctx


credentials :: IO (Either String T.Credential)
credentials = T.credentialLoadX509 "cert/server.crt" "cert/server.key"

sockParams :: T.Credentials -> T.ServerParams
sockParams creds = def { T.serverWantClientCert = False
                       , T.serverShared         = shared creds
                       , T.serverSupported      = supported
                       }

shared :: T.Credentials -> T.Shared
shared creds = def { T.sharedCredentials    = creds
                   }


supported :: T.Supported
supported = def { T.supportedVersions = [T.TLS10]
                , T.supportedCiphers = ciphers
                }


ciphers :: [T.Cipher]
ciphers =
    [ TE.cipher_AES128_SHA1
    , TE.cipher_AES256_SHA1
    , TE.cipher_RC4_128_MD5
    , TE.cipher_RC4_128_SHA1
    ]

Python Client:

# Echo client program
import socket
import json
import ssl 

def recv_all(s):
    buf = 4096
    data = ''
    chunk = s.recv(buf)
    while len(chunk) > 0:
        data = data + chunk
        chunk = s.recv(buf)
    return data

def main():
    HOST = '127.0.0.1'    # The remote host
    PORT = 4653              # The same port as used by the server
    s = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
    ss = ssl.wrap_socket(s, ssl_version=ssl.PROTOCOL_TLSv1, do_handshake_on_connect=False)
    ss.connect((HOST, PORT))
    ss.do_handshake()
    ss.sendall('Hello, world\r\n')

    data = recv_all(ss)

    s.close()
    print("Received %s" % data)


if __name__ == "__main__":
    main()

EDIT: Per my comments below, the server above cuts off inputs greater than 16k. My current solution is to sub out T.recvData above with the recvAll method below:

recvAll :: T.Context -> IO BSC.ByteString 
recvAll ctx = go BSC.empty
  where go acc = do
          pkt <- T.recvData ctx 
          print $ BSC.length pkt 
          if BSC.length pkt == 16384
            then go $ acc <> pkt 
              else return $ acc <> pkt

This function has some real shortcomings! Most notably, if you actually have a packet that is exactly 16k (or any multiple thereof) this will spin forever!