tls-2.0.0: util/Common.hs

{-# LANGUAGE CPP #-}
-- Disable this warning so we can still test deprecated functionality.
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

module Common (
    printCiphers,
    printDHParams,
    printGroups,
    readNumber,
    readCiphers,
    readDHParams,
    readGroups,
    printHandshakeInfo,
    makeAddrInfo,
    AddrInfo (..),
    getCertificateStore,
) where

import Data.Char (isDigit)
import Network.Socket
import Numeric (showHex)

import Crypto.System.CPU
import Data.X509.CertificateStore
import System.X509

import Network.TLS hiding (HostName)
import Network.TLS.Extra.Cipher
import Network.TLS.Extra.FFDHE

import Imports

namedDHParams :: [(String, DHParams)]
namedDHParams =
    [ ("ffdhe2048", ffdhe2048)
    , ("ffdhe3072", ffdhe3072)
    , ("ffdhe4096", ffdhe4096)
    , ("ffdhe6144", ffdhe6144)
    , ("ffdhe8192", ffdhe8192)
    ]

namedCiphersuites :: [(String, [CipherID])]
namedCiphersuites =
    [ ("all", map cipherID ciphersuite_all)
    , ("default", map cipherID ciphersuite_default)
    , ("strong", map cipherID ciphersuite_strong)
    ]

namedGroups :: [(String, Group)]
namedGroups =
    [ ("ffdhe2048", FFDHE2048)
    , ("ffdhe3072", FFDHE3072)
    , ("ffdhe4096", FFDHE4096)
    , ("ffdhe6144", FFDHE6144)
    , ("ffdhe8192", FFDHE8192)
    , ("p256", P256)
    , ("p384", P384)
    , ("p521", P521)
    , ("x25519", X25519)
    , ("x448", X448)
    ]

readNumber :: (Num a, Read a) => String -> Maybe a
readNumber s
    | all isDigit s = Just $ read s
    | otherwise = Nothing

readCiphers :: String -> Maybe [CipherID]
readCiphers s =
    case lookup s namedCiphersuites of
        Nothing -> (: []) `fmap` readNumber s
        just -> just

readDHParams :: String -> IO (Maybe DHParams)
readDHParams s =
    case lookup s namedDHParams of
        Nothing -> (Just . read) `fmap` readFile s
        mparams -> return mparams

readGroups :: String -> Maybe [Group]
readGroups s = traverse (`lookup` namedGroups) (split ',' s)

printCiphers :: IO ()
printCiphers = do
    putStrLn "Supported ciphers"
    putStrLn "====================================="
    forM_ ciphersuite_all_det $ \c ->
        putStrLn
            ( pad 50 (cipherName c)
                ++ " = "
                ++ pad 5 (show $ cipherID c)
                ++ "  0x"
                ++ showHex (cipherID c) ""
            )
    putStrLn ""
    putStrLn "Ciphersuites"
    putStrLn "====================================="
    forM_ namedCiphersuites $ \(name, _) -> putStrLn name
    putStrLn ""
    putStrLn
        ("Using crypton-" ++ VERSION_crypton ++ " with CPU support for: " ++ cpuSupport)
  where
    pad n s
        | length s < n = s ++ replicate (n - length s) ' '
        | otherwise = s

    cpuSupport
        | null processorOptions = "(nothing)"
        | otherwise = intercalate ", " (map show processorOptions)

printDHParams :: IO ()
printDHParams = do
    putStrLn "DH Parameters"
    putStrLn "====================================="
    forM_ namedDHParams $ \(name, _) -> putStrLn name
    putStrLn "(or /path/to/dhparams)"

printGroups :: IO ()
printGroups = do
    putStrLn "Groups"
    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
    ("", r) -> split c (tail r)
    (s', "") -> [s']
    (s', r) -> s' : split c (tail r)

getCertificateStore :: [FilePath] -> IO CertificateStore
getCertificateStore [] = getSystemCertificateStore
getCertificateStore paths = foldM readPathAppend mempty paths
  where
    readPathAppend acc path = do
        mstore <- readCertificateStore path
        case mstore of
            Nothing -> error ("invalid certificate store: " ++ path)
            Just st -> return $! mappend st acc