diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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 @@ -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) diff --git a/util/Client.hs b/util/Client.hs new file mode 100644 --- /dev/null +++ b/util/Client.hs @@ -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 diff --git a/util/Common.hs b/util/Common.hs --- a/util/Common.hs +++ b/util/Common.hs @@ -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) diff --git a/util/HexDump.hs b/util/HexDump.hs deleted file mode 100644 --- a/util/HexDump.hs +++ /dev/null @@ -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 diff --git a/util/Server.hs b/util/Server.hs new file mode 100644 --- /dev/null +++ b/util/Server.hs @@ -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 = "<Hello world!" + +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 diff --git a/util/tls-client.hs b/util/tls-client.hs --- a/util/tls-client.hs +++ b/util/tls-client.hs @@ -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}) "") + "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}) "") + "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 $ " = " ++ (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] [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 diff --git a/util/tls-server.hs b/util/tls-server.hs --- a/util/tls-server.hs +++ b/util/tls-server.hs @@ -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}) "") + "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 for key exchange" , Option - [] - ["certificate"] - (ReqArg Certificate "certificate") + ['c'] + ["cert"] + (ReqArg (\fl o -> o{optCertFile = fl}) "") "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}) "") + "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 and \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