/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
  8USING: cryptlib.libcl kernel hashtables alien math 
  9namespaces sequences assocs libc alien.c-types alien.accessors continuations ;
 10
 11IN: cryptlib
 12
 13SYMBOL: keyset
 14SYMBOL: certificate
 15SYMBOL: cert-buffer
 16SYMBOL: cert-length
 17SYMBOL: context
 18SYMBOL: envelope
 19SYMBOL: bytes-copied
 20SYMBOL: pop-buffer
 21SYMBOL: 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 ;