2015-06-20 22:16:34 +02:00
|
|
|
|
;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
|
|
|
|
|
;;;;
|
|
|
|
|
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
|
|
|
|
;;;;
|
|
|
|
|
;;;; This program is free software: you can redistribute it and/or modify
|
|
|
|
|
;;;; it under the terms of the GNU General Public License as published by
|
|
|
|
|
;;;; the Free Software Foundation, either version 3 of the License, or
|
|
|
|
|
;;;; (at your option) any later version.
|
|
|
|
|
;;;;
|
|
|
|
|
;;;; This program is distributed in the hope that it will be useful,
|
|
|
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
;;;; GNU General Public License for more details.
|
|
|
|
|
;;;;
|
|
|
|
|
;;;; You should have received a copy of the GNU General Public License
|
|
|
|
|
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
|
|
(define-module (gnu gnunet common)
|
|
|
|
|
#:use-module (system foreign)
|
|
|
|
|
#:use-module (rnrs base)
|
|
|
|
|
#:use-module (rnrs bytevectors)
|
2015-08-21 20:50:56 +02:00
|
|
|
|
#:use-module (ice-9 match)
|
2015-06-20 22:16:34 +02:00
|
|
|
|
#:use-module (gnu gnunet binding-utils)
|
2015-11-05 17:35:54 +01:00
|
|
|
|
#:use-module (gnu gnunet config)
|
2015-06-20 22:16:34 +02:00
|
|
|
|
#:export (gnunet-ok
|
|
|
|
|
gnunet-system-error
|
|
|
|
|
gnunet-yes
|
|
|
|
|
gnunet-no
|
2015-07-21 13:01:28 +02:00
|
|
|
|
bool->int
|
|
|
|
|
int->bool
|
2015-06-20 22:16:34 +02:00
|
|
|
|
|
|
|
|
|
time-relative
|
|
|
|
|
time-absolute
|
2015-08-03 15:57:09 +02:00
|
|
|
|
time-rel
|
2015-08-12 19:25:14 +02:00
|
|
|
|
current-time
|
|
|
|
|
time-absolute->string
|
|
|
|
|
time-relative->absolute
|
2015-08-03 15:57:09 +02:00
|
|
|
|
|
2015-06-20 22:16:34 +02:00
|
|
|
|
ecdsa-public-key
|
2015-07-03 13:39:56 +02:00
|
|
|
|
ecdsa-public-key?
|
2015-06-20 22:16:34 +02:00
|
|
|
|
eddsa-public-key
|
|
|
|
|
eddsa-signature
|
|
|
|
|
hashcode
|
|
|
|
|
|
|
|
|
|
define-foreign-definer
|
|
|
|
|
|
|
|
|
|
gnunet-util-ffi
|
|
|
|
|
gnunet-fs-ffi
|
|
|
|
|
define-gnunet
|
|
|
|
|
define-gnunet-fs
|
2015-07-24 21:31:42 +02:00
|
|
|
|
define-gnunet-id
|
2015-06-20 22:16:34 +02:00
|
|
|
|
|
2015-08-10 19:18:22 +02:00
|
|
|
|
setup-log
|
|
|
|
|
|
2015-06-20 22:16:34 +02:00
|
|
|
|
%make-blob-pointer
|
|
|
|
|
%malloc
|
2015-07-03 13:39:56 +02:00
|
|
|
|
%free
|
|
|
|
|
|
|
|
|
|
string->data-pointer))
|
2015-06-20 22:16:34 +02:00
|
|
|
|
|
2015-06-24 13:20:18 +02:00
|
|
|
|
|
|
|
|
|
(define (generate n x)
|
|
|
|
|
"Generates a list of length N which elements are X."
|
|
|
|
|
(if (zero? n)
|
|
|
|
|
'()
|
|
|
|
|
(cons x (generate (1- n) x))))
|
|
|
|
|
|
2015-06-20 22:16:34 +02:00
|
|
|
|
|
|
|
|
|
(define time-relative uint64)
|
|
|
|
|
(define time-absolute uint64)
|
2015-08-03 15:57:09 +02:00
|
|
|
|
|
2015-08-21 20:50:56 +02:00
|
|
|
|
(define %time-relative-forever #xffffffffffffffff) ; UINT64_MAX
|
|
|
|
|
|
2015-06-24 13:20:18 +02:00
|
|
|
|
(define ecdsa-public-key (generate (/ 256 8 4) uint32))
|
2015-06-20 22:16:34 +02:00
|
|
|
|
(define eddsa-public-key ecdsa-public-key)
|
2015-06-24 13:20:18 +02:00
|
|
|
|
(define eddsa-signature (list eddsa-public-key
|
|
|
|
|
eddsa-public-key))
|
|
|
|
|
(define hashcode (list (generate 16 uint32)))
|
2015-06-20 22:16:34 +02:00
|
|
|
|
|
2015-07-03 13:39:56 +02:00
|
|
|
|
(define (ecdsa-public-key? key)
|
|
|
|
|
(and (string? key)
|
|
|
|
|
(= (/ 258 8) (string-length key))))
|
|
|
|
|
|
2015-06-20 22:16:34 +02:00
|
|
|
|
(define gnunet-ok 1)
|
|
|
|
|
(define gnunet-system-error -1)
|
|
|
|
|
(define gnunet-yes 1)
|
|
|
|
|
(define gnunet-no 0)
|
|
|
|
|
|
2015-11-05 17:35:54 +01:00
|
|
|
|
(define gnunet-util-ffi (dynamic-link %libgnunet-util))
|
|
|
|
|
(define gnunet-fs-ffi (dynamic-link %libgnunet-fs))
|
|
|
|
|
(define gnunet-identity-ffi (dynamic-link %libgnunet-identity))
|
2015-06-20 22:16:34 +02:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-syntax define-foreign-definer
|
|
|
|
|
(syntax-rules ()
|
|
|
|
|
((_ definer-name ffi-var)
|
|
|
|
|
(define-syntax definer-name
|
|
|
|
|
(syntax-rules (: ->)
|
|
|
|
|
((_ func name : in -> out)
|
|
|
|
|
(define func
|
|
|
|
|
(pointer->procedure out (dynamic-func name ffi-var) in))))))))
|
|
|
|
|
|
|
|
|
|
(define-foreign-definer define-gnunet gnunet-util-ffi)
|
|
|
|
|
(define-foreign-definer define-gnunet-fs gnunet-fs-ffi)
|
2015-07-24 21:31:42 +02:00
|
|
|
|
(define-foreign-definer define-gnunet-id gnunet-identity-ffi)
|
2015-06-20 22:16:34 +02:00
|
|
|
|
|
2015-08-12 19:25:14 +02:00
|
|
|
|
(define-gnunet %time-absolute-get
|
|
|
|
|
"GNUNET_TIME_absolute_get" : '() -> time-absolute)
|
|
|
|
|
(define-gnunet %time-absolute->string
|
|
|
|
|
"GNUNET_STRINGS_absolute_time_to_string" : (list time-absolute) -> '*)
|
|
|
|
|
(define-gnunet %time-relative->absolute
|
|
|
|
|
"GNUNET_TIME_relative_to_absolute" : (list time-relative) -> time-absolute)
|
|
|
|
|
|
2015-08-10 19:18:22 +02:00
|
|
|
|
(define-gnunet %log-setup "GNUNET_log_setup" : '(* * *) -> int)
|
|
|
|
|
|
2015-06-20 22:16:34 +02:00
|
|
|
|
(define-gnunet %xfree "GNUNET_xfree_" : (list '* '* int) -> void)
|
|
|
|
|
(define-gnunet %xmalloc "GNUNET_xmalloc_" : (list size_t '* int) -> '*)
|
|
|
|
|
|
2015-07-03 13:39:56 +02:00
|
|
|
|
;; this function is needed to convert ASCII public keys to a format GNUnet can
|
|
|
|
|
;; understand.
|
|
|
|
|
(define-gnunet %string-to-data
|
|
|
|
|
"GNUNET_STRINGS_string_to_data" : (list '* size_t '* size_t) -> int)
|
|
|
|
|
|
2015-06-20 22:16:34 +02:00
|
|
|
|
|
2015-08-12 19:25:14 +02:00
|
|
|
|
(define (bool->int x) (if x gnunet-yes gnunet-no))
|
|
|
|
|
(define (int->bool x)
|
|
|
|
|
(cond ((= gnunet-yes x) #t)
|
|
|
|
|
((= gnunet-no x) #f)
|
|
|
|
|
((= gnunet-system-error x) #:system-error)
|
|
|
|
|
(else #:unknown)))
|
|
|
|
|
|
2015-08-10 19:18:22 +02:00
|
|
|
|
(define log-level-alist
|
|
|
|
|
(list (cons #:none (string->pointer "NONE"))
|
|
|
|
|
(cons #:error (string->pointer "ERROR"))
|
|
|
|
|
(cons #:warning (string->pointer "WARNING"))
|
|
|
|
|
(cons #:info (string->pointer "INFO"))
|
|
|
|
|
(cons #:debug (string->pointer "DEBUG"))
|
|
|
|
|
(cons #:invalid (string->pointer "INVALID"))
|
|
|
|
|
(cons #:bulk (string->pointer "BULK"))
|
|
|
|
|
(cons #:unspecified (string->pointer "UNSPECIFIED"))))
|
|
|
|
|
|
|
|
|
|
(define* (setup-log client-name log-level #:optional (log-file ""))
|
|
|
|
|
"Setup GNUnet’s logging. CLIENT-NAME is the name of the program you’re
|
|
|
|
|
writing, LOG-LEVEL is a keyword from (#:none #:error #:warning #:info #:debug
|
|
|
|
|
#:invalid #:bulk), LOG-FILE is either a filename or #f for `stderr'."
|
|
|
|
|
(define (log-level->pointer key)
|
|
|
|
|
(or (assq-ref log-level-alist key)
|
|
|
|
|
(assq-ref log-level-alist #:unspecified)))
|
|
|
|
|
(%log-setup (string->pointer client-name)
|
|
|
|
|
(log-level->pointer log-level)
|
|
|
|
|
(string->pointer* log-file)))
|
|
|
|
|
|
2015-08-12 19:25:14 +02:00
|
|
|
|
(define* (time-rel #:key (days 0) (hours 0) (minutes 0)
|
2015-08-21 20:50:56 +02:00
|
|
|
|
(seconds 0) (milli 0) (micro 0) #:rest rest)
|
|
|
|
|
(match rest
|
|
|
|
|
((#:forever) %time-relative-forever)
|
|
|
|
|
(_
|
|
|
|
|
(let* ((hours* (+ (* days 24) hours))
|
|
|
|
|
(minutes* (+ (* hours* 60) minutes))
|
|
|
|
|
(seconds* (+ (* minutes* 60) seconds))
|
|
|
|
|
(milli* (+ (* seconds* 1000) milli))
|
|
|
|
|
(micro* (+ (* milli* 1000) micro)))
|
|
|
|
|
(when (negative? micro*)
|
|
|
|
|
(scm-error 'out-of-range "time-rel"
|
|
|
|
|
"result (~a) is negative" (list micro*)
|
|
|
|
|
(list hours minutes seconds milli micro)))
|
|
|
|
|
(inexact->exact micro*)))))
|
2015-08-12 19:25:14 +02:00
|
|
|
|
|
|
|
|
|
(define (current-time)
|
|
|
|
|
"Get the current time as an absolute time."
|
|
|
|
|
(%time-absolute-get))
|
|
|
|
|
|
|
|
|
|
(define (time-absolute->string t)
|
|
|
|
|
(pointer->string (%time-absolute->string t)))
|
|
|
|
|
|
|
|
|
|
(define (time-relative->absolute t)
|
|
|
|
|
"Convert a relative time to an absolute time in the future."
|
|
|
|
|
(%time-relative->absolute t))
|
2015-07-21 13:01:28 +02:00
|
|
|
|
|
2015-06-20 22:16:34 +02:00
|
|
|
|
(define %xfilename (string->pointer "guile"))
|
|
|
|
|
|
|
|
|
|
(define (%free pointer)
|
|
|
|
|
(assert (not (eq? %null-pointer pointer)))
|
|
|
|
|
(%xfree pointer %xfilename 0))
|
|
|
|
|
|
|
|
|
|
(define (%malloc size)
|
|
|
|
|
"Allocates SIZE bytes on the C heap."
|
|
|
|
|
;; note: if %xmalloc couldn’t do the allocation (out of memory), it calls
|
|
|
|
|
;; abort(), and the whole guile process core dumps; at least, we’re assured
|
|
|
|
|
;; %xmalloc will never return a null pointer…
|
|
|
|
|
(%xmalloc size %xfilename 0))
|
|
|
|
|
|
|
|
|
|
(define (%make-blob-pointer)
|
|
|
|
|
(bytevector->pointer (make-bytevector (sizeof ptrdiff_t) 0)))
|
|
|
|
|
|
|
|
|
|
;;+TODO: what about (getenv "GNUNET_ARGS") ?
|
|
|
|
|
;;+TODO: skew-offset and skew-variance:
|
|
|
|
|
;; GNUNET_TIME_set_offset(offset - variance)
|
|
|
|
|
;;+TODO: what about defining the configuration entry ("arm" "CONFIG")?
|
|
|
|
|
;; (define-syntax with-gnunet
|
|
|
|
|
;; (syntax-rules ()
|
|
|
|
|
;; ((_ (config-file-name) thunk)
|
|
|
|
|
;; (let ((cfg-handle (load-configuration config-file-name)))
|
2015-07-03 13:39:56 +02:00
|
|
|
|
|
|
|
|
|
(define (string->data-pointer str data-len)
|
|
|
|
|
(let* ((%data (bytevector->pointer (make-bytevector data-len 0)))
|
|
|
|
|
(ret (%string-to-data (string->pointer str) (string-length str)
|
|
|
|
|
%data data-len)))
|
|
|
|
|
(when (not (= gnunet-ok ret))
|
|
|
|
|
(throw 'invalid-result "string->data-pointer" "%string-to-data"
|
|
|
|
|
(list str data-len)))
|
|
|
|
|
%data))
|