From cee0eb5be35153212da887ab09e903b9400b3101 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Mar 2008 14:25:57 -0500 Subject: [PATCH 1/6] fix secure-random-generator for windows --- extra/random/windows/windows.factor | 57 ++++++++++++++++++-------- extra/windows/advapi32/advapi32.factor | 34 +++++++++++++++ 2 files changed, 74 insertions(+), 17 deletions(-) diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index e0c564bc2c..cd69105e65 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -1,31 +1,54 @@ USING: accessors alien.c-types byte-arrays continuations -kernel windows windows.advapi32 init namespaces random ; +kernel windows windows.advapi32 init namespaces random +destructors locals ; +USE: tools.walker IN: random.windows -TUPLE: windows-crypto-context handle ; +TUPLE: windows-rng provider type ; +C: windows-rng +TUPLE: windows-crypto-context handle ; C: windows-crypto-context M: windows-crypto-context dispose ( tuple -- ) handle>> 0 CryptReleaseContext win32-error=0/f ; -TUPLE: windows-cryptographic-rng context ; +: factor-crypto-container ( -- string ) "FactorCryptoContainer" ; inline -C: windows-cryptographic-rng +:: (acquire-crypto-context) ( provider type flags -- handle ) + [let | handle [ "HCRYPTPROV" ] | + handle + factor-crypto-container + provider + type + flags + CryptAcquireContextW win32-error=0/f + handle *void* ] ; -M: windows-cryptographic-rng dispose ( tuple -- ) - context>> dispose ; +: acquire-crypto-context ( provider type -- handle ) + [ 0 (acquire-crypto-context) ] + [ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ; -M: windows-cryptographic-rng random-bytes* ( tuple n -- bytes ) - >r context>> r> dup - [ CryptGenRandom win32-error=0/f ] keep ; -: windows-aes-context ( -- context ) - "HCRYPTPROV" - dup f f PROV_RSA_AES CRYPT_NEWKEYSET - CryptAcquireContextW win32-error=0/f *void* - ; +: windows-crypto-context ( provider type -- context ) + acquire-crypto-context ; -! [ - ! windows-aes-context secure-random-generator set-global -! ] "random.windows" add-init-hook +M: windows-rng random-bytes* ( n tuple -- bytes ) + [ + [ provider>> ] [ type>> ] bi + windows-crypto-context + dup add-always-destructor handle>> + swap dup + [ CryptGenRandom win32-error=0/f ] keep + ] with-destructors ; + +[ + MS_DEF_PROV + PROV_RSA_FULL insecure-random-generator set-global + + ! MS_STRONG_PROV + ! PROV_RSA_FULL secure-random-generator set-global + + MS_ENH_RSA_AES_PROV + PROV_RSA_AES secure-random-generator set-global +] "random.windows" add-init-hook diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor index 0be82551a1..28091d3d9d 100644 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -21,6 +21,40 @@ LIBRARY: advapi32 : PROV_REPLACE_OWF 23 ; inline : PROV_RSA_AES 24 ; inline +: MS_DEF_DH_SCHANNEL_PROV + "Microsoft DH Schannel Cryptographic Provider" ; inline + +: MS_DEF_DSS_DH_PROV + "Microsoft Base DSS and Diffie-Hellman Cryptographic Provider" ; inline + +: MS_DEF_DSS_PROV + "Microsoft Base DSS Cryptographic Provider" ; inline + +: MS_DEF_PROV + "Microsoft Base Cryptographic Provider v1.0" ; inline + +: MS_DEF_RSA_SCHANNEL_PROV + "Microsoft RSA Schannel Cryptographic Provider" ; inline + +! Unsupported (!) +: MS_DEF_RSA_SIG_PROV + "Microsoft RSA Signature Cryptographic Provider" ; inline + +: MS_ENH_DSS_DH_PROV + "Microsoft Enhanced DSS and Diffie-Hellman Cryptographic Provider" ; inline + +: MS_ENH_RSA_AES_PROV + "Microsoft Enhanced RSA and AES Cryptographic Provider" ; inline + +: MS_ENHANCED_PROV + "Microsoft Enhanced Cryptographic Provider v1.0" ; inline + +: MS_SCARD_PROV + "Microsoft Base Smart Card Crypto Provider" ; inline + +: MS_STRONG_PROV + "Microsoft Strong Cryptographic Provider" ; inline + : CRYPT_VERIFYCONTEXT HEX: F0000000 ; inline : CRYPT_NEWKEYSET HEX: 8 ; inline : CRYPT_DELETEKEYSET HEX: 10 ; inline From a15159af6944c1a341b581b81592cd997b2aac3b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Mar 2008 14:50:52 -0500 Subject: [PATCH 2/6] add summary on error --- extra/random/random.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/random/random.factor b/extra/random/random.factor index c1701b1c0f..1168a4dd45 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -19,6 +19,9 @@ M: object random-32* ( tuple -- r ) 4 random-bytes* le> ; ERROR: no-random-number-generator ; +M: no-random-number-generator summary + drop "Random number generator is not defined." ; + M: f random-bytes* ( n obj -- * ) no-random-number-generator ; M: f random-32* ( obj -- * ) no-random-number-generator ; From 72cedcaf477c3aa119bbf2cf8cceb5cd5c31d66f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Mar 2008 14:51:50 -0500 Subject: [PATCH 3/6] add using --- extra/random/random.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/random/random.factor b/extra/random/random.factor index 1168a4dd45..b1c57ede60 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel math namespaces sequences -io.backend io.binary combinators system vocabs.loader ; +io.backend io.binary combinators system vocabs.loader +inspector ; IN: random SYMBOL: insecure-random-generator From fbdf62bb1cf45809ed64061220c7aa9569cc64d9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 29 Mar 2008 16:18:46 -0400 Subject: [PATCH 4/6] Making [ mpg ] undo work --- extra/inverse/inverse.factor | 55 +++++++++++++++++++--------------- extra/units/units-tests.factor | 4 +-- extra/units/units.factor | 6 ++++ 3 files changed, 38 insertions(+), 27 deletions(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 308bf36bf4..f4bd403b75 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -1,7 +1,8 @@ USING: kernel words inspector slots quotations sequences assocs math arrays inference effects shuffle continuations debugger tuples namespaces vectors bit-arrays byte-arrays strings sbufs -math.functions macros sequences.private combinators mirrors ; +math.functions macros sequences.private combinators mirrors +combinators.lib ; IN: inverse TUPLE: fail ; @@ -59,38 +60,44 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ; PREDICATE: pop-inverse < word "pop-length" word-prop ; UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; -: inline-word ( word -- ) - { - { [ dup word? not over symbol? or ] [ , ] } - { [ dup explicit-inverse? ] [ , ] } - ! { [ dup compound? over { if dispatch } member? not and ] - ! [ word-def [ inline-word ] each ] } - { [ dup word? over { if dispatch } member? not and ] - [ word-def [ inline-word ] each ] } - { [ drop t ] [ "Quotation is not invertible" throw ] } - } cond ; +: enough? ( stack quot -- ? ) + [ >r length r> 1quotation infer effect-in >= ] [ 3drop f ] + recover ; -: math-exp? ( n n word -- ? ) - { + - * / ^ } member? -rot [ number? ] both? and ; +: fold-word ( stack quot -- stack ) + 2dup enough? + [ 1quotation with-datastack ] [ >r % r> , { } ] if ; -: (fold-constants) ( quot -- ) - dup length 3 < [ % ] [ - dup first3 3dup math-exp? - [ execute , 3 ] [ 2drop , 1 ] if - tail-slice (fold-constants) - ] if ; +: fold ( quot -- folded-quot ) + [ { } swap [ fold-word ] each % ] [ ] make ; -: fold-constants ( quot -- folded ) - [ (fold-constants) ] [ ] make ; +: flattenable? ( object -- ? ) + [ [ word? ] [ primitive? not ] and? ] [ + { "inverse" "math-inverse" "pop-inverse" } + [ word-prop ] with contains? not + ] and? ; -: do-inlining ( quot -- inlined-quot ) - [ [ inline-word ] each ] [ ] make fold-constants ; +: (flatten) ( quot -- ) + [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ; + + : retain-stack-overflow? ( error -- ? ) + { "kernel-error" 14 f f } = ; + +: flatten ( quot -- expanded ) + [ [ (flatten) ] [ ] make ] [ + dup retain-stack-overflow? + [ drop "No inverse defined on recursive word" ] when + throw + ] recover ; GENERIC: inverse ( revquot word -- revquot* quot ) M: object inverse undo-literal ; + M: symbol inverse undo-literal ; +M: word inverse drop "Inverse is undefined" throw ; + M: normal-inverse inverse "inverse" word-prop ; @@ -108,7 +115,7 @@ M: pop-inverse inverse [ unclip-slice inverse % (undo) ] if ; : [undo] ( quot -- undo ) - do-inlining reverse [ (undo) ] [ ] make ; + flatten fold reverse [ (undo) ] [ ] make ; MACRO: undo ( quot -- ) [undo] ; diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor index 9f0e704157..9b450ed18b 100755 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -15,9 +15,7 @@ IN: units.tests [ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test [ t ] [ 3 m d-recip 1/3 { } { m } = ] unit-test -! I want these to work, Dan - : km/L km 1 L d/ ; : mpg miles 1 gallons d/ ; -! [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test +[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test diff --git a/extra/units/units.factor b/extra/units/units.factor index 13d0a5d1cf..b92cbb659a 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -95,3 +95,9 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; : d-infimum ( v -- d ) unclip-slice [ d-min ] reduce ; : d-supremum ( v -- d ) unclip-slice [ d-max ] reduce ; + +\ d+ [ d- ] [ d- ] define-math-inverse +\ d- [ d+ ] [ d- ] define-math-inverse +\ d* [ d/ ] [ d/ ] define-math-inverse +\ d/ [ d* ] [ d/ ] define-math-inverse +\ d-recip [ d-recip ] define-inverse From 606445f790e290fae775a00c4f5ccb257a713a0b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Mar 2008 15:31:31 -0500 Subject: [PATCH 5/6] improve png --- extra/cairo/ffi/ffi.factor | 3 +++ extra/cairo/png/png.factor | 27 ++++++++++++++++++++++++--- 2 files changed, 27 insertions(+), 3 deletions(-) diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index 76ce27975b..c319ade93b 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -203,6 +203,9 @@ C-ENUM: CAIRO_HINT_METRICS_ON ; +FUNCTION: char* cairo_status_to_string ( cairo_status_t status ) ; +FUNCTION: cairo_status_t cairo_status ( cairo_t* cr ) ; + : cairo_create ( cairo_surface_t -- cairo_t ) "cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ; diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor index eaab28e659..774a1afe8e 100755 --- a/extra/cairo/png/png.factor +++ b/extra/cairo/png/png.factor @@ -1,16 +1,34 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel accessors math ui.gadgets ui.render -opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib ; +opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib +inspector sequences combinators io.backend ; IN: cairo.png TUPLE: png surface width height cairo-t array ; TUPLE: png-gadget png ; +ERROR: cairo-error string ; + +: check-zero + dup zero? [ + "PNG dimension is 0" cairo-error + ] when ; + +: cairo-png-error ( n -- ) + { + { [ dup CAIRO_STATUS_NO_MEMORY = ] [ "Cairo: no memory" cairo-error ] } + { [ dup CAIRO_STATUS_FILE_NOT_FOUND = ] [ "Cairo: file not found" cairo-error ] } + { [ dup CAIRO_STATUS_READ_ERROR = ] [ "Cairo: read error" cairo-error ] } + { [ t ] [ drop ] } + } cond ; + : ( path -- png ) + normalize-pathname cairo_image_surface_create_from_png - dup [ cairo_image_surface_get_width ] - [ cairo_image_surface_get_height ] [ ] tri + dup cairo_surface_status cairo-png-error + dup [ cairo_image_surface_get_width check-zero ] + [ cairo_image_surface_get_height check-zero ] [ ] tri cairo-surface>array png construct-boa ; : write-png ( png path -- ) @@ -33,6 +51,7 @@ M: png-gadget draw-gadget* ( gadget -- ) png>> [ width>> ] [ height>> GL_RGBA GL_UNSIGNED_BYTE ] + ! [ height>> GL_BGRA GL_UNSIGNED_BYTE ] [ array>> ] tri glDrawPixels ] with-translation ; @@ -42,3 +61,5 @@ M: png-gadget graft* ( gadget -- ) M: png-gadget ungraft* ( gadget -- ) png>> surface>> cairo_destroy ; + +! "resource:misc/icons/Factor_1x16.png" USE: cairo.png gadget. From 7174e8cbc4e51dddfc6b258d80e4681428952462 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 15:50:50 -0500 Subject: [PATCH 6/6] Fixing unit test failures --- core/parser/parser-tests.factor | 4 ++-- core/parser/parser.factor | 2 +- core/vocabs/loader/loader-tests.factor | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a15da82718..6bd4abb7e1 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -322,7 +322,7 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ [ no-word? ] is? ] must-fail-with + ] [ [ no-word-error? ] is? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" @@ -332,7 +332,7 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ [ no-word? ] is? ] must-fail-with + ] [ [ no-word-error? ] is? ] must-fail-with [ "IN: parser.tests : foo ; TUPLE: foo ;" diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6e5023f74a..f8836217b5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -252,7 +252,7 @@ PREDICATE: unexpected-eof < unexpected [ "Use the word " swap summary append ] keep ] { } map>assoc ; -ERROR: no-word-error name ; +TUPLE: no-word-error name ; M: no-word-error summary drop "Word not found in current vocabulary search path" ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index fd3b616b87..4b978932bc 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -68,7 +68,7 @@ IN: vocabs.loader.tests "resource:core/vocabs/loader/test/a/a.factor" parse-stream -] [ [ no-word? ] is? ] must-fail-with +] [ [ no-word-error? ] is? ] must-fail-with 0 "count-me" set-global