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 IN: checksums.openssl
   6
   7 ERROR: unknown-digest name ;
   8
   9 TUPLE: openssl-checksum name ;
  10
  11 : openssl-md5 T{ openssl-checksum f "md5" } ;
  12
  13 : openssl-sha1 T{ openssl-checksum f "sha1" } ;
  14
  15 INSTANCE: openssl-checksum checksum
  16
  17 C: <openssl-checksum> openssl-checksum
  18
  19 <PRIVATE
  20
  21 TUPLE: evp-md-context handle ;
  22
  23 : <evp-md-context> ( -- ctx )
  24     "EVP_MD_CTX" <c-object>
  25     dup EVP_MD_CTX_init evp-md-context boa ;
  26
  27 M: evp-md-context dispose
  28     handle>> EVP_MD_CTX_cleanup drop ;
  29
  30 : with-evp-md-context ( quot -- )
  31     maybe-init-ssl >r <evp-md-context> r> with-disposal ; inline
  32
  33 : digest-named ( name -- md )
  34     dup EVP_get_digestbyname
  35     [ ] [ unknown-digest ] ?if ;
  36
  37 : set-digest ( name ctx -- )
  38     handle>> swap digest-named f EVP_DigestInit_ex ssl-error ;
  39
  40 : checksum-loop ( ctx -- )
  41     dup handle>>
  42     4096 read-partial dup [
  43         dup length EVP_DigestUpdate ssl-error
  44         checksum-loop
  45     ] [ 3drop ] if ;
  46
  47 : digest-value ( ctx -- value )
  48     handle>>
  49     EVP_MAX_MD_SIZE <byte-array> 0 <int>
  50     [ EVP_DigestFinal_ex ssl-error ] 2keep
  51     *int memory>byte-array ;
  52
  53 PRIVATE>
  54
  55 M: openssl-checksum checksum-stream
  56     name>> swap [
  57         [
  58             [ set-digest ]
  59             [ checksum-loop ]
  60             [ digest-value ]
  61             tri
  62         ] with-evp-md-context
  63     ] with-input-stream ;