Skip to content

Instantly share code, notes, and snippets.

@kazu-yamamoto
Last active November 1, 2019 05:27
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save kazu-yamamoto/6410e5e4bb0c1945c15ab3d7bbf40121 to your computer and use it in GitHub Desktop.
Using QUIC APIs in Haskell TLS
{-# 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
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment