ed25519-donna.fs 5.01 KB
Newer Older
bernd's avatar
bernd committed
1 2 3
\ Interface to the ed25519 primitives from donna     23oct2013py
\ The high level stuff is all in Forth

bernd's avatar
bernd committed
4 5 6 7 8
\ dummy load for Android
[IFDEF] android
    s" /data/data/gnu.gforth/lib/libed25519-prims.so" open-lib drop
[THEN]

bernd's avatar
bernd committed
9 10
c-library ed25519_donna
    "ed25519-prims" add-lib
bernd's avatar
bernd committed
11 12 13
    [IFDEF] android
	s" ./shlibs/ed25519-donna/.libs" add-libpath
    [THEN]
bernd's avatar
bernd committed
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
    \c #include <stdint.h>
    \c #include <ed25519-prims.h>
    \c int str32eq(uint64_t* a, uint64_t* b) {
    \c    uint64_t diff=((a[0]^b[0])|(a[1]^b[1])|(a[2]^b[2])|(a[3]^b[3]));
    \c    return -(diff==0);
    \c }

    c-function raw>sc25519 expand_raw256_modm a a -- void ( sc char[32] -- )
    c-function nb>sc25519 expand256_modm a a n -- void ( sc char[64] -- )
    c-function sc25519>32b contract256_modm a a -- void ( char[32] sc -- )
    c-function sc25519* mul256_modm a a a -- void ( r x y -- )
    c-function sc25519+ add256_modm a a a -- void ( r x y -- )

    c-function ge25519*base ge25519_scalarmult_base a a -- void ( ger x -- )
    c-function ge25519-pack ge25519_pack a a -- void ( r ger -- )
    c-function ge25519-unpack- ge25519_unpack_negative_vartime a a -- n ( r p -- flag )
    c-function ge25519*+ ge25519_double_scalarmult_vartime a a a a -- void ( r p s1 s2 -- )
    c-function ge25519*v ge25519_scalarmult_vartime a a a -- void ( r p s -- )
    c-function ge25519* ge25519_scalarmult a a a -- void ( r p s -- )
    c-function 32b= str32eq a a -- n ( addr1 addr2 -- flag )
end-c-library

: 32b>sc25519 32 nb>sc25519 ;
: 64b>sc25519 64 nb>sc25519 ;

$20 Constant KEYBYTES

bernd's avatar
bernd committed
41
user-o edbuf
bernd's avatar
bernd committed
42

bernd's avatar
bernd committed
43
object class
bernd's avatar
bernd committed
44
    $60 uvar sigbuf
bernd's avatar
bernd committed
45 46 47 48 49 50 51 52
    $30 uvar sct0
    $30 uvar sct1
    $30 uvar sct2
    $30 uvar sct3
    $C0 uvar get0
    $C0 uvar get1
    $40 uvar hashtmp
    #200 uvar keccaktmp
bernd's avatar
bernd committed
53
    cell uvar task-id
bernd's avatar
bernd committed
54
end-class edbuf-c
bernd's avatar
bernd committed
55

bernd's avatar
bernd committed
56 57
: init-ed25519
    edbuf @ IF  task-id @ up@ = ?EXIT  THEN
bernd's avatar
bernd committed
58 59
    [: edbuf-c new edbuf ! ;] crypto-a with-allocater
    up@ task-id ! ;
bernd's avatar
bernd committed
60 61

init-ed25519
bernd's avatar
bernd committed
62

bernd's avatar
bernd committed
63
: free-ed25519 ( -- )
64
    edbuf @ ?dup-IF  .dispose  THEN  edbuf off ;
bernd's avatar
bernd committed
65

bernd's avatar
bernd committed
66
: clean-ed25519 ( -- )
bernd's avatar
bernd committed
67
    \g do this every time you computed using something secret
bernd's avatar
bernd committed
68 69 70 71 72
    sct0 task-id over - erase ;

: sk-mask ( sk -- )  dup c@ $F8 and over c!
    $1F + dup c@ $7F and $40 or swap c! ;

bernd's avatar
bernd committed
73 74
: gen-sk ( sk -- ) >r
    \G generate a secret key with the right bits set and cleared
bernd's avatar
bernd committed
75
    $20 rng$ r@ swap move r> sk-mask ;
bernd's avatar
bernd committed
76 77 78 79 80

: sk>pk ( sk pk -- )
    \G convert a secret key to a public key
    sct0 rot raw>sc25519
    get0 sct0 ge25519*base
bernd's avatar
bernd committed
81
    get0 ge25519-pack clean-ed25519 ;
bernd's avatar
bernd committed
82 83 84 85 86

: ed-keypair ( sk pk -- )
    \G generate a keypair
    over gen-sk sk>pk ;

bernd's avatar
bernd committed
87 88
: ed-keypairx { sk1 pkrev skc pkc -- }
    sct2 sk1 raw>sc25519
bernd's avatar
bernd committed
89 90
    pkrev sk-mask  sct1 pkrev raw>sc25519
    sk1 KEYBYTES erase  pkrev KEYBYTES erase \ things we don't need anymore
bernd's avatar
bernd committed
91 92 93 94
    sct2 sct2 sct1 sc25519*
    skc sct2 sc25519>32b
    skc pkc sk>pk ; \ this also cleans up temp stuff

bernd's avatar
bernd committed
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
: >hash ( addr u -- )
    \G absorb a short string, perform a hash round
    \G and output 64 bytes to hashtmp
    >keccak keccak* hashtmp $40 keccak> ;

: ed-sign { sk pk -- sig u }
    \G sign a message: the keccak state contains the hash of the message.
    @keccak keccaktmp keccak# move \ we need this twice - move away
    sk $20 >hash \ gen "random number" from secret to hashtmp
    keccaktmp @keccak keccak# move \ restore state
    sct3 hashtmp 64b>sc25519
    get0 sct3 ge25519*base   \ sct3 is k
    sigbuf get0 ge25519-pack   \ sct0 is r=k*base
    pk sigbuf $20 + $20 move
    sigbuf $40 >hash           \ z=hash(r+pk+message)
    sct1 hashtmp 64b>sc25519 \ sct1 is z
    sct2 sk raw>sc25519      \ sct2 is sk
    sct1 sct1 sct2 sc25519*
    sct1 sct1 sct3 sc25519+  \ s=z*sk+k
    sigbuf $20 + sct1 sc25519>32b
bernd's avatar
bernd committed
115
    clean-ed25519 sigbuf $40 ; \ r,s
bernd's avatar
bernd committed
116 117

: ed-check? { sig pk -- flag }
118
    \G check a message: the keccak state contains the hash of the message.
bernd's avatar
bernd committed
119 120 121 122 123
    \G The unpacked pk is in get0, so this word can be used for batch checking.
    sig hashtmp $20 move  pk hashtmp $20 + $20 move
    hashtmp $40 >keccak keccak* hashtmp $40 keccak> \ z=hash(r+pk+message)
    sct2 hashtmp 64b>sc25519       \ sct2 is z
    sct3 sig $20 + raw>sc25519     \ sct3 is s
bernd's avatar
bernd committed
124
    get1 get0 sct2 sct3 ge25519*+  \ base*s-pk*z
bernd's avatar
bernd committed
125 126 127 128 129 130 131
    sigbuf $40 + get1 ge25519-pack         \ =r
    sig sigbuf $40 + 32b= ;

: ed-verify { sig pk -- flag } \ message digest is in keccak state
    get0 pk ge25519-unpack- 0=  IF  false EXIT  THEN \ bad pubkey
    sig pk ed-check? ;

bernd's avatar
bernd committed
132
: ed-dh { sk pk dest -- secret len }
bernd's avatar
bernd committed
133 134 135
    get0 pk ge25519-unpack- 0= !!no-ed-key!!
    sct2 sk raw>sc25519
    get1 get0 sct2 ge25519*
bernd's avatar
bernd committed
136 137
    dest get1 ge25519-pack
    clean-ed25519 dest $20  $80 dest $1F + xorc! ;
bernd's avatar
bernd committed
138

bernd's avatar
bernd committed
139
: ed-dhx { offset sk pk dest -- secret len }
140 141 142 143 144
    get0 pk ge25519-unpack- 0= !!no-ed-key!!
    sct2 sk raw>sc25519
    sct1 offset 32b>sc25519
    sct2 sct2 sct1 sc25519*
    get1 get0 sct2 ge25519*
bernd's avatar
bernd committed
145 146
    dest get1 ge25519-pack
    clean-ed25519 dest $20  $80 dest $1F + xorc! ;
147

bernd's avatar
bernd committed
148
: ed-dhv { sk pk dest -- secret len }
bernd's avatar
bernd committed
149 150 151
    get0 pk ge25519-unpack- 0= !!no-ed-key!!
    sct2 sk raw>sc25519
    get1 get0 sct2 ge25519*v
bernd's avatar
bernd committed
152 153
    dest get1 ge25519-pack
    clean-ed25519 dest $20  $80 dest $1F + xorc! ;