-
Notifications
You must be signed in to change notification settings - Fork 88
/
Connection.hs
125 lines (109 loc) · 3.63 KB
/
Connection.hs
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
121
122
123
124
125
module Tests.Connection
( newPairContext
, arbitraryPairParams
, setPairParamsSessionSaving
, setPairParamsSessionResuming
) where
import Test.QuickCheck
import Tests.Certificate
import Tests.PubKey
import Tests.PipeChan
import Network.TLS
import Network.TLS.Core
import Network.TLS.Cipher
import Network.TLS.Crypto
import Control.Concurrent
import qualified Crypto.Random.AESCtr as RNG
import qualified Data.ByteString as B
debug = False
blockCipher :: Cipher
blockCipher = Cipher
{ cipherID = 0xff12
, cipherName = "rsa-id-const"
, cipherBulk = Bulk
{ bulkName = "id"
, bulkKeySize = 16
, bulkIVSize = 16
, bulkBlockSize = 16
, bulkF = BulkBlockF (\k iv m -> m) (\k iv m -> m)
}
, cipherHash = Hash
{ hashName = "const-hash"
, hashSize = 16
, hashF = (\_ -> B.replicate 16 1)
}
, cipherKeyExchange = CipherKeyExchange_RSA
, cipherMinVer = Nothing
}
streamCipher = blockCipher
{ cipherID = 0xff13
, cipherBulk = Bulk
{ bulkName = "stream"
, bulkKeySize = 16
, bulkIVSize = 0
, bulkBlockSize = 0
, bulkF = BulkStreamF (\k -> k) (\i m -> (m,i)) (\i m -> (m,i))
}
}
nullCipher = blockCipher
{ cipherID = 0xff14
, cipherBulk = Bulk
{ bulkName = "null"
, bulkKeySize = 0
, bulkIVSize = 0
, bulkBlockSize = 0
, bulkF = BulkNoneF
}
}
supportedCiphers :: [Cipher]
supportedCiphers = [blockCipher,streamCipher,nullCipher]
supportedVersions :: [Version]
supportedVersions = [SSL3,TLS10,TLS11,TLS12]
arbitraryPairParams = do
let (pubKey, privKey) = getGlobalRSAPair
servCert <- arbitraryX509WithPublicKey pubKey
allowedVersions <- arbitraryVersions
connectVersion <- elements supportedVersions `suchThat` (\c -> c `elem` allowedVersions)
serverCiphers <- arbitraryCiphers
clientCiphers <- oneof [arbitraryCiphers] `suchThat` (\cs -> or [x `elem` serverCiphers | x <- cs])
secNeg <- arbitrary
let serverState = defaultParams
{ pAllowedVersions = allowedVersions
, pCiphers = serverCiphers
, pCertificates = [(servCert, Just $ PrivRSA privKey)]
, pUseSecureRenegotiation = secNeg
, pLogging = logging "server: "
}
let clientState = defaultParams
{ pConnectVersion = connectVersion
, pAllowedVersions = allowedVersions
, pCiphers = clientCiphers
, pUseSecureRenegotiation = secNeg
, pLogging = logging "client: "
}
return (clientState, serverState)
where
logging pre = if debug
then defaultLogging
{ loggingPacketSent = putStrLn . ((pre ++ ">> ") ++)
, loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) }
else defaultLogging
arbitraryVersions :: Gen [Version]
arbitraryVersions = resize (length supportedVersions + 1) $ listOf1 (elements supportedVersions)
arbitraryCiphers = resize (length supportedCiphers + 1) $ listOf1 (elements supportedCiphers)
setPairParamsSessionSaving f (clientState, serverState) = (nc,ns)
where
nc = clientState { onSessionEstablished = f }
ns = serverState { onSessionEstablished = f }
setPairParamsSessionResuming sessionStuff (clientState, serverState) = (nc,ns)
where
nc = clientState { sessionResumeWith = Just sessionStuff }
ns = serverState { onSessionResumption = \s ->
return $ if s == fst sessionStuff then Just (snd sessionStuff) else Nothing }
newPairContext pipe (cParams, sParams) = do
let noFlush = return ()
cRNG <- RNG.makeSystem
sRNG <- RNG.makeSystem
cCtx' <- clientWith cParams cRNG () noFlush (writePipeA pipe) (readPipeA pipe)
sCtx' <- serverWith sParams sRNG () noFlush (writePipeB pipe) (readPipeB pipe)
return (cCtx', sCtx')