2009-09-17 23:07:21 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								USING: accessors alien.c-types alien.data byte-arrays
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-20 20:30:35 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								combinators.short-circuit continuations destructors init kernel
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								locals namespaces random windows.advapi32 windows.errors
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-28 23:45:19 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								windows.kernel32 windows.types math.bitwise sequences fry
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								literals ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-19 17:18:03 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								IN: random.windows
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2009-11-18 11:01:00 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								TUPLE: windows-rng provider type ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								C: <windows-rng> windows-rng
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-28 23:10:01 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								TUPLE: windows-crypto-context handle ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-28 23:10:01 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								C: <windows-crypto-context> windows-crypto-context
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: windows-crypto-context dispose ( tuple -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    handle>> 0 CryptReleaseContext win32-error=0/f ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-20 20:30:35 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								CONSTANT: factor-crypto-container "FactorCryptoContainer"
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-20 20:30:35 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								:: (acquire-crypto-context) ( provider type flags -- handle ret )
							 | 
						
					
						
							
								
									
										
										
										
											2009-11-20 02:37:24 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    HCRYPTPROV <c-object> :> handle
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-20 20:30:35 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    handle
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    factor-crypto-container
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    provider
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    type
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    flags
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    CryptAcquireContextW handle swap ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: acquire-crypto-context ( provider type -- handle )
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-22 18:15:40 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    CRYPT_MACHINE_KEYSET
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    (acquire-crypto-context)
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-20 20:30:35 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    0 = [
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        GetLastError NTE_BAD_KEYSET =
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ drop f ] [ win32-error-string throw ] if
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] [
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        *void*
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] if ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-20 20:30:35 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: create-crypto-context ( provider type -- handle )
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-22 18:18:24 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    (acquire-crypto-context) win32-error=0/f *void* ;
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-20 20:30:35 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								ERROR: acquire-crypto-context-failed provider type ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: attempt-crypto-context ( provider type -- handle )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    {
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ acquire-crypto-context ] 
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ create-crypto-context ] 
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ acquire-crypto-context-failed ]
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    } 2|| ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: windows-crypto-context ( provider type -- context )
							 | 
						
					
						
							
								
									
										
										
										
											2009-05-20 20:40:52 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    attempt-crypto-context <windows-crypto-context> ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: windows-rng random-bytes* ( n tuple -- bytes )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ provider>> ] [ type>> ] bi
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-14 20:03:07 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        windows-crypto-context &dispose
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        handle>> swap dup <byte-array>
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ CryptGenRandom win32-error=0/f ] keep
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] with-destructors ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-29 00:28:11 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								ERROR: no-windows-crypto-provider error ;
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-28 23:45:19 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: try-crypto-providers ( seq -- windows-rng )
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-29 00:28:11 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    [ first2 <windows-rng> ] attempt-all
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    dup windows-rng? [ no-windows-crypto-provider ] unless ;
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-28 23:45:19 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								[
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-28 23:45:19 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    {
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        ${ MS_ENHANCED_PROV PROV_RSA_FULL }
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        ${ MS_DEF_PROV PROV_RSA_FULL }
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    } try-crypto-providers
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    system-random-generator set-global
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2010-01-28 23:45:19 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    {
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        ${ MS_STRONG_PROV PROV_RSA_FULL }
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        ${ MS_ENH_RSA_AES_PROV PROV_RSA_AES }
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    } try-crypto-providers secure-random-generator set-global
							 | 
						
					
						
							
								
									
										
										
										
											2009-10-19 22:17:02 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								] "random.windows" add-startup-hook
							 | 
						
					
						
							
								
									
										
										
										
											2008-03-29 15:25:57 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2009-10-19 22:17:02 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								[
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [
							 | 
						
					
						
							
								
									
										
										
										
											2009-11-30 17:59:40 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        ! system-random-generator get-global &dispose drop
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        ! secure-random-generator get-global &dispose drop
							 | 
						
					
						
							
								
									
										
										
										
											2009-10-19 22:17:02 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    ] with-destructors
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								] "random.windows" add-shutdown-hook
							 |