! 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 ;