libkeccak.fs 4.87 KB
Newer Older
bernd's avatar
bernd committed
1 2
\ keccak wrapper

bernd's avatar
bernd committed
3
require 64bit.fs
bernd's avatar
bernd committed
4
require unix/mmap.fs
bernd's avatar
bernd committed
5
require crypto-api.fs
bernd's avatar
bernd committed
6 7
require net2o-err.fs
require kregion.fs
bernd's avatar
bernd committed
8

bernd's avatar
bernd committed
9
\ dummy load for Android
bernd's avatar
bernd committed
10 11 12
[IFDEF] android
    s" /data/data/gnu.gforth/lib/libkeccak.so" open-lib drop
[THEN]
bernd's avatar
bernd committed
13 14

c-library keccak
bernd's avatar
bernd committed
15
    \    s" keccak/.libs" add-libpath
bernd's avatar
bernd committed
16
    s" keccak" add-lib
bernd's avatar
bernd committed
17 18 19
    [IFDEF] android
	s" ./keccak" add-libpath
    [THEN]
bernd's avatar
bernd committed
20
    \c #include <KeccakF-1600.h>
bernd's avatar
bernd committed
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
    \c UINT64* KeccakEncryptLoop(keccak_state state, UINT64 * data, unsigned int n)
    \c {
    \c   while(n>0) {
    \c     unsigned int p = n >= 128 ? 128 : n;
    \c     KeccakF(state);
    \c     KeccakEncrypt(state, data, p>>3);
    \c     data += p>>3; n-=p;
    \c   }
    \c   return data;
    \c }
    \c UINT64* KeccakDecryptLoop(keccak_state state, UINT64 * data, unsigned int n)
    \c {
    \c   while(n>0) {
    \c     unsigned int p = n >= 128 ? 128 : n;
    \c     KeccakF(state);
    \c     KeccakDecrypt(state, data, p>>3);
    \c     data += p>>3; n-=p;
    \c   }
    \c   return data;
    \c }

\ ------===< functions >===-------
c-function KeccakInitialize KeccakInitialize  -- void
c-function KeccakF KeccakF a -- void
c-function KeccakInitializeState KeccakInitializeState a -- void
c-function KeccakExtract KeccakExtract a a n -- void
c-function KeccakAbsorb KeccakAbsorb a a n -- void
c-function KeccakEncrypt KeccakEncrypt a a n -- void
c-function KeccakDecrypt KeccakDecrypt a a n -- void
c-function KeccakEncryptLoop KeccakEncryptLoop a a n -- a
c-function KeccakDecryptLoop KeccakDecryptLoop a a n -- a
bernd's avatar
bernd committed
52 53 54 55 56

end-c-library

25 8 * Constant keccak#
128 Constant keccak#max
57
128 Constant keccak#cks
bernd's avatar
bernd committed
58

bernd's avatar
bernd committed
59
UValue @keccak
bernd's avatar
bernd committed
60 61 62 63 64 65 66 67 68 69 70

: keccak0 ( -- ) @keccak KeccakInitializeState ;

: keccak* ( -- ) @keccak KeccakF ;
: >keccak ( addr u -- )  3 rshift @keccak -rot KeccakAbsorb ;
: +keccak ( addr u -- )  3 rshift @keccak -rot KeccakEncrypt ;
: -keccak ( addr u -- )  3 rshift @keccak -rot KeccakDecrypt ;
: keccak> ( addr u -- )  3 rshift @keccak -rot KeccakExtract ;

\ crypto api integration

bernd's avatar
bernd committed
71
require crypto-api.fs
bernd's avatar
bernd committed
72

bernd's avatar
bernd committed
73 74 75
crypto class
    keccak# uvar keccak-state
    keccak#cks uvar keccak-checksums
bernd's avatar
bernd committed
76
    keccak#max uvar keccak-padded
bernd's avatar
bernd committed
77 78 79 80
    cell uvar keccak-up
end-class keccak

: keccak-init crypto-o @ IF  keccak-up @ next-task = ?EXIT  THEN
bernd's avatar
bernd committed
81 82
    [: keccak new crypto-o ! ;] crypto-a with-allocater
    next-task keccak-up ! keccak-state to @keccak ;
bernd's avatar
bernd committed
83

84
: keccak-free crypto-o @ ?dup-IF  .dispose  THEN
bernd's avatar
bernd committed
85 86
    0 to @keccak crypto-o off ;

bernd's avatar
bernd committed
87
keccak-init
bernd's avatar
bernd committed
88

bernd's avatar
bernd committed
89
' keccak-init to c:init
90
' keccak-free to c:free
bernd's avatar
bernd committed
91
:noname to @keccak ; to c:key! ( addr -- )
bernd's avatar
bernd committed
92
\G use addr as key storage
bernd's avatar
bernd committed
93
' @keccak to c:key@ ( -- addr )
bernd's avatar
bernd committed
94
\G obtain the key storage
bernd's avatar
bernd committed
95
' keccak# to c:key# ( -- n )
bernd's avatar
bernd committed
96
\G obtain key storage size
bernd's avatar
bernd committed
97 98
' keccak0 to c:0key ( -- )
\G set zero key
bernd's avatar
bernd committed
99
:noname keccak0 keccak#max >keccak ; to >c:key ( addr -- )
bernd's avatar
bernd committed
100
\G move 128 bytes from addr to the state
bernd's avatar
bernd committed
101
:noname keccak#max keccak> ; to c:key> ( addr -- )
bernd's avatar
bernd committed
102
\G get 128 bytes from the state to addr
bernd's avatar
bernd committed
103
' keccak* to c:diffuse ( -- )
bernd's avatar
bernd committed
104 105 106
\G perform a diffuse round
:noname ( addr u -- )
    \G Encrypt message in buffer addr u
bernd's avatar
bernd committed
107 108 109
    @keccak -rot KeccakEncryptLoop  drop
\    BEGIN  @keccak KeccakF  2dup keccak#max umin tuck +keccak
\    /string dup 0= UNTIL  2drop
bernd's avatar
bernd committed
110
; to c:encrypt
bernd's avatar
bernd committed
111 112
:noname ( addr u -- )
    \G Decrypt message in buffer addr u
bernd's avatar
bernd committed
113 114 115
    @keccak -rot KeccakDecryptLoop  drop
\    BEGIN  @keccak KeccakF  2dup keccak#max umin tuck -keccak
\    /string dup 0= UNTIL  2drop
bernd's avatar
bernd committed
116
; to c:decrypt ( addr u -- )
117
:noname ( addr u tag -- )
bernd's avatar
bernd committed
118
    \G Encrypt message in buffer addr u with auth
bernd's avatar
bernd committed
119 120
\    BEGIN  @keccak KeccakF  2dup keccak#max umin tuck +keccak
\    /string dup 0= UNTIL  drop
121
    { tag } @keccak -rot KeccakEncryptLoop
bernd's avatar
bernd committed
122
    @keccak KeccakF
123 124
    >r keccak-checksums keccak#cks keccak>
    keccak-checksums tag 7 and 4 lshift + 128@ r> 128!
bernd's avatar
bernd committed
125
; to c:encrypt+auth ( addr u -- )
126
:noname ( addr u tag -- )
bernd's avatar
bernd committed
127
    \G Decrypt message in buffer addr u, with auth check
bernd's avatar
bernd committed
128 129
\    BEGIN  @keccak KeccakF  2dup keccak#max umin tuck -keccak
\    /string dup 0= UNTIL  drop
130
    { tag } @keccak -rot KeccakDecryptLoop
bernd's avatar
bernd committed
131
    @keccak KeccakF
132 133
    128@ keccak-checksums keccak#cks keccak>
    keccak-checksums tag 7 and 4 lshift + 128@ 128=
bernd's avatar
bernd committed
134
; to c:decrypt+auth ( addr u -- flag )
bernd's avatar
bernd committed
135 136
:noname ( addr u -- )
\G Hash message in buffer addr u
bernd's avatar
bernd committed
137
    BEGIN  2dup keccak#max umin tuck
bernd's avatar
bernd committed
138 139 140 141
	dup keccak#max u< IF
	    keccak-padded keccak#max >padded
	    keccak-padded keccak#max
	THEN  >keccak  @keccak KeccakF
bernd's avatar
bernd committed
142
    /string dup 0= UNTIL  2drop
bernd's avatar
bernd committed
143
; to c:hash
bernd's avatar
bernd committed
144
:noname ( addr u -- )
bernd's avatar
bernd committed
145 146
    BEGIN  @keccak KeccakF  2dup keccak#max umin tuck keccak>
    /string dup 0= UNTIL  2drop
bernd's avatar
bernd committed
147
; to c:prng
bernd's avatar
bernd committed
148 149
\G Fill buffer addr u with PRNG sequence
:noname @keccak KeccakF
150 151
    keccak-checksums keccak#cks keccak>
    7 and 4 lshift keccak-checksums + 128@ ; to c:checksum ( tag -- xd )
bernd's avatar
bernd committed
152
\G compute a 128 bit checksum
153 154 155 156
:noname keccak-checksums keccak#cks keccak>
    64#0 keccak-checksums keccak#cks bounds ?DO
	I 64@ 64xor  8 +LOOP ; to c:cookie ( -- x )
\G obtain a 64 bit checksum
bernd's avatar
bernd committed
157

bernd's avatar
bernd committed
158
keccak ' new static-a with-allocater Constant keccak-o
bernd's avatar
bernd committed
159 160

keccak-o crypto-o !