;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*- ;;;; ;;;; Copyright © 2015 Rémi Delrue ;;;; ;;;; 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 . (define-module (gnu gnunet common) #:use-module (system foreign) #:use-module (rnrs base) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (gnu gnunet binding-utils) #:use-module (gnu gnunet config) #:export (gnunet-ok gnunet-system-error gnunet-yes gnunet-no bool->int int->bool time-relative time-absolute time-rel current-time time-absolute->string time-relative->absolute ecdsa-public-key ecdsa-public-key? eddsa-public-key eddsa-signature hashcode define-foreign-definer gnunet-util-ffi gnunet-fs-ffi define-gnunet define-gnunet-fs define-gnunet-id setup-log %make-blob-pointer %malloc %free string->data-pointer)) (define (generate n x) "Generates a list of length N which elements are X." (if (zero? n) '() (cons x (generate (1- n) x)))) (define time-relative uint64) (define time-absolute uint64) (define %time-relative-forever #xffffffffffffffff) ; UINT64_MAX (define ecdsa-public-key (generate (/ 256 8 4) uint32)) (define eddsa-public-key ecdsa-public-key) (define eddsa-signature (list eddsa-public-key eddsa-public-key)) (define hashcode (list (generate 16 uint32))) (define (ecdsa-public-key? key) (and (string? key) (= (/ 258 8) (string-length key)))) (define gnunet-ok 1) (define gnunet-system-error -1) (define gnunet-yes 1) (define gnunet-no 0) (define gnunet-util-ffi (dynamic-link %libgnunet-util)) (define gnunet-fs-ffi (dynamic-link %libgnunet-fs)) (define gnunet-identity-ffi (dynamic-link %libgnunet-identity)) (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) (define-foreign-definer define-gnunet-id gnunet-identity-ffi) (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) (define-gnunet %log-setup "GNUNET_log_setup" : '(* * *) -> int) (define-gnunet %xfree "GNUNET_xfree_" : (list '* '* int) -> void) (define-gnunet %xmalloc "GNUNET_xmalloc_" : (list size_t '* int) -> '*) ;; 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) (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))) (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))) (define* (time-rel #:key (days 0) (hours 0) (minutes 0) (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*))))) (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)) (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))) (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))