1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Interface to mhash library */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "usrdef.h"
32 #include "os.h"
33
34 /* If mhash.h unavailable, ignore it. This helps
35 "makegen/makegen.scm" work properly on systems lacking this
36 library. */
37 #ifdef HAVE_MHASH_H
38 # include <mhash.h>
39 #endif
40
41 #define UNARY_OPERATION(name, get_arg, cvt_val) \
42 { \
43 PRIMITIVE_HEADER (1); \
44 PRIMITIVE_RETURN (cvt_val (name (get_arg (1)))); \
45 }
46
47 static SCHEME_OBJECT
cp2s(void * cp)48 cp2s (void * cp)
49 {
50 if (cp == 0)
51 return (SHARP_F);
52 else
53 {
54 SCHEME_OBJECT s = (char_pointer_to_string (cp));
55 free (cp);
56 return (s);
57 }
58 }
59
60 typedef struct
61 {
62 MHASH context;
63 hashid id;
64 } context_entry;
65
66 static size_t context_table_length = 0;
67 static context_entry * context_table = 0;
68
69 static size_t
search_context_table(MHASH context)70 search_context_table (MHASH context)
71 {
72 size_t i;
73 for (i = 0; (i < context_table_length); i += 1)
74 if (((context_table[i]) . context) == context)
75 break;
76 return (i);
77 }
78
79 static size_t
allocate_context_entry(void)80 allocate_context_entry (void)
81 {
82 size_t i = (search_context_table (0));
83 if (i < context_table_length)
84 return (i);
85 if (i == 0)
86 {
87 context_table_length = 256;
88 context_table
89 = (OS_malloc ((sizeof (context_entry)) * context_table_length));
90 }
91 else
92 {
93 context_table_length *= 2;
94 context_table
95 = (OS_realloc (context_table,
96 ((sizeof (context_entry)) * context_table_length)));
97 }
98 {
99 size_t j;
100 for (j = i; (j < context_table_length); j += 1)
101 ((context_table[j]) . context) = 0;
102 }
103 return (i);
104 }
105
106 static SCHEME_OBJECT
store_context(MHASH context,hashid id)107 store_context (MHASH context, hashid id)
108 {
109 if (context == MHASH_FAILED)
110 return (SHARP_F);
111 {
112 size_t i = (allocate_context_entry ());
113 ((context_table[i]) . context) = context;
114 ((context_table[i]) . id) = id;
115 return (ulong_to_integer (i));
116 }
117 }
118
119 static void
forget_context(size_t index)120 forget_context (size_t index)
121 {
122 ((context_table[index]) . context) = 0;
123 }
124
125 static size_t
arg_context_index(unsigned int arg)126 arg_context_index (unsigned int arg)
127 {
128 unsigned long n = (arg_ulong_index_integer (arg, context_table_length));
129 if (((context_table[n]) . context) == 0)
130 error_bad_range_arg (arg);
131 return (n);
132 }
133
134 static MHASH
arg_context(unsigned int arg)135 arg_context (unsigned int arg)
136 {
137 return ((context_table [arg_context_index (arg)]) . context);
138 }
139
140 static size_t hashid_count;
141 static hashid * hashid_map = 0;
142
143 static void
initialize_hashid_map(void)144 initialize_hashid_map (void)
145 {
146 if (hashid_map == 0)
147 {
148 size_t i = 0;
149 size_t j = 0;
150 hashid_count = (mhash_count ());
151 hashid_map = (OS_malloc ((sizeof (hashid)) * hashid_count));
152 while (i <= hashid_count)
153 {
154 if ((mhash_get_block_size (i)) != 0)
155 (hashid_map[j++]) = ((hashid) i);
156 i += 1;
157 }
158 }
159 }
160
161 static hashid
arg_hashid(unsigned int arg)162 arg_hashid (unsigned int arg)
163 {
164 initialize_hashid_map ();
165 return (hashid_map [arg_ulong_index_integer (arg, hashid_count)]);
166 }
167
168 DEFINE_PRIMITIVE ("MHASH_COUNT", Prim_mhash_count, 0, 0, 0)
169 {
170 PRIMITIVE_HEADER (0);
171 initialize_hashid_map ();
172 PRIMITIVE_RETURN (ulong_to_integer (hashid_count));
173 }
174
175 DEFINE_PRIMITIVE ("MHASH_GET_BLOCK_SIZE", Prim_mhash_get_block_size, 1, 1, 0)
UNARY_OPERATION(mhash_get_block_size,arg_hashid,ulong_to_integer)176 UNARY_OPERATION (mhash_get_block_size, arg_hashid, ulong_to_integer)
177 DEFINE_PRIMITIVE ("MHASH_GET_HASH_PBLOCK", Prim_mhash_get_hash_pblock, 1, 1, 0)
178 UNARY_OPERATION (mhash_get_hash_pblock, arg_hashid, ulong_to_integer)
179 DEFINE_PRIMITIVE ("MHASH_GET_HASH_NAME", Prim_mhash_get_hash_name, 1, 1, 0)
180 UNARY_OPERATION (mhash_get_hash_name, arg_hashid, cp2s)
181
182 DEFINE_PRIMITIVE ("MHASH_INIT", Prim_mhash_init, 1, 1, 0)
183 {
184 PRIMITIVE_HEADER (1);
185 {
186 hashid id = (arg_hashid (1));
187 PRIMITIVE_RETURN (store_context ((mhash_init (id)), id));
188 }
189 }
190
191 DEFINE_PRIMITIVE ("MHASH_HMAC_INIT", Prim_mhash_hmac_init, 3, 3, 0)
192 {
193 PRIMITIVE_HEADER (3);
194 CHECK_ARG (2, STRING_P);
195 {
196 hashid id = (arg_hashid (1));
197 SCHEME_OBJECT key = (ARG_REF (2));
198 PRIMITIVE_RETURN
199 (store_context ((mhash_hmac_init (id,
200 (STRING_POINTER (key)),
201 (STRING_LENGTH (key)),
202 (arg_ulong_integer (3)))),
203 id));
204 }
205 }
206
207 DEFINE_PRIMITIVE ("MHASH", Prim_mhash, 4, 4, 0)
208 {
209 PRIMITIVE_HEADER (4);
210 CHECK_ARG (2, STRING_P);
211 {
212 SCHEME_OBJECT string = (ARG_REF (2));
213 unsigned long end
214 = (arg_ulong_index_integer (4, ((STRING_LENGTH (string)) + 1)));
215 unsigned long start = (arg_ulong_index_integer (3, (end + 1)));
216 mhash ((arg_context (1)), (STRING_LOC (string, start)), (end - start));
217 }
218 PRIMITIVE_RETURN (UNSPECIFIC);
219 }
220
221 DEFINE_PRIMITIVE ("MHASH_END", Prim_mhash_end, 1, 1, 0)
222 {
223 PRIMITIVE_HEADER (1);
224 {
225 size_t index = (arg_context_index (1));
226 MHASH context = ((context_table[index]) . context);
227 hashid id = ((context_table[index]) . id);
228 size_t block_size = (mhash_get_block_size (id));
229 /* Must allocate string _before_ calling mhash_end. */
230 SCHEME_OBJECT sd = (allocate_string (block_size));
231 void * digest = (mhash_end (context));
232 forget_context (index);
233 memcpy ((STRING_POINTER (sd)), digest, block_size);
234 free (digest);
235 PRIMITIVE_RETURN (sd);
236 }
237 }
238
239 DEFINE_PRIMITIVE ("MHASH_HMAC_END", Prim_mhash_hmac_end, 1, 1, 0)
240 {
241 PRIMITIVE_HEADER (1);
242 {
243 size_t index = (arg_context_index (1));
244 MHASH context = ((context_table[index]) . context);
245 hashid id = ((context_table[index]) . id);
246 size_t block_size = (mhash_get_block_size (id));
247 /* Must allocate string _before_ calling mhash_hmac_end. */
248 SCHEME_OBJECT sd = (allocate_string (block_size));
249 void * digest = (mhash_hmac_end (context));
250 forget_context (index);
251 memcpy ((STRING_POINTER (sd)), digest, block_size);
252 free (digest);
253 PRIMITIVE_RETURN (sd);
254 }
255 }
256
257 static size_t keygenid_count;
258 static keygenid * keygenid_map = 0;
259
260 static void
initialize_keygenid_map(void)261 initialize_keygenid_map (void)
262 {
263 if (keygenid_map == 0)
264 {
265 size_t i = 0;
266 size_t j = 0;
267 keygenid_count = (mhash_keygen_count ());
268 keygenid_map = (OS_malloc ((sizeof (keygenid)) * keygenid_count));
269 while (j < keygenid_count)
270 {
271 void * name = (mhash_get_keygen_name (i));
272 if (name != 0)
273 {
274 (keygenid_map[j++]) = ((keygenid) i);
275 free (name);
276 }
277 i += 1;
278 }
279 }
280 }
281
282 static keygenid
arg_keygenid(unsigned int arg)283 arg_keygenid (unsigned int arg)
284 {
285 initialize_keygenid_map ();
286 return (keygenid_map [arg_ulong_index_integer (arg, keygenid_count)]);
287 }
288
289 DEFINE_PRIMITIVE ("MHASH_KEYGEN_COUNT", Prim_mhash_keygen_count, 0, 0, 0)
290 {
291 PRIMITIVE_HEADER (0);
292 initialize_keygenid_map ();
293 PRIMITIVE_RETURN (ulong_to_integer (keygenid_count));
294 }
295
296 DEFINE_PRIMITIVE ("MHASH_GET_KEYGEN_NAME", Prim_mhash_get_keygen_name, 1, 1, 0)
UNARY_OPERATION(mhash_get_keygen_name,arg_keygenid,cp2s)297 UNARY_OPERATION (mhash_get_keygen_name, arg_keygenid, cp2s)
298 DEFINE_PRIMITIVE ("MHASH_KEYGEN_USES_SALT", Prim_mhash_keygen_uses_salt, 1, 1, 0)
299 UNARY_OPERATION (mhash_keygen_uses_salt, arg_keygenid, BOOLEAN_TO_OBJECT)
300 DEFINE_PRIMITIVE ("MHASH_KEYGEN_USES_COUNT", Prim_mhash_keygen_uses_count, 1, 1, 0)
301 UNARY_OPERATION (mhash_keygen_uses_count, arg_keygenid, BOOLEAN_TO_OBJECT)
302 DEFINE_PRIMITIVE ("MHASH_KEYGEN_USES_HASH_ALGORITHM", Prim_mhash_keygen_uses_hash_algorithm, 1, 1, 0)
303 UNARY_OPERATION (mhash_keygen_uses_hash_algorithm, arg_keygenid, long_to_integer)
304 DEFINE_PRIMITIVE ("MHASH_GET_KEYGEN_SALT_SIZE", Prim_mhash_get_keygen_salt_size, 1, 1, 0)
305 UNARY_OPERATION (mhash_get_keygen_salt_size, arg_keygenid, ulong_to_integer)
306 DEFINE_PRIMITIVE ("MHASH_GET_KEYGEN_MAX_KEY_SIZE", Prim_mhash_get_keygen_max_key_size, 1, 1, 0)
307 UNARY_OPERATION (mhash_get_keygen_max_key_size, arg_keygenid, ulong_to_integer)
308
309 DEFINE_PRIMITIVE ("MHASH_KEYGEN", Prim_mhash_keygen, 4, 4, 0)
310 {
311 /* keygen-id #(salt count hashid ...) keyword passphrase */
312 PRIMITIVE_HEADER (4);
313 CHECK_ARG (2, VECTOR_P);
314 CHECK_ARG (3, STRING_P);
315 CHECK_ARG (4, STRING_P);
316 {
317 keygenid id = (arg_keygenid (1));
318 SCHEME_OBJECT parameters = (ARG_REF (2));
319 SCHEME_OBJECT keyword = (ARG_REF (3));
320 SCHEME_OBJECT passphrase = (ARG_REF (4));
321 unsigned int n_algs = (mhash_keygen_uses_hash_algorithm (id));
322 SCHEME_OBJECT salt;
323 SCHEME_OBJECT count;
324 KEYGEN cparms;
325 {
326 size_t max_key_size = (mhash_get_keygen_max_key_size (id));
327 if ((max_key_size != 0) && ((STRING_LENGTH (keyword)) > max_key_size))
328 error_bad_range_arg (4);
329 }
330 if ((VECTOR_LENGTH (parameters)) != (2 + n_algs))
331 error_bad_range_arg (2);
332 salt = (VECTOR_REF (parameters, 0));
333 count = (VECTOR_REF (parameters, 1));
334 if (mhash_keygen_uses_salt (id))
335 {
336 if (!STRING_P (salt))
337 error_bad_range_arg (2);
338 {
339 size_t salt_size = (mhash_get_keygen_salt_size (id));
340 if ((salt_size != 0) && ((STRING_LENGTH (salt)) != salt_size))
341 error_bad_range_arg (2);
342 }
343 (cparms . salt) = (STRING_BYTE_PTR (salt));
344 (cparms . salt_size) = (STRING_LENGTH (salt));
345 }
346 else if (salt != SHARP_F)
347 error_bad_range_arg (2);
348 if (mhash_keygen_uses_count (id))
349 {
350 if (!integer_to_ulong_p (count))
351 error_bad_range_arg (2);
352 (cparms . count) = (integer_to_ulong (count));
353 }
354 else if (count != SHARP_F)
355 error_bad_range_arg (2);
356 {
357 unsigned int i;
358 initialize_hashid_map ();
359 for (i = 0; (i < n_algs); i += 1)
360 {
361 SCHEME_OBJECT a = (VECTOR_REF (parameters, (2 + i)));
362 if (!integer_to_ulong_p (a))
363 error_bad_range_arg (2);
364 {
365 unsigned long ia = (integer_to_ulong (a));
366 if (ia < hashid_count)
367 ((cparms . hash_algorithm) [i]) = (hashid_map[ia]);
368 else
369 error_bad_range_arg (2);
370 }
371 }
372 }
373 PRIMITIVE_RETURN
374 (BOOLEAN_TO_OBJECT
375 ((mhash_keygen_ext (id, cparms,
376 (STRING_POINTER (keyword)),
377 (STRING_LENGTH (keyword)),
378 (STRING_BYTE_PTR (passphrase)),
379 (STRING_LENGTH (passphrase))))
380 == 0));
381 }
382 }
383
384 #ifdef COMPILE_AS_MODULE
385
386 char *
dload_initialize_file(void)387 dload_initialize_file (void)
388 {
389 declare_primitive
390 ("MHASH_COUNT", Prim_mhash_count, 0, 0, 0);
391 declare_primitive
392 ("MHASH_GET_BLOCK_SIZE", Prim_mhash_get_block_size, 1, 1, 0);
393 declare_primitive
394 ("MHASH_GET_HASH_PBLOCK", Prim_mhash_get_hash_pblock, 1, 1, 0);
395 declare_primitive
396 ("MHASH_GET_HASH_NAME", Prim_mhash_get_hash_name, 1, 1, 0);
397 declare_primitive
398 ("MHASH_INIT", Prim_mhash_init, 1, 1, 0);
399 declare_primitive
400 ("MHASH_HMAC_INIT", Prim_mhash_hmac_init, 3, 3, 0);
401 declare_primitive
402 ("MHASH", Prim_mhash, 4, 4, 0);
403 declare_primitive
404 ("MHASH_END", Prim_mhash_end, 1, 1, 0);
405 declare_primitive
406 ("MHASH_HMAC_END", Prim_mhash_hmac_end, 1, 1, 0);
407 declare_primitive
408 ("MHASH_KEYGEN_COUNT", Prim_mhash_keygen_count, 0, 0, 0);
409 declare_primitive
410 ("MHASH_GET_KEYGEN_NAME", Prim_mhash_get_keygen_name, 1, 1, 0);
411 declare_primitive
412 ("MHASH_KEYGEN_USES_SALT", Prim_mhash_keygen_uses_salt, 1, 1, 0);
413 declare_primitive
414 ("MHASH_KEYGEN_USES_COUNT", Prim_mhash_keygen_uses_count, 1, 1, 0);
415 declare_primitive
416 ("MHASH_KEYGEN_USES_HASH_ALGORITHM", Prim_mhash_keygen_uses_hash_algorithm, 1, 1, 0);
417 declare_primitive
418 ("MHASH_GET_KEYGEN_SALT_SIZE", Prim_mhash_get_keygen_salt_size, 1, 1, 0);
419 declare_primitive
420 ("MHASH_GET_KEYGEN_MAX_KEY_SIZE", Prim_mhash_get_keygen_max_key_size, 1, 1, 0);
421 declare_primitive
422 ("MHASH_KEYGEN", Prim_mhash_keygen, 4, 4, 0);
423 return "#prmd5";
424 }
425
426 #endif /* COMPILE_AS_MODULE */
427