unmaintained/cryptlib/cryptlib.factor

   1 ! Copyright (C) 2007 Elie CHAFTARI
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 ! libs/cryptib/cryptlib.factor
   5
   6 ! Adapted from cryptlib.h
   7 ! Tested with cryptlib 3.3.1.0
   8 USING: cryptlib.libcl kernel hashtables alien math
   9 namespaces sequences assocs libc alien.c-types alien.accessors continuations ;
  10
  11 IN: cryptlib
  12
  13 SYMBOL: keyset
  14 SYMBOL: certificate
  15 SYMBOL: cert-buffer
  16 SYMBOL: cert-length
  17 SYMBOL: context
  18 SYMBOL: envelope
  19 SYMBOL: bytes-copied
  20 SYMBOL: pop-buffer
  21 SYMBOL: session
  22
  23 ! =========================================================
  24 ! Error-handling routines
  25 ! =========================================================
  26
  27 : check-result ( result -- )
  28     dup CRYPT_OK = [
  29         drop
  30     ] [
  31         dup CRYPT_ENVELOPE_RESOURCE = [
  32             throw
  33         ] [
  34             dup error-messages >hashtable at throw
  35         ] if
  36     ] if ;
  37
  38 ! =========================================================
  39 ! Secure pointer-freeing routines
  40 ! =========================================================
  41
  42 : secure-free ( ptr n -- )
  43     [ dupd 0 -rot set-alien-unsigned-1 ] each free ;
  44
  45 : secure-free-array ( ptr n type -- )
  46     heap-size * [ dupd 0 -rot set-alien-unsigned-1 ] each free ;
  47
  48 : secure-free-object ( ptr type -- )
  49     1 swap secure-free-array ;
  50
  51 ! =========================================================
  52 ! Initialise and shut down cryptlib
  53 ! =========================================================
  54
  55 : init ( -- )
  56     cryptInit check-result ;
  57
  58 : end ( -- )
  59     cryptEnd check-result ;
  60
  61 : with-cryptlib ( quot -- )
  62         [ init [ end ] [ ] cleanup ] with-scope ; inline
  63
  64 ! =========================================================
  65 ! Create and destroy an encryption context
  66 ! =========================================================
  67
  68 : create-context ( algo -- )
  69     >r "int" <c-object> dup swap CRYPT_UNUSED r> cryptCreateContext
  70     check-result context set ;
  71
  72 : destroy-context ( -- )
  73     context get [ *int cryptDestroyContext check-result ] when*
  74         context off ;
  75
  76 : with-context ( algo quot -- )
  77         swap create-context [ destroy-context ] [ ] cleanup ; inline
  78
  79 ! =========================================================
  80 ! Keyset routines
  81 ! =========================================================
  82
  83 : open-keyset ( type name options -- )
  84     >r >r >r "int" <c-object> dup swap CRYPT_UNUSED r> r> string>char-alien
  85     r> cryptKeysetOpen check-result keyset set ;
  86
  87 : close-keyset ( -- )
  88     keyset get *int cryptKeysetClose check-result
  89         destroy-context ;
  90
  91 : with-keyset ( type name options quot -- )
  92         >r open-keyset r> [ close-keyset ] [ ] cleanup ; inline
  93
  94 : get-public-key ( idtype id -- )
  95     >r >r keyset get *int "int*" <c-object> tuck r> r> string>char-alien
  96     cryptGetPublicKey check-result context set ;
  97
  98 : get-private-key ( idtype id password -- )
  99     >r >r >r keyset get *int "int*" <c-object> tuck r>
 100     r> string>char-alien r> string>char-alien cryptGetPrivateKey
 101     check-result context set ;
 102
 103 : get-key ( idtype id password -- )
 104     >r >r >r keyset get *int "int*" <c-object> tuck r>
 105     r> string>char-alien r> string>char-alien cryptGetKey
 106     check-result context set ;
 107
 108 : add-public-key ( -- )
 109     keyset get *int certificate get *int cryptAddPublicKey check-result ;
 110
 111 : add-private-key ( password -- )
 112     >r keyset get *int context get *int r> string>char-alien
 113     cryptAddPrivateKey check-result ;
 114
 115 : delete-key ( type id -- )
 116     >r >r keyset get *int r> r> string>char-alien cryptDeleteKey
 117     check-result ;
 118
 119 ! =========================================================
 120 ! Certificate routines
 121 ! =========================================================
 122
 123 : create-certificate ( type -- )
 124     >r "int" <c-object> dup swap CRYPT_UNUSED r>
 125     cryptCreateCert check-result certificate set ;
 126
 127 : destroy-certificate ( -- )
 128     certificate get *int cryptDestroyCert check-result ;
 129
 130 : with-certificate ( type quot -- )
 131         swap create-certificate [ destroy-certificate ] [ ] cleanup ; inline
 132
 133 : sign-certificate ( -- )
 134     certificate get *int context get *int cryptSignCert check-result ;
 135
 136 : check-certificate ( -- )
 137     certificate get *int context get *int cryptCheckCert check-result ;
 138
 139 : import-certificate ( certbuffer length -- )
 140     >r r> CRYPT_UNUSED "int*" malloc-object dup >r
 141     cryptImportCert check-result r> certificate set ;
 142
 143 : export-certificate ( certbuffer maxlength format -- )
 144     >r >r dup swap r> "int*" malloc-object dup r> swap >r
 145     certificate get *int cryptExportCert check-result
 146     cert-buffer set r> cert-length set ;
 147
 148 ! =========================================================
 149 ! Generate a key into a context
 150 ! =========================================================
 151
 152 : generate-key ( handle -- )
 153     *int cryptGenerateKey check-result ;
 154
 155 ! =========================================================
 156 ! Get/set/delete attribute functions
 157 ! =========================================================
 158
 159 : set-attribute ( handle attribute value -- )
 160     >r >r *int r> r> cryptSetAttribute check-result ;
 161
 162 : set-attribute-string ( handle attribute value -- )
 163     >r >r *int r> r> dup length swap string>char-alien swap
 164     cryptSetAttributeString check-result ;
 165
 166 ! =========================================================
 167 ! Envelope and Session routines
 168 ! =========================================================
 169
 170 : create-envelope ( format -- )
 171     >r "int" <c-object> dup swap CRYPT_UNUSED r> cryptCreateEnvelope
 172     check-result envelope set ;
 173
 174 : destroy-envelope ( -- )
 175     envelope get *int cryptDestroyEnvelope check-result ;
 176
 177 : with-envelope ( format quot -- )
 178         swap create-envelope [ destroy-envelope ] [ ] cleanup ;
 179
 180 : create-session ( format -- )
 181     >r "int" <c-object> dup swap CRYPT_UNUSED r> cryptCreateSession
 182     check-result session set ;
 183
 184 : destroy-session ( -- )
 185     session get *int cryptDestroySession check-result ;
 186
 187 : with-session ( format quot -- )
 188         swap create-session [ destroy-session ] [ ] cleanup ;
 189
 190 : push-data ( handle buffer length -- )
 191     >r >r *int r> r> "int" <c-object> [ cryptPushData ]
 192     keep swap check-result bytes-copied set ;
 193
 194 : flush-data ( handle -- )
 195     *int cryptFlushData check-result ;
 196
 197 : pop-data ( handle length -- )
 198     dup >r >r *int r> "uchar*" malloc-array
 199     dup r> swap >r "int" <c-object> [ cryptPopData ] keep
 200     swap check-result bytes-copied set r> pop-buffer set ;
 201
 202 ! =========================================================
 203 ! Public routines
 204 ! =========================================================
 205
 206 : envelope-handle ( -- envelope )
 207     envelope get ;
 208
 209 : context-handle ( -- context )
 210     context get ;
 211
 212 : certificate-handle ( -- certificate )
 213     certificate get ;
 214
 215 : session-handle ( -- session )
 216     session get ;
 217
 218 : set-pop-buffer ( data -- )
 219     string>char-alien pop-buffer set ;
 220
 221 : get-pop-buffer ( -- buffer )
 222     pop-buffer get ;
 223
 224 : pop-buffer-string ( -- s )
 225     pop-buffer get alien>char-string ;
 226
 227 : get-bytes-copied ( -- value )
 228     bytes-copied get *int ;
 229
 230 : get-cert-buffer ( -- certreq )
 231     cert-buffer get ;
 232
 233 : get-cert-length ( -- certlength )
 234     cert-length get ;