tls 2.0.3 → 2.0.4
raw patch · 9 files changed
+661/−1128 lines, 9 filesdep +network-rundep +unliftio
Dependencies added: network-run, unliftio
Files
- CHANGELOG.md +5/−0
- Network/TLS/Core.hs +105/−58
- tls.cabal +9/−5
- util/Client.hs +44/−0
- util/Common.hs +38/−42
- util/HexDump.hs +0/−96
- util/Server.hs +55/−0
- util/tls-client.hs +290/−477
- util/tls-server.hs +115/−450
CHANGELOG.md view
@@ -1,3 +1,8 @@+## Version 2.0.4++* More fix for 0-RTT when application data is available while receiving CF.+* New util/tls-client and util/tls-server.+ ## Version 2.0.3 * Fixing a bug where `timeout` in `bye` does not work.
Network/TLS/Core.hs view
@@ -111,7 +111,7 @@ rtt <- getRTT ctx var <- newEmptyMVar _ <- forkIOWithUnmask $ \umask ->- umask (void $ timeout rtt $ recvData13 ctx chk) `E.finally` putMVar var ()+ umask (void $ timeout rtt $ recvHS13 ctx chk) `E.finally` putMVar var () takeMVar var else do -- receiving Client Finished@@ -123,7 +123,7 @@ let rtt = 1000000 var <- newEmptyMVar _ <- forkIOWithUnmask $ \umask ->- umask (void $ timeout rtt $ recvData13 ctx chk) `E.finally` putMVar var ()+ umask (void $ timeout rtt $ recvHS13 ctx chk) `E.finally` putMVar var () takeMVar var bye_ ctx @@ -202,12 +202,12 @@ -- Even when recvData12/recvData13 loops, we only need to call function -- checkValid once. Since we hold the read lock, no concurrent call -- will impact the validity of the context.- if tls13 then recvData13 ctx (return False) else recvData12 ctx+ if tls13 then recvData13 ctx else recvData12 ctx recvData12 :: Context -> IO B.ByteString recvData12 ctx = do pkt <- recvPacket12 ctx- either (onError terminate) process pkt+ either (onError terminate12) process pkt where process (Handshake [ch@ClientHello{}]) = handshakeWith ctx ch >> recvData12 ctx@@ -231,17 +231,17 @@ process (AppData x) = return x process p = let reason = "unexpected message " ++ show p- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ in terminate12 (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - terminate = terminateWithWriteLock ctx (sendPacket12 ctx . Alert)+ terminate12 = terminateWithWriteLock ctx (sendPacket12 ctx . Alert) -recvData13 :: Context -> IO Bool -> IO B.ByteString-recvData13 ctx breakLoop = do+recvData13 :: Context -> IO B.ByteString+recvData13 ctx = do mdat <- tls13stPendingRecvData <$> getTLS13State ctx case mdat of Nothing -> do pkt <- recvPacket13 ctx- either (onError terminate) process pkt+ either (onError (terminate13 ctx)) process pkt Just dat -> do modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Nothing} return dat@@ -259,14 +259,9 @@ ) process (Handshake13 hs) = do loopHandshake13 hs- stop <- breakLoop- if stop- then- return ""- else- recvData13 ctx breakLoop+ recvData13 ctx -- when receiving empty appdata, we just retry to get some data.- process (AppData13 "") = recvData13 ctx breakLoop+ process (AppData13 "") = recvData13 ctx process (AppData13 x) = do let chunkLen = C8.length x established <- ctxEstablished ctx@@ -277,26 +272,26 @@ return x | otherwise -> let reason = "early data overflow"- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason EarlyDataNotAllowed n | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1)- recvData13 ctx breakLoop -- ignore "x"+ recvData13 ctx -- ignore "x" | otherwise -> let reason = "early data deprotect overflow"- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Established -> return x _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage process ChangeCipherSpec13 = do established <- ctxEstablished ctx if established /= Established- then recvData13 ctx breakLoop+ then recvData13 ctx else do let reason = "CSS after Finished"- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason process p = let reason = "unexpected message " ++ show p- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time.@@ -305,7 +300,7 @@ role <- usingState_ ctx S.getRole unless (role == ClientRole) $ let reason = "Session ticket is allowed for client only"- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- This part is similar to handshake code, so protected with -- read+write locks (which is also what we use for all calls to the -- session manager).@@ -328,8 +323,8 @@ loopHandshake13 (KeyUpdate13 mode : hs) = do when (ctxQUICMode ctx) $ do let reason = "KeyUpdate is not allowed for QUIC"- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- checkAlignment hs+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ checkAlignment ctx hs established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says, -- unidirectional key update is legal.@@ -347,46 +342,98 @@ loopHandshake13 hs else do let reason = "received key update before established"- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason loopHandshake13 (h@CertRequest13{} : hs) = postHandshakeAuthWith ctx h >> loopHandshake13 hs loopHandshake13 (h@Certificate13{} : hs) = postHandshakeAuthWith ctx h >> loopHandshake13 hs loopHandshake13 (h : hs) = do- mPendingRecvAction <- popPendingRecvAction ctx- case mPendingRecvAction of- Nothing ->- let reason = "unexpected handshake message " ++ show h- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- Just action -> do- -- Pending actions are executed with read+write locks, just- -- like regular handshake code.- withWriteLock ctx $- handleException ctx $ do- case action of- PendingRecvAction needAligned pa -> do- when needAligned $ checkAlignment hs- processHandshake13 ctx h- pa h- PendingRecvActionHash needAligned pa -> do- when needAligned $ checkAlignment hs- d <- transcriptHash ctx- processHandshake13 ctx h- pa d h- -- Client: after receiving SH, app data is coming.- -- this loop tries to receive it.- -- App key must be installed before receiving- -- the app data.- sendCFifNecessary ctx- loopHandshake13 hs+ cont <- popAction ctx h hs+ when cont $ loopHandshake13 hs - terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13)+recvHS13 :: Context -> IO Bool -> IO ()+recvHS13 ctx breakLoop = do+ pkt <- recvPacket13 ctx+ -- fixme: Left+ either (\_ -> return ()) process pkt+ where+ -- UserCanceled MUST be followed by a CloseNotify.+ process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx+ process (Alert13 [(AlertLevel_Fatal, _desc)]) = setEOF ctx+ process (Handshake13 hs) = do+ loopHandshake13 hs+ stop <- breakLoop+ unless stop $ recvHS13 ctx breakLoop+ process _ = recvHS13 ctx breakLoop - checkAlignment hs = do- complete <- isRecvComplete ctx- unless (complete && null hs) $- let reason = "received message not aligned with record boundary"- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ loopHandshake13 [] = return ()+ -- fixme: some implementations send multiple NST at the same time.+ -- Only the first one is used at this moment.+ loopHandshake13 (NewSessionTicket13 life add nonce label exts : hs) = do+ role <- usingState_ ctx S.getRole+ unless (role == ClientRole) $+ let reason = "Session ticket is allowed for client only"+ in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ -- This part is similar to handshake code, so protected with+ -- read+write locks (which is also what we use for all calls to the+ -- session manager).+ withWriteLock ctx $ do+ Just resumptionSecret <- usingHState ctx getTLS13ResumptionSecret+ (_, usedCipher, _, _) <- getTxRecordState ctx+ let choice = makeCipherChoice TLS13 usedCipher+ psk = derivePSK choice resumptionSecret nonce+ maxSize = case extensionLookup EID_EarlyData exts+ >>= extensionDecode MsgTNewSessionTicket of+ Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms+ _ -> 0+ life7d = min life 604800 -- 7 days max+ tinfo <- createTLS13TicketInfo life7d (Right add) Nothing+ sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk+ let label' = B.copy label+ void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata+ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}+ loopHandshake13 hs+ loopHandshake13 (h : hs) = do+ cont <- popAction ctx h hs+ when cont $ loopHandshake13 hs++terminate13+ :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a+terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13)++popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool+popAction ctx h hs = do+ mPendingRecvAction <- popPendingRecvAction ctx+ case mPendingRecvAction of+ Nothing -> return False+ Just action -> do+ -- Pending actions are executed with read+write locks, just+ -- like regular handshake code.+ withWriteLock ctx $+ handleException ctx $ do+ case action of+ PendingRecvAction needAligned pa -> do+ when needAligned $ checkAlignment ctx hs+ processHandshake13 ctx h+ pa h+ PendingRecvActionHash needAligned pa -> do+ when needAligned $ checkAlignment ctx hs+ d <- transcriptHash ctx+ processHandshake13 ctx h+ pa d h+ -- Client: after receiving SH, app data is coming.+ -- this loop tries to receive it.+ -- App key must be installed before receiving+ -- the app data.+ sendCFifNecessary ctx+ return True++checkAlignment :: Context -> [Handshake13] -> IO ()+checkAlignment ctx hs = do+ complete <- isRecvComplete ctx+ unless (complete && null hs) $+ let reason = "received message not aligned with record boundary"+ in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls-version: 2.0.3+version: 2.0.4 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -171,7 +171,7 @@ hs-source-dirs: util other-modules: Common- HexDump+ Server Imports default-language: Haskell2010@@ -186,7 +186,9 @@ crypton-x509-system, data-default-class, network,- tls+ network-run,+ tls,+ unliftio if flag(devel) @@ -197,8 +199,8 @@ main-is: tls-client.hs hs-source-dirs: util other-modules:+ Client Common- HexDump Imports default-language: Haskell2010@@ -212,7 +214,9 @@ crypton-x509-system, data-default-class, network,- tls+ network-run,+ tls,+ unliftio if flag(devel)
+ util/Client.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Client (+ Aux (..),+ Cli,+ client,+) where++import qualified Data.ByteString.Lazy.Char8 as CL8+import Network.Socket+import Network.TLS++import Imports++data Aux = Aux+ { auxAuthority :: HostName+ , auxPort :: ServiceName+ , auxDebug :: String -> IO ()+ , auxShow :: ByteString -> IO ()+ , auxReadResumptionData :: IO (Maybe (SessionID, SessionData))+ }++type Cli = Aux -> [ByteString] -> Context -> IO ()++client :: Cli+client Aux{..} paths ctx = do+ sendData ctx $+ "GET "+ <> CL8.fromStrict (head paths)+ <> " HTTP/1.1\r\n"+ <> "Host: "+ <> CL8.pack auxAuthority+ <> "\r\n"+ <> "Connection: close\r\n"+ <> "\r\n"+ loop+ auxShow "\n"+ where+ loop = do+ bs <- recvData ctx+ when (bs /= "") $ do+ auxShow bs+ loop
util/Common.hs view
@@ -10,23 +10,22 @@ readCiphers, readDHParams, readGroups,- printHandshakeInfo,- makeAddrInfo,- AddrInfo (..), getCertificateStore,+ getLogger,+ namedGroups,+ getInfo,+ printHandshakeInfo, ) where -import Data.Char (isDigit)-import Network.Socket-import Numeric (showHex)- import Crypto.System.CPU+import Data.Char (isDigit) import Data.X509.CertificateStore-import System.X509- import Network.TLS hiding (HostName) import Network.TLS.Extra.Cipher import Network.TLS.Extra.FFDHE+import Numeric (showHex)+import System.Exit+import System.X509 import Imports @@ -77,8 +76,10 @@ Nothing -> (Just . read) `fmap` readFile s mparams -> return mparams -readGroups :: String -> Maybe [Group]-readGroups s = traverse (`lookup` namedGroups) (split ',' s)+readGroups :: String -> [Group]+readGroups s = case traverse (`lookup` namedGroups) (split ',' s) of+ Nothing -> []+ Just gs -> gs printCiphers :: IO () printCiphers = do@@ -121,37 +122,6 @@ putStrLn "=====================================" forM_ namedGroups $ \(name, _) -> putStrLn name -printHandshakeInfo :: Context -> IO ()-printHandshakeInfo ctx = do- info <- contextGetInformation ctx- case info of- Nothing -> return ()- Just i -> do- putStrLn ("version: " ++ show (infoVersion i))- putStrLn ("cipher: " ++ show (infoCipher i))- putStrLn ("compression: " ++ show (infoCompression i))- putStrLn ("group: " ++ maybe "(none)" show (infoSupportedGroup i))- when (infoVersion i < TLS13) $ do- putStrLn ("extended master secret: " ++ show (infoExtendedMainSecret i))- putStrLn ("resumption: " ++ show (infoTLS12Resumption i))- when (infoVersion i == TLS13) $ do- putStrLn ("handshake emode: " ++ show (fromJust (infoTLS13HandshakeMode i)))- putStrLn ("early data accepted: " ++ show (infoIsEarlyDataAccepted i))- sni <- getClientSNI ctx- case sni of- Nothing -> return ()- Just n -> putStrLn ("server name indication: " ++ n)--makeAddrInfo :: Maybe HostName -> PortNumber -> IO AddrInfo-makeAddrInfo maddr port = do- let flgs = [AI_ADDRCONFIG, AI_NUMERICSERV, AI_PASSIVE]- hints =- defaultHints- { addrFlags = flgs- , addrSocketType = Stream- }- head <$> getAddrInfo (Just hints) maddr (Just $ show port)- split :: Char -> String -> [String] split _ "" = [] split c s = case break (c ==) s of@@ -168,3 +138,29 @@ case mstore of Nothing -> error ("invalid certificate store: " ++ path) Just st -> return $! mappend st acc++getLogger :: Maybe FilePath -> (String -> IO ())+getLogger Nothing = \_ -> return ()+getLogger (Just file) = \msg -> appendFile file (msg ++ "\n")++getInfo :: Context -> IO Information+getInfo ctx = do+ minfo <- contextGetInformation ctx+ case minfo of+ Nothing -> do+ putStrLn "Erro: information cannot be obtained"+ exitFailure+ Just info -> return info++printHandshakeInfo :: Information -> IO ()+printHandshakeInfo i = do+ putStrLn $ "Version: " ++ show (infoVersion i)+ putStrLn $ "Cipher: " ++ show (infoCipher i)+ putStrLn $ "Compression: " ++ show (infoCompression i)+ putStrLn $ "Groups: " ++ maybe "(none)" show (infoSupportedGroup i)+ when (infoVersion i < TLS13) $ do+ putStrLn $ "Extended master secret: " ++ show (infoExtendedMainSecret i)+ putStrLn $ "Resumption: " ++ show (infoTLS12Resumption i)+ when (infoVersion i == TLS13) $ do+ putStrLn $ "Handshake mode: " ++ show (fromJust (infoTLS13HandshakeMode i))+ putStrLn $ "Early data accepted: " ++ show (infoIsEarlyDataAccepted i)
− util/HexDump.hs
@@ -1,96 +0,0 @@-module HexDump (- hexdump,-) where--import qualified Data.ByteString as B--import Imports--hexdump :: String -> ByteString -> [String]-hexdump pre b = disptable (defaultConfig{configRowLeft = pre ++ " | "}) $ B.unpack b--data BytedumpConfig = BytedumpConfig- { configRowSize :: Int- -- ^ number of bytes per row.- , configRowGroupSize :: Int- -- ^ number of bytes per group per row.- , configRowGroupSep :: String- -- ^ string separating groups.- , configRowLeft :: String- -- ^ string on the left of the row.- , configRowRight :: String- -- ^ string on the right of the row.- , configCellSep :: String- -- ^ string separating cells in row.- , configPrintChar :: Bool- -- ^ if the printable ascii table is displayed.- }- deriving (Show, Eq)--defaultConfig :: BytedumpConfig-defaultConfig =- BytedumpConfig- { configRowSize = 16- , configRowGroupSize = 8- , configRowGroupSep = " : "- , configRowLeft = " | "- , configRowRight = " | "- , configCellSep = " "- , configPrintChar = True- }--disptable :: BytedumpConfig -> [Word8] -> [String]-disptable _ [] = []-disptable cfg x =- let (pre, post) = splitAt (configRowSize cfg) x- in tableRow pre : disptable cfg post- where- tableRow row =- let l = splitMultiple (configRowGroupSize cfg) $ map hexString row- in let lb = intercalate (configRowGroupSep cfg) $ map (intercalate (configCellSep cfg)) l- in let rb = map printChar row- in let rowLen =- 2 * configRowSize cfg- + (configRowSize cfg - 1) * length (configCellSep cfg)- + ((configRowSize cfg `div` configRowGroupSize cfg) - 1)- * length (configRowGroupSep cfg)- in configRowLeft cfg- ++ lb- ++ replicate (rowLen - length lb) ' '- ++ configRowRight cfg- ++ (if configPrintChar cfg then rb else "")-- splitMultiple _ [] = []- splitMultiple n l = let (pre, post) = splitAt n l in pre : splitMultiple n post-- printChar :: Word8 -> Char- printChar w- | w >= 0x20 && w < 0x7f = toEnum $ fromIntegral w- | otherwise = '.'-- hex :: Int -> Char- hex 0 = '0'- hex 1 = '1'- hex 2 = '2'- hex 3 = '3'- hex 4 = '4'- hex 5 = '5'- hex 6 = '6'- hex 7 = '7'- hex 8 = '8'- hex 9 = '9'- hex 10 = 'a'- hex 11 = 'b'- hex 12 = 'c'- hex 13 = 'd'- hex 14 = 'e'- hex 15 = 'f'- hex _ = ' '-- {-# INLINE hexBytes #-}- hexBytes :: Word8 -> (Char, Char)- hexBytes w = (hex h, hex l) where (h, l) = fromIntegral w `divMod` 16-- -- \| Dump one byte into a 2 hexadecimal characters.- hexString :: Word8 -> String- hexString i = [h, l] where (h, l) = hexBytes i
+ util/Server.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Server where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as BL8+import Data.IORef+import Network.TLS+import Prelude hiding (getLine)++import Imports++server :: Context -> Bool -> IO ()+server ctx showRequest = do+ recvRequest ctx showRequest+ sendData ctx $+ "HTTP/1.1 200 OK\r\n"+ <> "Context-Type: text/html\r\n"+ <> "Content-Length: "+ <> BL8.pack (show (BL8.length body))+ <> "\r\n"+ <> "\r\n"+ <> body+ where+ body = "<html><<body>Hello world!</body></html>"++recvRequest :: Context -> Bool -> IO ()+recvRequest ctx showRequest = do+ getLine <- newSource ctx+ loop getLine+ where+ loop getLine = do+ bs <- getLine+ when (bs /= "") $ do+ when showRequest $ do+ BS.putStr bs+ BS.putStr "\n"+ loop getLine++newSource :: Context -> IO (IO ByteString)+newSource ctx = do+ ref <- newIORef ""+ return $ getline ref+ where+ getline :: IORef ByteString -> IO ByteString+ getline ref = do+ bs0 <- readIORef ref+ case BS.breakSubstring "\r\n" bs0 of+ (_, "") -> do+ bs1 <- recvData ctx+ writeIORef ref (bs0 <> bs1)+ getline ref+ (bs1, bs2) -> do+ writeIORef ref $ BS.drop 2 bs2+ return bs1
util/tls-client.hs view
@@ -1,515 +1,328 @@+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -import Control.Exception (SomeException (..))-import qualified Control.Exception as E-import Crypto.Random-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy.Char8 as LC-import Data.Default.Class+module Main where++import Control.Concurrent+import qualified Data.ByteString.Char8 as C8+import Data.Default.Class (def) import Data.IORef import Data.X509.CertificateStore-import Network.Socket (PortNumber, close, connect, socket)+import Network.Run.TCP+import Network.Socket+import Network.TLS+import Network.TLS.Extra.Cipher import System.Console.GetOpt import System.Environment import System.Exit-import System.IO-import System.Timeout--import Network.TLS-import Network.TLS.Extra.Cipher+import System.X509+import qualified UnliftIO.Exception as E +import Client import Common-import HexDump import Imports -defaultBenchAmount :: Int-defaultBenchAmount = 1024 * 1024--defaultTimeout :: Int-defaultTimeout = 2000--bogusCipher :: CipherID -> Cipher-bogusCipher cid = cipher_ECDHE_RSA_AES128GCM_SHA256{cipherID = cid}--runTLS- :: Bool- -> Bool- -> ClientParams- -> String- -> PortNumber- -> (Context -> IO a)- -> IO a-runTLS debug ioDebug params hostname portNumber f =- E.bracket setup teardown $ \sock -> do- ctx <- contextNew sock params- contextHookSetLogging ctx getLogging- f ctx- where- getLogging = ioLogging $ packetLogging def- packetLogging logging- | debug =- logging- { loggingPacketSent = putStrLn . ("debug: >> " ++)- , loggingPacketRecv = putStrLn . ("debug: << " ++)- }- | otherwise = logging- ioLogging logging- | ioDebug =- logging- { loggingIOSent = mapM_ putStrLn . hexdump ">>"- , loggingIORecv = \hdr body -> do- putStrLn ("<< " ++ show hdr)- mapM_ putStrLn $ hexdump "<<" body- }- | otherwise = logging- setup = do- ai <- makeAddrInfo (Just hostname) portNumber- sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)- let sockaddr = addrAddress ai- connect sock sockaddr- return sock- teardown sock = close sock+data Options = Options+ { optDebugLog :: Bool+ , optShow :: Bool+ , optKeyLogFile :: Maybe FilePath+ , optGroups :: [Group]+ , optValidate :: Bool+ , optVerNego :: Bool+ , optResumption :: Bool+ , opt0RTT :: Bool+ , optRetry :: Bool+ , optVersions :: [Version]+ }+ deriving (Show) -sessionRef :: IORef (SessionID, SessionData) -> SessionManager-sessionRef ref =- noSessionManager- { sessionEstablish = \sid sdata -> writeIORef ref (sid, sdata) >> return Nothing+defaultOptions :: Options+defaultOptions =+ Options+ { optDebugLog = False+ , optShow = False+ , optKeyLogFile = Nothing+ , optGroups = supportedGroups def+ , optValidate = False+ , optVerNego = False+ , optResumption = False+ , opt0RTT = False+ , optRetry = False+ , optVersions = supportedVersions def } -getDefaultParams- :: [Flag]- -> String- -> CertificateStore- -> IORef (SessionID, SessionData)- -> Maybe OnCertificateRequest- -> Maybe (SessionID, SessionData)- -> Maybe ByteString- -> ClientParams-getDefaultParams flags host store sStorage certCredsRequest session earlyData =- (defaultParamsClient serverName BC.empty)- { clientSupported =- def- { supportedVersions = supportedVers- , supportedCiphers = myCiphers- , supportedGroups = getGroups flags- }- , clientWantSessionResume = session- , clientUseServerNameIndication = NoSNI `notElem` flags- , clientShared =- def- { sharedSessionManager = sessionRef sStorage- , sharedCAStore = store- , sharedValidationCache = validateCache- }- , clientHooks =- def- { onCertificateRequest = fromMaybe (onCertificateRequest def) certCredsRequest- }- , clientDebug =- def- { debugSeed = foldl getDebugSeed Nothing flags- , debugPrintSeed =- if DebugPrintSeed `elem` flags- then (\seed -> putStrLn ("seed: " ++ show (seedToInteger seed)))- else (\_ -> return ())- }- , clientUseEarlyData = isJust earlyData- }- where- serverName = foldl f host flags- where- f _ (SNI n) = n- f acc _ = acc-- validateCache- | validateCert = def- | otherwise =- ValidationCache- (\_ _ _ -> return ValidationCachePass)- (\_ _ _ -> return ())- myCiphers = foldl accBogusCipher getSelectedCiphers flags- where- accBogusCipher acc (BogusCipher c) =- case reads c of- [(v, "")] -> acc ++ [bogusCipher v]- _ -> acc- accBogusCipher acc _ = acc-- getUsedCipherIDs = foldl f [] flags- where- f acc (UseCipher am) =- case readCiphers am of- Just l -> l ++ acc- Nothing -> acc- f acc _ = acc-- getSelectedCiphers =- case getUsedCipherIDs of- [] -> ciphersuite_all- l -> mapMaybe (\cid -> find ((== cid) . cipherID) ciphersuite_all) l-- getDebugSeed :: Maybe Seed -> Flag -> Maybe Seed- getDebugSeed _ (DebugSeed seed) = seedFromInteger `fmap` readNumber seed- getDebugSeed acc _ = acc-- tlsConnectVer- | Tls13 `elem` flags = TLS13- | Tls12 `elem` flags = TLS12- | Tls11 `elem` flags = TLS11- | Ssl3 `elem` flags = SSL3- | Tls10 `elem` flags = TLS10- | otherwise = TLS13- supportedVers- | NoVersionDowngrade `elem` flags = [tlsConnectVer]- | otherwise = filter (<= tlsConnectVer) allVers- allVers = [TLS13, TLS12, TLS11, TLS10, SSL3]- validateCert = NoValidateCert `notElem` flags--getGroups :: [Flag] -> [Group]-getGroups flags = case getGroup >>= readGroups of- Nothing -> defaultGroups- Just [] -> defaultGroups- Just groups -> groups- where- defaultGroups = supportedGroups def- getGroup = foldl f Nothing flags- where- f _ (NGroup g) = Just g- f acc _ = acc--data Flag- = Verbose- | Debug- | IODebug- | NoValidateCert- | Session- | Http11- | Ssl3- | Tls10- | Tls11- | Tls12- | Tls13- | SNI String- | NoSNI- | Uri String- | NoVersionDowngrade- | UserAgent String- | Input String- | Output String- | Timeout String- | BogusCipher String- | ClientCert String- | TrustAnchor String- | BenchSend- | BenchRecv- | BenchData String- | UseCipher String- | ListCiphers- | ListGroups- | DebugSeed String- | DebugPrintSeed- | NGroup String- | Help- | UpdateKey- deriving (Show, Eq)+usage :: String+usage = "Usage: quic-client [OPTION] addr port [path]" -options :: [OptDescr Flag]+options :: [OptDescr (Options -> Options)] options =- [ Option ['v'] ["verbose"] (NoArg Verbose) "verbose output on stdout"- , Option ['d'] ["debug"] (NoArg Debug) "TLS debug output on stdout"- , Option [] ["io-debug"] (NoArg IODebug) "TLS IO debug output on stdout"- , Option ['s'] ["session"] (NoArg Session) "try to resume a session"- , Option- ['Z']- ["zerortt"]- (ReqArg Input "inpfile")- "input for TLS 1.3 0RTT data"- , Option ['O'] ["output"] (ReqArg Output "stdout") "output "- , Option ['g'] ["group"] (ReqArg NGroup "group") "group"- , Option- ['t']- ["timeout"]- (ReqArg Timeout "timeout")- "timeout in milliseconds (2s by default)"- , Option- ['u']- ["update-key"]- (NoArg UpdateKey)- "Updating keys after sending the first request then sending the same request again (TLS 1.3 only)"- , Option- []- ["no-validation"]- (NoArg NoValidateCert)- "disable certificate validation"- , Option- []- ["client-cert"]- (ReqArg ClientCert "cert-file:key-file")- "add a client certificate to use with the server"- , Option- []- ["trust-anchor"]- (ReqArg TrustAnchor "pem-or-dir")- "use provided CAs instead of system certificate store"- , Option [] ["http1.1"] (NoArg Http11) "use http1.1 instead of http1.0"- , Option [] ["ssl3"] (NoArg Ssl3) "use SSL 3.0"- , Option- []- ["sni"]- (ReqArg SNI "server-name")- "use non-default server name indication"- , Option [] ["no-sni"] (NoArg NoSNI) "don't use server name indication"- , Option [] ["user-agent"] (ReqArg UserAgent "user-agent") "use a user agent"- , Option [] ["tls10"] (NoArg Tls10) "use TLS 1.0"- , Option [] ["tls11"] (NoArg Tls11) "use TLS 1.1"- , Option [] ["tls12"] (NoArg Tls12) "use TLS 1.2"- , Option [] ["tls13"] (NoArg Tls13) "use TLS 1.3 (default)"- , Option- []- ["bogocipher"]- (ReqArg BogusCipher "cipher-id")- "add a bogus cipher id for testing"- , Option- ['x']- ["no-version-downgrade"]- (NoArg NoVersionDowngrade)- "do not allow version downgrade"+ [ Option+ ['d']+ ["debug"]+ (NoArg (\o -> o{optDebugLog = True}))+ "print debug info" , Option- []- ["uri"]- (ReqArg Uri "URI")- "optional URI requested by default /"- , Option ['h'] ["help"] (NoArg Help) "request help"+ ['v']+ ["show-content"]+ (NoArg (\o -> o{optShow = True}))+ "print downloaded content" , Option- []- ["bench-send"]- (NoArg BenchSend)- "benchmark send path. only with compatible server"+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets" , Option- []- ["bench-recv"]- (NoArg BenchRecv)- "benchmark recv path. only with compatible server"+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = readGroups gs}) "<groups>")+ "specify groups" , Option- []- ["bench-data"]- (ReqArg BenchData "amount")- "amount of data to benchmark with"+ ['e']+ ["validate"]+ (NoArg (\o -> o{optValidate = True}))+ "validate server's certificate" , Option- []- ["use-cipher"]- (ReqArg UseCipher "cipher-id")- "use a specific cipher"+ ['R']+ ["resumption"]+ (NoArg (\o -> o{optResumption = True}))+ "try session resumption" , Option- []- ["list-ciphers"]- (NoArg ListCiphers)- "list all ciphers supported and exit"+ ['Z']+ ["0rtt"]+ (NoArg (\o -> o{opt0RTT = True}))+ "try sending early data" , Option- []- ["list-groups"]- (NoArg ListGroups)- "list all groups supported and exit"+ ['S']+ ["hello-retry"]+ (NoArg (\o -> o{optRetry = True}))+ "try client hello retry" , Option- []- ["debug-seed"]- (ReqArg DebugSeed "debug-seed")- "debug: set a specific seed for randomness"+ ['2']+ ["tls12"]+ (NoArg (\o -> o{optVersions = [TLS12]}))+ "use TLS 1.2" , Option- []- ["debug-print-seed"]- (NoArg DebugPrintSeed)- "debug: set a specific seed for randomness"+ ['3']+ ["tls13"]+ (NoArg (\o -> o{optVersions = [TLS13]}))+ "use TLS 1.3" ] -noSession :: Maybe (SessionID, SessionData)-noSession = Nothing+showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ putStrLn $ " <groups> = " ++ (intercalate "," (map fst namedGroups))+ exitFailure -runOn- :: (IORef (SessionID, SessionData), CertificateStore)- -> [Flag]- -> PortNumber- -> String- -> IO ()-runOn (sStorage, certStore) flags port hostname- | BenchSend `elem` flags = runBench True- | BenchRecv `elem` flags = runBench False- | otherwise = do- certCredRequest <- getCredRequest- doTLS certCredRequest noSession Nothing `E.catch` \(SomeException e) -> print e- when (Session `elem` flags) $ do- putStrLn "\nResuming the session..."- session <- readIORef sStorage- earlyData <- case getInput of- Nothing -> return Nothing- Just i -> Just <$> B.readFile i- doTLS certCredRequest (Just session) earlyData `E.catch` \(SomeException e) -> print e- where- runBench isSend =- runTLS- (Debug `elem` flags)- (IODebug `elem` flags)- (getDefaultParams flags hostname certStore sStorage Nothing noSession Nothing)- hostname- port- $ \ctx -> do- handshake ctx- if isSend- then loopSendData getBenchAmount ctx- else loopRecvData getBenchAmount ctx- bye ctx- where- dataSend = BC.replicate 4096 'a'- loopSendData bytes ctx- | bytes <= 0 = return ()- | otherwise = do- sendData ctx $- LC.fromChunks- [if bytes > B.length dataSend then dataSend else BC.take bytes dataSend]- loopSendData (bytes - B.length dataSend) ctx+clientOpts :: [String] -> IO (Options, [String])+clientOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs - loopRecvData bytes ctx- | bytes <= 0 = return ()- | otherwise = do- d <- recvData ctx- loopRecvData (bytes - B.length d) ctx+main :: IO ()+main = do+ args <- getArgs+ (opts@Options{..}, ips) <- clientOpts args+ (host, port, paths) <- case ips of+ [] -> showUsageAndExit usage+ _ : [] -> showUsageAndExit usage+ h : p : [] -> return (h, p, ["/"])+ h : p : ps -> return (h, p, C8.pack <$> ps)+ when (null optGroups) $ do+ putStrLn "Error: unsupported groups"+ exitFailure+ ref <- newIORef Nothing+ let debug+ | optDebugLog = putStrLn+ | otherwise = \_ -> return ()+ showContent+ | optShow = C8.putStr+ | otherwise = \_ -> return ()+ aux =+ Aux+ { auxAuthority = host+ , auxPort = port+ , auxDebug = debug+ , auxShow = showContent+ , auxReadResumptionData = readIORef ref+ }+ mstore <-+ if optValidate then Just <$> getSystemCertificateStore else return Nothing+ let keyLog = getLogger optKeyLogFile+ groups+ | optRetry = FFDHE8192 : optGroups+ | otherwise = optGroups+ cparams = getClientParams optVersions host port groups (smIORef ref) mstore keyLog+ runClient opts cparams aux paths - doTLS certCredRequest sess earlyData = E.bracket setup teardown $ \out -> do- let query =- LC.pack- ( "GET "- ++ findURI flags- ++ ( if Http11 `elem` flags then " HTTP/1.1\r\nHost: " ++ hostname else " HTTP/1.0"- )- ++ userAgent- ++ "\r\n\r\n"- )- when- (Verbose `elem` flags)- (putStrLn "sending query:" >> LC.putStrLn query >> putStrLn "")- runTLS- (Debug `elem` flags)- (IODebug `elem` flags)- ( getDefaultParams- flags- hostname- certStore- sStorage- certCredRequest- sess- earlyData- )- hostname- port- $ \ctx -> do- handshake ctx- when (Verbose `elem` flags) $ printHandshakeInfo ctx- case earlyData of- Just edata -> sendData ctx $ LC.fromStrict edata- _ -> return ()- sendData ctx query- loopRecv out ctx- when (UpdateKey `elem` flags) $ do- _tls13 <- updateKey ctx TwoWay- sendData ctx query- loopRecv out ctx- bye ctx `E.catch` \(SomeException e) -> putStrLn $ "bye failed: " ++ show e- return ()- setup = maybe (return stdout) (\f -> openFile f AppendMode) getOutput- teardown out = when (isJust getOutput) $ hClose out- loopRecv out ctx = do- d <- timeout (timeoutMs * 1000) (recvData ctx) -- 2s per recv- case d of- Nothing ->- when (Debug `elem` flags) (hPutStrLn stderr "timeout")- Just b- | BC.null b -> return ()- | otherwise -> BC.hPutStrLn out b >> loopRecv out ctx+runClient :: Options -> ClientParams -> Aux -> [ByteString] -> IO ()+runClient opts@Options{..} cparams aux@Aux{..} paths = do+ auxDebug "------------------------"+ (info1, msd) <- runTLS cparams aux $ \ctx -> do+ i1 <- getInfo ctx+ when optDebugLog $ printHandshakeInfo i1+ client aux paths ctx+ msd' <- auxReadResumptionData+ return (i1, msd')+ if+ | optResumption ->+ if isResumptionPossible msd+ then do+ let cparams2 = modifyClientParams cparams msd False+ info2 <- runClient2 opts cparams2 aux paths+ if infoVersion info1 == TLS12+ then do+ if infoTLS12Resumption info2+ then do+ putStrLn "Result: (R) TLS resumption ... OK"+ exitSuccess+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ else do+ if infoTLS13HandshakeMode info2 == Just PreSharedKey+ then do+ putStrLn "Result: (R) TLS resumption ... OK"+ exitSuccess+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ | opt0RTT ->+ if is0RTTPossible info1 msd+ then do+ let cparams2 = modifyClientParams cparams msd True+ info2 <- runClient2 opts cparams2 aux paths+ if infoTLS13HandshakeMode info2 == Just RTT0+ then do+ putStrLn "Result: (Z) 0-RTT ... OK"+ exitSuccess+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ | optRetry ->+ if infoTLS13HandshakeMode info1 == Just HelloRetryRequest+ then do+ putStrLn "Result: (S) retry ... OK"+ exitSuccess+ else do+ putStrLn "Result: (S) retry ... NG"+ exitFailure+ | otherwise -> do+ putStrLn "Result: (H) handshake ... OK"+ let malpn = (snd <$> msd) >>= sessionALPN+ when (malpn == Just "http/1.1") $+ putStrLn "Result: (1) HTTP/1.1 transaction ... OK"+ exitSuccess - getCredRequest =- case clientCert of- Nothing -> return Nothing- Just s ->- case break (== ':') s of- (_, "") -> error "wrong format for client-cert, expecting 'cert-file:key-file'"- (cert, ':' : key) -> do- ecred <- credentialLoadX509 cert key- case ecred of- Left err -> error ("cannot load client certificate: " ++ err)- Right cred -> do- let certRequest _ = return $ Just cred- return $ Just certRequest- (_, _) -> error "wrong format for client-cert, expecting 'cert-file:key-file'"+runClient2+ :: Options+ -> ClientParams+ -> Aux+ -> [ByteString]+ -> IO Information+runClient2 Options{..} cparams aux@Aux{..} paths = do+ threadDelay 100000+ auxDebug "<<<< next connection >>>>"+ auxDebug "------------------------"+ runTLS cparams aux $ \ctx -> do+ if opt0RTT+ then do+ void $ client aux paths ctx+ i <- getInfo ctx+ when optDebugLog $ printHandshakeInfo i+ return i+ else do+ i <- getInfo ctx+ when optDebugLog $ printHandshakeInfo i+ void $ client aux paths ctx+ return i - findURI [] = "/"- findURI (Uri u : _) = u- findURI (_ : xs) = findURI xs+runTLS+ :: ClientParams+ -> Aux+ -> (Context -> IO a)+ -> IO a+runTLS cparams Aux{..} action =+ runTCPClient auxAuthority auxPort $ \sock -> do+ E.bracket (contextNew sock cparams) bye $ \ctx -> do+ handshake ctx+ action ctx - userAgent = maybe "" ("\r\nUser-Agent: " ++) mUserAgent- mUserAgent = foldl f Nothing flags- where- f _ (UserAgent ua) = Just ua- f acc _ = acc- getInput = foldl f Nothing flags- where- f _ (Input i) = Just i- f acc _ = acc- getOutput = foldl f Nothing flags- where- f _ (Output o) = Just o- f acc _ = acc- timeoutMs = foldl f defaultTimeout flags- where- f _ (Timeout t) = read t- f acc _ = acc- clientCert = foldl f Nothing flags- where- f _ (ClientCert c) = Just c- f acc _ = acc- getBenchAmount = foldl f defaultBenchAmount flags- where- f acc (BenchData am) = case readNumber am of- Nothing -> acc- Just i -> i- f acc _ = acc+modifyClientParams+ :: ClientParams -> Maybe (SessionID, SessionData) -> Bool -> ClientParams+modifyClientParams cparams wantResume early =+ cparams+ { clientWantSessionResume = wantResume+ , clientUseEarlyData = early+ } -getTrustAnchors :: [Flag] -> IO CertificateStore-getTrustAnchors flags = getCertificateStore (foldr getPaths [] flags)+getClientParams+ :: [Version]+ -> HostName+ -> ServiceName+ -> [Group]+ -> SessionManager+ -> Maybe CertificateStore+ -> (String -> IO ())+ -> ClientParams+getClientParams vers serverName port groups sm mstore keyLog =+ (defaultParamsClient serverName (C8.pack port))+ { clientSupported = supported+ , clientUseServerNameIndication = True+ , clientShared = shared+ , clientHooks = hooks+ , clientDebug = debug+ } where- getPaths (TrustAnchor path) acc = path : acc- getPaths _ acc = acc--printUsage :: IO ()-printUsage =- putStrLn $- usageInfo- "usage: client [opts] <hostname> [port]\n\n\t(port default to: 443)\noptions:\n"- options--main :: IO ()-main = do- args <- getArgs- let (opts, other, errs) = getOpt Permute options args- unless (null errs) $ do- print errs- exitFailure-- when (Help `elem` opts) $ do- printUsage- exitSuccess+ shared =+ def+ { sharedSessionManager = sm+ , sharedCAStore = case mstore of+ Just store -> store+ Nothing -> mempty+ , sharedValidationCache = validateCache+ }+ supported =+ def+ { supportedCiphers = ciphersuite_strong+ , supportedVersions = vers+ , supportedGroups = groups+ }+ hooks =+ def+ { onSuggestALPN = return $ Just ["http/1.1"]+ }+ validateCache+ | isJust mstore = def+ | otherwise =+ ValidationCache+ (\_ _ _ -> return ValidationCachePass)+ (\_ _ _ -> return ())+ debug =+ def+ { debugKeyLogger = keyLog+ } - when (ListCiphers `elem` opts) $ do- printCiphers- exitSuccess+smIORef :: IORef (Maybe (SessionID, SessionData)) -> SessionManager+smIORef ref =+ noSessionManager+ { sessionEstablish = \sid sdata -> writeIORef ref (Just (sid, sdata)) >> return Nothing+ } - when (ListGroups `elem` opts) $ do- printGroups- exitSuccess+isResumptionPossible :: Maybe (SessionID, SessionData) -> Bool+isResumptionPossible = isJust - certStore <- getTrustAnchors opts- sStorage <- newIORef (error "storage ioref undefined")- case other of- [hostname] -> runOn (sStorage, certStore) opts 443 hostname- [hostname, port] -> runOn (sStorage, certStore) opts (fromInteger $ read port) hostname- _ -> printUsage >> exitFailure+is0RTTPossible :: Information -> Maybe (SessionID, SessionData) -> Bool+is0RTTPossible _ Nothing = False+is0RTTPossible info (Just (_, sd)) =+ infoVersion info == TLS13+ && sessionMaxEarlyDataSize sd > 0
util/tls-server.hs view
@@ -1,483 +1,148 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} -import Control.Concurrent-import qualified Control.Exception as E-import Crypto.Random-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy.Char8 as LC-import Data.Default.Class+module Main where++import Data.Default.Class (def) import Data.IORef import qualified Data.Map.Strict as M-import Data.X509.CertificateStore-import Network.Socket (accept, bind, close, listen, socket)-import qualified Network.Socket as S+import Network.Run.TCP+import Network.TLS+import Network.TLS.Extra.Cipher import System.Console.GetOpt-import System.Environment+import System.Environment (getArgs) import System.Exit import System.IO-import System.Timeout--import Network.TLS-import Network.TLS.Extra.Cipher+import qualified UnliftIO.Exception as E import Common-import HexDump import Imports--defaultBenchAmount :: Int-defaultBenchAmount = 1024 * 1024--defaultTimeout :: Int-defaultTimeout = 2000--bogusCipher :: CipherID -> Cipher-bogusCipher cid = cipher_ECDHE_RSA_AES128GCM_SHA256{cipherID = cid}--runTLS :: Bool -> Bool -> ServerParams -> S.Socket -> (Context -> IO a) -> IO a-runTLS debug ioDebug params cSock f = do- ctx <- contextNew cSock params- contextHookSetLogging ctx getLogging- f ctx- where- getLogging = ioLogging $ packetLogging def- packetLogging logging- | debug =- logging- { loggingPacketSent = putStrLn . ("debug: >> " ++)- , loggingPacketRecv = putStrLn . ("debug: << " ++)- }- | otherwise = logging- ioLogging logging- | ioDebug =- logging- { loggingIOSent = mapM_ putStrLn . hexdump ">>"- , loggingIORecv = \hdr body -> do- putStrLn ("<< " ++ show hdr)- mapM_ putStrLn $ hexdump "<<" body- }- | otherwise = logging--getDefaultParams- :: [Flag]- -> CertificateStore- -> SessionManager- -> Credential- -> Bool- -> IO ServerParams-getDefaultParams flags store smgr cred rtt0accept = do- dhParams <- case getDHParams flags of- Nothing -> return Nothing- Just name -> readDHParams name-- return- def- { serverWantClientCert = False- , serverCACertificates = []- , serverDHEParams = dhParams- , serverShared =- def- { sharedSessionManager = smgr- , sharedCAStore = store- , sharedValidationCache = validateCache- , sharedCredentials = Credentials [cred]- }- , serverSupported =- def- { supportedVersions = supportedVers- , supportedCiphers = myCiphers- , supportedGroups = getGroups flags- , supportedClientInitiatedRenegotiation = allowRenegotiation- }- , serverDebug =- def- { debugSeed = foldl getDebugSeed Nothing flags- , debugPrintSeed =- if DebugPrintSeed `elem` flags- then (\seed -> putStrLn ("seed: " ++ show (seedToInteger seed)))- else (\_ -> return ())- }- , serverEarlyDataSize = if rtt0accept then 2048 else 0- }- where- validateCache- | validateCert = def- | otherwise =- ValidationCache- (\_ _ _ -> return ValidationCachePass)- (\_ _ _ -> return ())-- myCiphers = foldl accBogusCipher getSelectedCiphers flags- where- accBogusCipher acc (BogusCipher c) =- case reads c of- [(v, "")] -> acc ++ [bogusCipher v]- _ -> acc- accBogusCipher acc _ = acc-- getUsedCipherIDs = foldl f [] flags- where- f acc (UseCipher am) =- case readCiphers am of- Just l -> l ++ acc- Nothing -> acc- f acc _ = acc-- getSelectedCiphers =- case getUsedCipherIDs of- [] -> ciphersuite_default- l -> mapMaybe (\cid -> find ((== cid) . cipherID) ciphersuite_all) l-- getDHParams opts = foldl accf Nothing opts- where- accf _ (DHParams file) = Just file- accf acc _ = acc-- getDebugSeed :: Maybe Seed -> Flag -> Maybe Seed- getDebugSeed _ (DebugSeed seed) = seedFromInteger `fmap` readNumber seed- getDebugSeed acc _ = acc-- tlsConnectVer- | Tls13 `elem` flags = TLS13- | Tls12 `elem` flags = TLS12- | Tls11 `elem` flags = TLS11- | Ssl3 `elem` flags = SSL3- | Tls10 `elem` flags = TLS10- | otherwise = TLS13- supportedVers- | NoVersionDowngrade `elem` flags = [tlsConnectVer]- | otherwise = filter (<= tlsConnectVer) allVers- allVers = [TLS13, TLS12, TLS11, TLS10, SSL3]- validateCert = NoValidateCert `notElem` flags- allowRenegotiation = AllowRenegotiation `elem` flags+import Server -getGroups :: [Flag] -> [Group]-getGroups flags = case getGroup >>= readGroups of- Nothing -> defaultGroups- Just [] -> defaultGroups- Just groups -> groups- where- defaultGroups = supportedGroups def- getGroup = foldl f Nothing flags- where- f _ (NGroup g) = Just g- f acc _ = acc+data Options = Options+ { optDebugLog :: Bool+ , optShow :: Bool+ , optKeyLogFile :: Maybe FilePath+ , optGroups :: [Group]+ , optCertFile :: FilePath+ , optKeyFile :: FilePath+ }+ deriving (Show) -data Flag- = Verbose- | Debug- | IODebug- | NoValidateCert- | Http11- | Ssl3- | Tls10- | Tls11- | Tls12- | Tls13- | NoVersionDowngrade- | AllowRenegotiation- | Output String- | Timeout String- | BogusCipher String- | TrustAnchor String- | BenchSend- | BenchRecv- | BenchData String- | UseCipher String- | ListCiphers- | ListGroups- | ListDHParams- | Certificate String- | Key String- | DHParams String- | Rtt0- | DebugSeed String- | DebugPrintSeed- | NGroup String- | Help- deriving (Show, Eq)+defaultOptions :: Options+defaultOptions =+ Options+ { optDebugLog = False+ , optShow = False+ , optKeyLogFile = Nothing+ , optGroups = []+ , optCertFile = "servercert.pem"+ , optKeyFile = "serverkey.pem"+ } -options :: [OptDescr Flag]+options :: [OptDescr (Options -> Options)] options =- [ Option ['v'] ["verbose"] (NoArg Verbose) "verbose output on stdout"- , Option ['d'] ["debug"] (NoArg Debug) "TLS debug output on stdout"- , Option [] ["io-debug"] (NoArg IODebug) "TLS IO debug output on stdout"- , Option ['Z'] ["zerortt"] (NoArg Rtt0) "accept TLS 1.3 0RTT data"- , Option ['O'] ["output"] (ReqArg Output "stdout") "output "- , Option ['g'] ["group"] (ReqArg NGroup "group") "group"- , Option- ['t']- ["timeout"]- (ReqArg Timeout "timeout")- "timeout in milliseconds (2s by default)"- , Option- []- ["no-validation"]- (NoArg NoValidateCert)- "disable certificate validation"- , Option- []- ["trust-anchor"]- (ReqArg TrustAnchor "pem-or-dir")- "use provided CAs instead of system certificate store"- , Option [] ["http1.1"] (NoArg Http11) "use http1.1 instead of http1.0"- , Option [] ["ssl3"] (NoArg Ssl3) "use SSL 3.0"- , Option [] ["tls10"] (NoArg Tls10) "use TLS 1.0"- , Option [] ["tls11"] (NoArg Tls11) "use TLS 1.1"- , Option [] ["tls12"] (NoArg Tls12) "use TLS 1.2"- , Option [] ["tls13"] (NoArg Tls13) "use TLS 1.3 (default)"- , Option- []- ["bogocipher"]- (ReqArg BogusCipher "cipher-id")- "add a bogus cipher id for testing"- , Option- ['x']- ["no-version-downgrade"]- (NoArg NoVersionDowngrade)- "do not allow version downgrade"- , Option- []- ["allow-renegotiation"]- (NoArg AllowRenegotiation)- "allow client-initiated renegotiation"- , Option ['h'] ["help"] (NoArg Help) "request help"- , Option- []- ["bench-send"]- (NoArg BenchSend)- "benchmark send path. only with compatible server"- , Option- []- ["bench-recv"]- (NoArg BenchRecv)- "benchmark recv path. only with compatible server"- , Option- []- ["bench-data"]- (ReqArg BenchData "amount")- "amount of data to benchmark with"- , Option- []- ["use-cipher"]- (ReqArg UseCipher "cipher-id")- "use a specific cipher"+ [ Option+ ['d']+ ["debug"]+ (NoArg (\o -> o{optDebugLog = True}))+ "print debug info" , Option- []- ["list-ciphers"]- (NoArg ListCiphers)- "list all ciphers supported and exit"+ ['v']+ ["show-content"]+ (NoArg (\o -> o{optShow = True}))+ "print downloaded content" , Option- []- ["list-groups"]- (NoArg ListGroups)- "list all groups supported and exit"+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets" , Option- []- ["list-dhparams"]- (NoArg ListDHParams)- "list all DH parameters supported and exit"+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = readGroups gs}) "<groups>")+ "groups for key exchange" , Option- []- ["certificate"]- (ReqArg Certificate "certificate")+ ['c']+ ["cert"]+ (ReqArg (\fl o -> o{optCertFile = fl}) "<file>") "certificate file" , Option- []- ["debug-seed"]- (ReqArg DebugSeed "debug-seed")- "debug: set a specific seed for randomness"- , Option- []- ["debug-print-seed"]- (NoArg DebugPrintSeed)- "debug: set a specific seed for randomness"- , Option [] ["key"] (ReqArg Key "key") "certificate file"- , Option- []- ["dhparams"]- (ReqArg DHParams "dhparams")- "DH parameters (name or file)"+ ['k']+ ["key"]+ (ReqArg (\fl o -> o{optKeyFile = fl}) "<file>")+ "key file" ] -loadCred :: Maybe FilePath -> Maybe FilePath -> IO Credential-loadCred (Just key) (Just cert) = do- res <- credentialLoadX509 cert key- case res of- Left err -> error ("cannot load certificate: " ++ err)- Right v -> return v-loadCred Nothing _ =- error "missing credential key"-loadCred _ Nothing =- error "missing credential certificate"--runOn :: (SessionManager, CertificateStore) -> [Flag] -> S.PortNumber -> IO ()-runOn (smgr, certStore) flags port = do- ai <- makeAddrInfo Nothing port- sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)- S.setSocketOption sock S.ReuseAddr 1- let sockaddr = addrAddress ai- bind sock sockaddr- listen sock 10- runOn' sock- close sock- where- runOn' sock- | BenchSend `elem` flags = runBench True sock- | BenchRecv `elem` flags = runBench False sock- | otherwise = do- -- certCredRequest <- getCredRequest- E.bracket- (maybe (return stdout) (\x -> openFile x AppendMode) getOutput)- (\out -> when (isJust getOutput) $ hClose out)- (doTLS sock)- runBench isSend sock = do- (cSock, cAddr) <- accept sock- putStrLn ("connection from " ++ show cAddr)- cred <- loadCred getKey getCertificate- params <- getDefaultParams flags certStore smgr cred False- runTLS False False params cSock $ \ctx ->- do- handshake ctx- if isSend- then loopSendData getBenchAmount ctx- else loopRecvData getBenchAmount ctx- bye ctx- `E.finally` close cSock- where- dataSend = BC.replicate 4096 'a'- loopSendData bytes ctx- | bytes <= 0 = return ()- | otherwise = do- sendData ctx $- LC.fromChunks- [if bytes > B.length dataSend then dataSend else BC.take bytes dataSend]- loopSendData (bytes - B.length dataSend) ctx-- loopRecvData bytes ctx- | bytes <= 0 = return ()- | otherwise = do- d <- recvData ctx- loopRecvData (bytes - B.length d) ctx-- doTLS sock out = do- (cSock, cAddr) <- accept sock- putStrLn ("connection from " ++ show cAddr)-- cred <- loadCred getKey getCertificate- let rtt0accept = Rtt0 `elem` flags- params <- getDefaultParams flags certStore smgr cred rtt0accept-- void- $ forkIO- $ runTLS- (Debug `elem` flags)- (IODebug `elem` flags)- params- cSock- $ \ctx ->- do- handshake ctx- when (Verbose `elem` flags) $ printHandshakeInfo ctx- loopRecv out ctx- -- sendData ctx $ query- bye ctx- return ()- `E.finally` close cSock- doTLS sock out-- loopRecv out ctx = do- d <- timeout (timeoutMs * 1000) (recvData ctx) -- 2s per recv- case d of- Nothing ->- when (Debug `elem` flags) $ hPutStrLn stderr "timeout"- Just b- | BC.null b -> return ()- | otherwise -> BC.hPutStrLn out b >> loopRecv out ctx-- {-- getCredRequest =- case clientCert of- Nothing -> return Nothing- Just s -> do- case break (== ':') s of- (_ ,"") -> error "wrong format for client-cert, expecting 'cert-file:key-file'"- (cert,':':key) -> do- ecred <- credentialLoadX509 cert key- case ecred of- Left err -> error ("cannot load client certificate: " ++ err)- Right cred -> do- let certRequest _ = return $ Just cred- return $ Just (Credentials [cred], certRequest)- (_ ,_) -> error "wrong format for client-cert, expecting 'cert-file:key-file'"- -}-- getOutput = foldl f Nothing flags- where- f _ (Output o) = Just o- f acc _ = acc- timeoutMs = foldl f defaultTimeout flags- where- f _ (Timeout t) = read t- f acc _ = acc- getKey = foldl f Nothing flags- where- f _ (Key key) = Just key- f acc _ = acc- getCertificate = foldl f Nothing flags- where- f _ (Certificate cert) = Just cert- f acc _ = acc- getBenchAmount = foldl f defaultBenchAmount flags- where- f acc (BenchData am) = case readNumber am of- Nothing -> acc- Just i -> i- f acc _ = acc+usage :: String+usage = "Usage: server [OPTION] addr port" -getTrustAnchors :: [Flag] -> IO CertificateStore-getTrustAnchors flags = getCertificateStore (foldr getPaths [] flags)- where- getPaths (TrustAnchor path) acc = path : acc- getPaths _ acc = acc+showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ exitFailure -printUsage :: IO ()-printUsage =- putStrLn $- usageInfo- "usage: server [opts] [port]\n\n\t(port default to: 443)\noptions:\n"- options+serverOpts :: [String] -> IO (Options, [String])+serverOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs main :: IO () main = do+ hSetBuffering stdout NoBuffering args <- getArgs- let (opts, other, errs) = getOpt Permute options args- unless (null errs) $ do- print errs- exitFailure-- when (Help `elem` opts) $ do- printUsage- exitSuccess-- when (ListCiphers `elem` opts) $ do- printCiphers- exitSuccess-- when (ListDHParams `elem` opts) $ do- printDHParams- exitSuccess+ (Options{..}, ips) <- serverOpts args+ (host, port) <- case ips of+ [h, p] -> return (h, p)+ _ -> showUsageAndExit "cannot recognize <addr> and <port>\n"+ smgr <- newSessionManager+ Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile+ let keyLog = getLogger optKeyLogFile+ creds = Credentials [cred]+ runTCPServer (Just host) port $ \sock -> do+ let sparams = getServerParams creds smgr keyLog+ E.bracket (contextNew sock sparams) bye $ \ctx -> do+ handshake ctx+ when (optDebugLog || optShow) $ putStrLn "------------------------"+ when optDebugLog $+ getInfo ctx >>= printHandshakeInfo+ server ctx optShow - when (ListGroups `elem` opts) $ do- printGroups- exitSuccess+getServerParams+ :: Credentials+ -> SessionManager+ -> (String -> IO ())+ -> ServerParams+getServerParams creds sm keyLog =+ def+ { serverSupported = supported+ , serverShared = shared+ , serverHooks = hooks+ , serverDebug = debug+ , serverEarlyDataSize = 2048+ }+ where+ shared =+ def+ { sharedCredentials = creds+ , sharedSessionManager = sm+ }+ supported =+ def+ { supportedCiphers = ciphersuite_strong+ , supportedGroups = [X25519, X448, P256, P521]+ }+ hooks = def{onALPNClientSuggest = Just chooseALPN}+ debug = def{debugKeyLogger = keyLog} - certStore <- getTrustAnchors opts- smgr <- newSessionManager- case other of- [] -> runOn (smgr, certStore) opts 443- [port] -> runOn (smgr, certStore) opts (fromInteger $ read port)- _ -> printUsage >> exitFailure+chooseALPN :: [ByteString] -> IO ByteString+chooseALPN protos+ | "http/1.1" `elem` protos = return "http/1.1"+ | otherwise = return "" newSessionManager :: IO SessionManager newSessionManager = do