| 
									
										
										
										
											2013-10-07 11:14:24 -04:00
										 |  |  | USING: | 
					
						
							|  |  |  |     arrays | 
					
						
							|  |  |  |     kernel | 
					
						
							|  |  |  |     math | 
					
						
							|  |  |  |     openssl.libssl | 
					
						
							|  |  |  |     sequences | 
					
						
							|  |  |  |     tools.test ;
 | 
					
						
							|  |  |  | IN: openssl.libssl.tests | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : all-opts ( -- opts )
 | 
					
						
							|  |  |  |     { | 
					
						
							|  |  |  |         SSL_OP_NO_SSLv2 | 
					
						
							|  |  |  |         SSL_OP_NO_SSLv3 | 
					
						
							|  |  |  |         SSL_OP_NO_TLSv1 | 
					
						
							|  |  |  |         SSL_OP_NO_TLSv1_1 | 
					
						
							|  |  |  |         SSL_OP_NO_TLSv1_2 | 
					
						
							|  |  |  |     } [ execute( -- x ) ] map ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : set-opt ( ctx op -- )
 | 
					
						
							|  |  |  |     SSL_CTRL_OPTIONS swap f SSL_CTX_ctrl drop ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : has-opt ( ctx op -- ? )
 | 
					
						
							|  |  |  |     swap SSL_CTRL_OPTIONS 0 f SSL_CTX_ctrl bitand 0 > ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : new-ctx ( -- ctx )
 | 
					
						
							| 
									
										
										
										
											2016-03-01 19:42:08 -05:00
										 |  |  |     TLSv1_client_method SSL_CTX_new ;
 | 
					
						
							| 
									
										
										
										
											2013-10-07 11:14:24 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : new-ssl ( -- ssl )
 | 
					
						
							|  |  |  |     new-ctx SSL_new ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ! Test default options | 
					
						
							| 
									
										
										
										
											2015-07-03 12:39:59 -04:00
										 |  |  | { { f f f f f } } [ new-ctx all-opts [ has-opt ] with map ] unit-test | 
					
						
							| 
									
										
										
										
											2013-10-07 11:14:24 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | ! Test setting options | 
					
						
							| 
									
										
										
										
											2015-07-03 12:39:59 -04:00
										 |  |  | { 5 } [ | 
					
						
							| 
									
										
										
										
											2013-10-07 11:14:24 -04:00
										 |  |  |     new-ctx all-opts [ [ set-opt ] [ has-opt ] 2bi ] with map [ t = ] count
 | 
					
						
							|  |  |  | ] unit-test | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ! Initial state | 
					
						
							| 
									
										
										
										
											2015-07-03 12:39:59 -04:00
										 |  |  | { { "before/connect initialization" "read header" 1 f } } [ | 
					
						
							| 
									
										
										
										
											2013-10-07 11:14:24 -04:00
										 |  |  |     new-ssl { | 
					
						
							|  |  |  |         SSL_state_string_long | 
					
						
							|  |  |  |         SSL_rstate_string_long | 
					
						
							|  |  |  |         SSL_want | 
					
						
							|  |  |  |         SSL_get_peer_certificate | 
					
						
							|  |  |  |     } [ execute( x -- x ) ] with map
 | 
					
						
							|  |  |  | ] unit-test |