/unmaintained/cryptlib/cryptlib.factor

http://github.com/abeaumont/factor · Factor · 234 lines · 137 code · 62 blank · 35 comment · 5 complexity · 6ec53ea5412f9dfb8adc3b05e42d60e8 MD5 · raw file

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