basis/checksums/openssl/openssl.factor

   1 ! Copyright (C) 2008 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors byte-arrays alien.c-types kernel continuations
   4 destructors sequences io openssl openssl.libcrypto checksums
   5 checksums.stream ;
   6 IN: checksums.openssl
   7
   8 ERROR: unknown-digest name ;
   9
  10 TUPLE: openssl-checksum name ;
  11
  12 : openssl-md5 T{ openssl-checksum f "md5" } ;
  13
  14 : openssl-sha1 T{ openssl-checksum f "sha1" } ;
  15
  16 INSTANCE: openssl-checksum stream-checksum
  17
  18 C: <openssl-checksum> openssl-checksum
  19
  20 <PRIVATE
  21
  22 TUPLE: evp-md-context handle ;
  23
  24 : <evp-md-context> ( -- ctx )
  25     "EVP_MD_CTX" <c-object>
  26     dup EVP_MD_CTX_init evp-md-context boa ;
  27
  28 M: evp-md-context dispose
  29     handle>> EVP_MD_CTX_cleanup drop ;
  30
  31 : with-evp-md-context ( quot -- )
  32     maybe-init-ssl [ <evp-md-context> ] dip with-disposal ; inline
  33
  34 : digest-named ( name -- md )
  35     dup EVP_get_digestbyname
  36     [ ] [ unknown-digest ] ?if ;
  37
  38 : set-digest ( name ctx -- )
  39     handle>> swap digest-named f EVP_DigestInit_ex ssl-error ;
  40
  41 : checksum-loop ( ctx -- )
  42     dup handle>>
  43     4096 read-partial dup [
  44         dup length EVP_DigestUpdate ssl-error
  45         checksum-loop
  46     ] [ 3drop ] if ;
  47
  48 : digest-value ( ctx -- value )
  49     handle>>
  50     EVP_MAX_MD_SIZE <byte-array> 0 <int>
  51     [ EVP_DigestFinal_ex ssl-error ] 2keep
  52     *int memory>byte-array ;
  53
  54 PRIVATE>
  55
  56 M: openssl-checksum checksum-stream
  57     name>> swap [
  58         [
  59             [ set-digest ]
  60             [ checksum-loop ]
  61             [ digest-value ]
  62             tri
  63         ] with-evp-md-context
  64     ] with-input-stream ;