Using QUIC APIs in Haskell TLS

quic-tls.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Concurrent
import Control.Monad
import Data.ByteString hiding (putStrLn)
import Data.Default.Class
import Network.TLS
import Network.TLS.Extra.Cipher
import Network.TLS.QUIC
import System.Environment

main :: IO ()
main = do
    [cert,key] <- getArgs
    (toServer, fromServer, toClient, fromClient) <- newPipe
    void $ forkIO $ server toClient fromClient cert key
    client toServer fromServer
    threadDelay 1000000

newPipe :: IO (ByteString -> IO (), IO ByteString
              ,ByteString -> IO (), IO ByteString)
newPipe = do
    c2s <- newChan
    s2c <- newChan
    let toServer   = writeChan c2s
        fromServer = readChan  s2c
    let toClient   = writeChan s2c
        fromClient = readChan  c2s
    return (toServer, fromServer, toClient, fromClient)

server :: (ByteString -> IO ()) -> IO ByteString
       -> FilePath -> FilePath
       -> IO ()
server toClient fromClient cert key = do
    serverControl <- tlsServerController cert key
    ch <- fromClient
    state <- serverControl $ PutClientHello ch
    sh <- case state of
      SendRequestRetry hrr -> do
          putStrLn "S: retry requested"
          toClient hrr
          ch1 <- fromClient
          SendServerHello sh0 exts cipher _ _ <- serverControl $ PutClientHello ch1
          putStrLn $ "S: Cipher = " ++ show cipher
          putStrLn $ "S: Client exts = " ++ show exts
          return sh0
      SendServerHello sh0 exts cipher _ _ -> do
          putStrLn $ "S: Cipher = " ++ show cipher
          putStrLn $ "S: Client exts = " ++ show exts
          return sh0
      _ -> error "server"
    toClient sh
    SendServerFinished sf alpn _ <- serverControl GetServerFinished
    putStrLn $ "S: ALPN = " ++ show alpn
    toClient sf
    cf <- fromClient
    SendSessionTicket nst <- serverControl $ PutClientFinished cf
    toClient nst
    void $ serverControl ExitServer
    putStrLn "S: handshake done"

client :: (ByteString -> IO ()) -> IO ByteString -> IO ()
client toServer fromServer = do
    clientControl <- tlsClientController "127.0.0.1" (return $ Just ["hq","h3"])
    SendClientHello ch _  <- clientControl GetClientHello
    toServer ch
    hrrOrSh <- fromServer
    state <- clientControl $ PutServerHello hrrOrSh
    case state of
      SendClientHello ch1 _ -> do
          putStrLn "C: retry tried"
          toServer ch1
          sh1 <- fromServer
          RecvServerHello cipher _ <- clientControl $ PutServerHello sh1
          putStrLn $ "C: Cipher = " ++ show cipher
      RecvServerHello cipher _ -> do
          putStrLn $ "C: Cipher = " ++ show cipher
      s1 -> error $ show s1
    sf <- fromServer
    SendClientFinished cf exts alpn _ <- clientControl $ PutServerFinished sf
    putStrLn $ "C: ALPN = " ++ show alpn
    putStrLn $ "S: Server exts = " ++ show exts
    toServer cf
    nst <- fromServer
    RecvSessionTicket <- clientControl $ PutSessionTicket nst
    void $ clientControl ExitClient
    putStrLn "C: handshake done"

tlsServerController :: FilePath -> FilePath -> IO ServerController
tlsServerController cert key = do
    Right cred <- credentialLoadX509 cert key
    let sshared = def {
            sharedCredentials = Credentials [cred]
          , sharedExtensions  = [ExtensionRaw extensionID_QuicTransportParameters "from server"]
          }
    let sparams = def {
        serverHooks     = hook
      , serverSupported = supported
      , serverShared    = sshared
      , serverDebug     = debug
      }
    newQUICServer sparams
  where
    supported = def {
        supportedVersions = [TLS13]
      , supportedCiphers  = ciphersuite_strong
      , supportedGroups   = [P256]
      }
    hook = def {
        onALPNClientSuggest = Just (\_ -> return "h3")
      }
    debug = def {
        debugKeyLogger = \msg -> putStrLn $ "S: " ++ msg
      }

tlsClientController :: String -> IO (Maybe [ByteString]) -> IO ClientController
tlsClientController serverName suggestALPN =
    newQUICClient cparams
  where
    cparams = (defaultParamsClient serverName "") {
        clientHooks     = hook
      , clientShared    = cshared
      , clientSupported = supported
      , clientDebug     = debug
      }
    hook = def {
        onSuggestALPN = suggestALPN
      }
    cshared = def {
        sharedValidationCache = ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ())
      , sharedSessionManager = SessionManager {
            sessionEstablish      = \_ _ -> putStrLn "C: new session ticket received"
          , sessionResume         = \_ -> return Nothing
          , sessionResumeOnlyOnce = \_ -> return Nothing
          , sessionInvalidate     = \_ -> return ()
          }
      , sharedExtensions  = [ExtensionRaw extensionID_QuicTransportParameters "from client"]
      }
    supported = def {
        supportedVersions = [TLS13]
      , supportedCiphers = ciphersuite_strong
      }
    debug = def {
        debugKeyLogger = \msg -> putStrLn $ "C: " ++ msg
      }