1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
{-# LANGUAGE CPP #-}
-- Disable this warning so we can still test deprecated functionality.
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module Common (
printDHParams,
printGroups,
readNumber,
readDHParams,
readGroups,
getCertificateStore,
getLogger,
namedGroups,
getInfo,
printHandshakeInfo,
) where
import Data.Char (isDigit)
import Data.X509.CertificateStore
import Network.TLS hiding (HostName)
import Network.TLS.Extra.FFDHE
import System.Exit
import System.X509
import Imports
namedDHParams :: [(String, DHParams)]
namedDHParams =
[ ("ffdhe2048", ffdhe2048)
, ("ffdhe3072", ffdhe3072)
, ("ffdhe4096", ffdhe4096)
, ("ffdhe6144", ffdhe6144)
, ("ffdhe8192", ffdhe8192)
]
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
readDHParams :: String -> IO (Maybe DHParams)
readDHParams s =
case lookup s namedDHParams of
Nothing -> (Just . read) `fmap` readFile s
mparams -> return mparams
readGroups :: String -> [Group]
readGroups s = case traverse (`lookup` namedGroups) (split ',' s) of
Nothing -> []
Just gs -> gs
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
split :: Char -> String -> [String]
split _ "" = []
split c s = case break (c ==) s of
("", _ : rs) -> split c rs
(s', "") -> [s']
(s', _ : rs) -> s' : split c rs
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
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)
|
