basis/checksums/openssl/openssl.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors byte-arrays alien.c-types alien.data kernel
   4 continuations destructors sequences io openssl openssl.libcrypto
   5 checksums checksums.stream classes.struct ;
   6 IN: checksums.openssl
   7
   8 ERROR: unknown-digest name ;
   9
  10 TUPLE: openssl-checksum name ;
  11
  12 CONSTANT: openssl-md5 T{ openssl-checksum f "md5" }
  13
  14 CONSTANT: 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 < disposable handle ;
  23
  24 : <evp-md-context> ( -- ctx )
  25     evp-md-context new-disposable
  26     EVP_MD_CTX_create >>handle ;
  27
  28 M: evp-md-context dispose*
  29     handle>> EVP_MD_CTX_destroy ;
  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     { { int EVP_MAX_MD_SIZE } int }
  51     [ EVP_DigestFinal_ex ssl-error ]
  52     [ memory>byte-array ]
  53     with-out-parameters ;
  54
  55 PRIVATE>
  56
  57 M: openssl-checksum checksum-stream
  58     name>> swap [
  59         [
  60             [ set-digest ]
  61             [ checksum-loop ]
  62             [ digest-value ]
  63             tri
  64         ] with-evp-md-context
  65     ] with-input-stream ;