extra/hashcash/hashcash.factor

   1 ! Copyright (C) 2009 Diego Martinelli.
   2 ! Copyright (C) 2022 Zoltán Kéri.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors byte-arrays calendar calendar.format
   5 calendar.parser checksums checksums.openssl classes.tuple
   6 combinators combinators.short-circuit.smart formatting grouping
   7 io io.encodings.ascii io.encodings.string io.streams.string
   8 kernel literals make math math.functions math.parser namespaces
   9 parser present prettyprint quotations random random.passwords
  10 ranges sequences sequences.deep splitting strings typed words ;
  11 IN: hashcash
  12
  13 <PRIVATE
  14
  15 : lastn-digits ( n digits -- string )
  16     [ number>string ] dip [ 48 pad-head ] keep tail* ;
  17
  18 : read-yymmdd ( -- y m d )
  19     read-00 now start-of-millennium year>> + read-00 read-00 ;
  20
  21 TYPED: yymmdd-gmt>timestamp ( yymmdd: string -- timestamp )
  22     [ read-yymmdd <date-gmt> ] with-string-reader ;
  23
  24 TYPED: timestamp>yymmdd ( timestamp -- yymmdd: string )
  25     [ year>> 2 lastn-digits ]
  26     [ month>> pad-00 ]
  27     [ day>> pad-00 ] tri 3append ;
  28
  29 TYPED: now-gmt-yymmdd ( -- yymmdd: string )
  30     now-gmt timestamp>yymmdd ;
  31
  32 TYPED: yymmdd-gmt-diff ( yymmdd: string yymmdd: string -- days )
  33     [ yymmdd-gmt>timestamp ] bi@ time- duration>days ;
  34
  35 TYPED: on-or-before-today? ( yymmdd: string -- x ? )
  36     now-gmt-yymmdd swap yymmdd-gmt-diff dup 0 >= ;
  37
  38 PRIVATE>
  39
  40 TUPLE: hashcash version bits date resource ext salt suffix ;
  41
  42 : <hashcash> ( -- tuple )
  43     hashcash new
  44     1 >>version
  45     20 >>bits
  46     now-gmt-yymmdd >>date
  47     8 ascii-password >>salt ;
  48
  49 M: hashcash string>>
  50     tuple-slots [ present ] map ":" join ;
  51
  52 <PRIVATE
  53
  54 : sha1-checksum ( str -- bytes )
  55     ascii encode openssl-sha1 checksum-bytes ; inline
  56
  57 : set-suffix ( tuple guess -- tuple )
  58     >hex >>suffix ;
  59
  60 : get-bits ( bytes -- str )
  61     [ >bin 8 CHAR: 0 pad-head ] { } map-as concat ;
  62
  63 : checksummed-bits ( tuple -- relevant-bits )
  64     dup string>> sha1-checksum
  65     swap bits>> 8 / ceiling head get-bits ;
  66
  67 : all-char-zero? ( seq -- ? )
  68     [ CHAR: 0 = ] all? ; inline
  69
  70 : valid-guess? ( checksum tuple -- ? )
  71     bits>> head all-char-zero? ;
  72
  73 : (mint) ( tuple counter -- tuple )
  74     2dup set-suffix checksummed-bits pick
  75     valid-guess? [ drop ] [ 1 + (mint) ] if ;
  76
  77 PRIVATE>
  78
  79 : mint* ( tuple -- stamp )
  80     0 (mint) string>> ;
  81
  82 : mint ( resource -- stamp )
  83     <hashcash>
  84     swap >>resource
  85     mint* ;
  86
  87 <PRIVATE
  88
  89 ! NOTE: Recommended expiry time is 28 days.
  90 SYMBOL: expiry-days
  91 expiry-days [ 28 ] initialize
  92
  93 PRIVATE>
  94
  95 TYPED: valid-date? ( yymmdd: string -- ? )
  96     on-or-before-today? [ expiry-days get <= ] [ drop f ] if ;
  97
  98 : valid-stamp? ( stamp -- ? )
  99     dup ":" split [ sha1-checksum get-bits ] dip [ 1 3 ] dip subseq first2
 100     valid-date? [ string>number head all-char-zero? ] [ 2drop f ] if ;