/unmaintained/cryptlib/cryptlib.factor
http://github.com/abeaumont/factor · Factor · 234 lines · 137 code · 62 blank · 35 comment · 5 complexity · 6ec53ea5412f9dfb8adc3b05e42d60e8 MD5 · raw file
- ! Copyright (C) 2007 Elie CHAFTARI
- ! See http://factorcode.org/license.txt for BSD license.
- ! libs/cryptib/cryptlib.factor
- ! Adapted from cryptlib.h
- ! Tested with cryptlib 3.3.1.0
- USING: cryptlib.libcl kernel hashtables alien math
- namespaces sequences assocs libc alien.c-types alien.accessors continuations ;
- IN: cryptlib
- SYMBOL: keyset
- SYMBOL: certificate
- SYMBOL: cert-buffer
- SYMBOL: cert-length
- SYMBOL: context
- SYMBOL: envelope
- SYMBOL: bytes-copied
- SYMBOL: pop-buffer
- SYMBOL: session
- ! =========================================================
- ! Error-handling routines
- ! =========================================================
- : check-result ( result -- )
- dup CRYPT_OK = [
- drop
- ] [
- dup CRYPT_ENVELOPE_RESOURCE = [
- throw
- ] [
- dup error-messages >hashtable at throw
- ] if
- ] if ;
- ! =========================================================
- ! Secure pointer-freeing routines
- ! =========================================================
- : secure-free ( ptr n -- )
- [ dupd 0 -rot set-alien-unsigned-1 ] each free ;
- : secure-free-array ( ptr n type -- )
- heap-size * [ dupd 0 -rot set-alien-unsigned-1 ] each free ;
- : secure-free-object ( ptr type -- )
- 1 swap secure-free-array ;
- ! =========================================================
- ! Initialise and shut down cryptlib
- ! =========================================================
- : init ( -- )
- cryptInit check-result ;
- : end ( -- )
- cryptEnd check-result ;
- : with-cryptlib ( quot -- )
- [ init [ end ] [ ] cleanup ] with-scope ; inline
- ! =========================================================
- ! Create and destroy an encryption context
- ! =========================================================
- : create-context ( algo -- )
- >r "int" <c-object> dup swap CRYPT_UNUSED r> cryptCreateContext
- check-result context set ;
- : destroy-context ( -- )
- context get [ *int cryptDestroyContext check-result ] when*
- context off ;
- : with-context ( algo quot -- )
- swap create-context [ destroy-context ] [ ] cleanup ; inline
- ! =========================================================
- ! Keyset routines
- ! =========================================================
- : open-keyset ( type name options -- )
- >r >r >r "int" <c-object> dup swap CRYPT_UNUSED r> r> string>char-alien
- r> cryptKeysetOpen check-result keyset set ;
- : close-keyset ( -- )
- keyset get *int cryptKeysetClose check-result
- destroy-context ;
- : with-keyset ( type name options quot -- )
- >r open-keyset r> [ close-keyset ] [ ] cleanup ; inline
- : get-public-key ( idtype id -- )
- >r >r keyset get *int "int*" <c-object> tuck r> r> string>char-alien
- cryptGetPublicKey check-result context set ;
- : get-private-key ( idtype id password -- )
- >r >r >r keyset get *int "int*" <c-object> tuck r>
- r> string>char-alien r> string>char-alien cryptGetPrivateKey
- check-result context set ;
- : get-key ( idtype id password -- )
- >r >r >r keyset get *int "int*" <c-object> tuck r>
- r> string>char-alien r> string>char-alien cryptGetKey
- check-result context set ;
- : add-public-key ( -- )
- keyset get *int certificate get *int cryptAddPublicKey check-result ;
- : add-private-key ( password -- )
- >r keyset get *int context get *int r> string>char-alien
- cryptAddPrivateKey check-result ;
- : delete-key ( type id -- )
- >r >r keyset get *int r> r> string>char-alien cryptDeleteKey
- check-result ;
- ! =========================================================
- ! Certificate routines
- ! =========================================================
- : create-certificate ( type -- )
- >r "int" <c-object> dup swap CRYPT_UNUSED r>
- cryptCreateCert check-result certificate set ;
- : destroy-certificate ( -- )
- certificate get *int cryptDestroyCert check-result ;
- : with-certificate ( type quot -- )
- swap create-certificate [ destroy-certificate ] [ ] cleanup ; inline
- : sign-certificate ( -- )
- certificate get *int context get *int cryptSignCert check-result ;
- : check-certificate ( -- )
- certificate get *int context get *int cryptCheckCert check-result ;
- : import-certificate ( certbuffer length -- )
- >r r> CRYPT_UNUSED "int*" malloc-object dup >r
- cryptImportCert check-result r> certificate set ;
- : export-certificate ( certbuffer maxlength format -- )
- >r >r dup swap r> "int*" malloc-object dup r> swap >r
- certificate get *int cryptExportCert check-result
- cert-buffer set r> cert-length set ;
- ! =========================================================
- ! Generate a key into a context
- ! =========================================================
- : generate-key ( handle -- )
- *int cryptGenerateKey check-result ;
- ! =========================================================
- ! Get/set/delete attribute functions
- ! =========================================================
- : set-attribute ( handle attribute value -- )
- >r >r *int r> r> cryptSetAttribute check-result ;
- : set-attribute-string ( handle attribute value -- )
- >r >r *int r> r> dup length swap string>char-alien swap
- cryptSetAttributeString check-result ;
- ! =========================================================
- ! Envelope and Session routines
- ! =========================================================
- : create-envelope ( format -- )
- >r "int" <c-object> dup swap CRYPT_UNUSED r> cryptCreateEnvelope
- check-result envelope set ;
- : destroy-envelope ( -- )
- envelope get *int cryptDestroyEnvelope check-result ;
- : with-envelope ( format quot -- )
- swap create-envelope [ destroy-envelope ] [ ] cleanup ;
- : create-session ( format -- )
- >r "int" <c-object> dup swap CRYPT_UNUSED r> cryptCreateSession
- check-result session set ;
- : destroy-session ( -- )
- session get *int cryptDestroySession check-result ;
- : with-session ( format quot -- )
- swap create-session [ destroy-session ] [ ] cleanup ;
- : push-data ( handle buffer length -- )
- >r >r *int r> r> "int" <c-object> [ cryptPushData ]
- keep swap check-result bytes-copied set ;
- : flush-data ( handle -- )
- *int cryptFlushData check-result ;
- : pop-data ( handle length -- )
- dup >r >r *int r> "uchar*" malloc-array
- dup r> swap >r "int" <c-object> [ cryptPopData ] keep
- swap check-result bytes-copied set r> pop-buffer set ;
- ! =========================================================
- ! Public routines
- ! =========================================================
- : envelope-handle ( -- envelope )
- envelope get ;
- : context-handle ( -- context )
- context get ;
- : certificate-handle ( -- certificate )
- certificate get ;
- : session-handle ( -- session )
- session get ;
- : set-pop-buffer ( data -- )
- string>char-alien pop-buffer set ;
- : get-pop-buffer ( -- buffer )
- pop-buffer get ;
- : pop-buffer-string ( -- s )
- pop-buffer get alien>char-string ;
- : get-bytes-copied ( -- value )
- bytes-copied get *int ;
- : get-cert-buffer ( -- certreq )
- cert-buffer get ;
- : get-cert-length ( -- certlength )
- cert-length get ;