235 lines
6.9 KiB
Factor
235 lines
6.9 KiB
Factor
! 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 ;
|