guix
/
gnunet
mirror of git://git.savannah.gnu.org/guix/gnunet.git
2
0
Fork 0
Code Issues Releases Wiki Activity
gnunet/gnu/gnunet/fs/progress-info.scm

285 lines
13 KiB
Scheme
Raw Normal View History

Initial commit.
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 fs progress-info)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (system foreign)
Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working.
2015-06-24 13:20:18 +02:00
#:use-module (system foreign unions)
Initial commit.
2015-06-20 22:16:34 +02:00
#:use-module (rnrs bytevectors)
#:use-module (gnu gnunet binding-utils)
#:use-module (gnu gnunet common)
#:use-module (gnu gnunet container metadata)
#:use-module (gnu gnunet fs uri)
#:export (progress-info-status
parse-c-progress-info))
(define %progress-info-type
(list ; struct GNUNET_FS_ProgressInfo
Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working.
2015-06-24 13:20:18 +02:00
(union ; union {…} value
Initial commit.
2015-06-20 22:16:34 +02:00
(list #:publish ; struct {…} publish
'* ; GNUNET_FS_PublishContext *pc;
'* ; GNUNET_FS_FileInformation *fi;
'* ; void *cctx;
'* ; void *pctx;
'* ; char *filename;
uint64 ; uint64_t size;
time-relative ; GNUNET_TIME_Relative eta;
time-relative ; GNUNET_TIME_Relative duration;
uint64 ; uint64_t completed;
uint32 ; uint32_t anonymity;
Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working.
2015-06-24 13:20:18 +02:00
(union ; union {…} specifics
Initial commit.
2015-06-20 22:16:34 +02:00
(list #:progress ; struct {…} progress
'* ; void *data;
uint64 ; uint64_t offset;
uint64 ; uint64_t data_len;
unsigned-int) ; unsigned int depth;
(list #:progress-directory ; struct {…} progress_directory
uint64 ; uint64_t completed;
uint64 ; uint64_t total;
time-relative) ; GNUNET_TIME_Relative eta;
(list #:resume ; struct {…} resume
'* ; char *message;
'*) ; GNUNET_FS_URI *chk_uri;
(list #:completed ; struct {…} completed
'*) ; GNUNET_FS_URI *chk_uri;
(list #:error ; struct {…} error
'*))) ; char *message;
(list #:download ; struct {…} download
'* ; GNUNET_FS_DownloadContext *dc
'* ; void *cctx;
'* ; void *pctx;
'* ; void *sctx;
'* ; GNUNET_FS_Uri *uri;
'* ; char *filename;
uint64 ; uint64_t size;
time-relative ; GNUNET_TIME_Relative eta;
time-relative ; GNUNET_TIME_Relative duration;
uint64 ; uint64_t completed;
uint32 ; uint32_t anonymity;
int ; int is_active;
Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working.
2015-06-24 13:20:18 +02:00
(union ; union {…} specifics
Initial commit.
2015-06-20 22:16:34 +02:00
(list #:progress ; struct {…} progress
'* ; void *data;
uint64 ; uint64_t offset;
uint64 ; uint64_t data_len;
time-relative ; GNUNET_TIME_Relative block…;
unsigned-int ; unsigned int depth;
uint32 ; uint32_t respect_offered;
uint32) ; uint32_t num_transmissions;
(list #:start ; struct {…} start
'*) ; GNUNET_CONTAINER_MetaData *m…;
(list #:resume ; struct {…} resume
'* ; GNUNET_CONTAINER_MetaData *m…;
'*) ; char *message;
(list #:error ; struct {…} error
'*))) ; char *message;
(list #:search ; struct {…} search
'* ; GNUNET_FS_SearchContext *sc;
'* ; void *cctx;
'* ; void *pctx;
'* ; GNUNET_FS_Uri *query;
time-relative ; GNUNET_TIME_RELATIVE duration;
uint32 ; uint32_t anonymity;
Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working.
2015-06-24 13:20:18 +02:00
(union ; union {…} specifics
Initial commit.
2015-06-20 22:16:34 +02:00
(list #:result ; struct {…} result
'* ; GNUNET_CONTAINER_MetaData *m…;
'* ; GNUNET_FS_Uri *uri;
'* ; GNUNET_FS_SearchResult *res…;
uint32) ; uint32_t applicability_rank;
(list #:resume-result ; struct {…} resume_result
'* ; GNUNET_CONTAINER_MetaData m…;
'* ; GNUNET_FS_Uri *uri;
'* ; GNUNET_FS_SearchResult *res…;
int32 ; int32_t availability_rank;
uint32 ; uint32_t availability_certa…;
uint32) ; uint32_t applicability_rank;
(list #:update ; struct {…} update
'* ; void *cctx;
'* ; GNUNET_CONTAINER_MetaData *m…;
'* ; GNUNET_FS_Uri *uri;
int32 ; int32_t availability_rank;
uint32 ; uint32_t availability_certai…;
uint32 ; uint32_t applicability_rank;
time-relative) ; GNUNET_TIME_Relative current…;
(list #:result-suspend ; struct {…} result_suspend
'* ; void *cctx
'* ; GNUNET_CONTAINER_MetaData *m…;
'*) ; GNUNET_FS_Uri *uri;
(list #:result-stopped ; struct {…} result_stopped
'* ; void *cctx;
'* ; GNUNET_CONTAINER_MetaData *m…;
'*) ; GNUNET_FS_Uri *uri;
(list #:resume ; struct {…} resume
'* ; char *message;
int) ; int is_paused;
(list #:error ; struct {…} error
'*) ; char *message;
(list #:ns ; struct {…} ns
'* ; char *name;
'* ; char *root;
'* ; GNUNET_CONTAINER_MetaData *m…;
ecdsa-public-key))) ; GNUNET_CRYPTO_Ecdsa…Key pseu…;
(list #:unindex ; struct {…} unindex
'* ; GNUNET_FS_UnindexContext *uc;
'* ; void *cctx;
'* ; char *filename;
uint64 ; uint64_t size;
time-relative ; GNUNET_TIME_Relative eta;
time-relative ; GNUNET_TIME_Relative duration;
uint64 ; uint64_t completed;
Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working.
2015-06-24 13:20:18 +02:00
(union ; union {…} specifics
Initial commit.
2015-06-20 22:16:34 +02:00
(list #:progress ; struct {…} progress
'* ; void *data;
uint64 ; uint64_t offset;
uint64 ; uint64_t data_len;
unsigned-int) ; unsigned int depth;
(list #:resume ; struct {…} resume
'*) ; char *message;
(list #:error ; struct {…} error
'*)))) ; char *message;
unsigned-int ; enum GNUNET_FS_Status status;
'*)) ; GNUNET_FS_Handle *fsh;
(define progress-info-status-alist
`((0 #:publish #:start)
(1 #:publish #:resume)
(2 #:publish #:suspend)
(3 #:publish #:progress)
(4 #:publish #:error)
(5 #:publish #:completed)
(6 #:publish #:stopped)
(7 #:download #:start)
(8 #:download #:resume)
(9 #:download #:suspend)
(10 #:download #:progress)
(11 #:download #:error)
(12 #:download #:completed)
(13 #:download #:stopped)
(14 #:download #:active)
(15 #:download #:inactive)
(16 #:download #:lost-parent)
(17 #:search #:start)
(18 #:search #:resume)
(19 #:search #:resume-result)
(20 #:search #:suspend)
(21 #:search #:result)
(22 #:search #:result-namespace)
(23 #:search #:update)
(24 #:search #:error)
(25 #:search #:paused)
(26 #:search #:continued)
(27 #:search #:result-stopped)
(28 #:search #:result-suspend)
(29 #:search #:stopped)
(30 #:unindex #:start)
(31 #:unindex #:resume)
(32 #:unindex #:suspend)
(33 #:unindex #:progress)
(34 #:unindex #:error)
(35 #:unindex #:completed)
(36 #:unindex #:stopped)
(37 #:publish #:progress-directory)))
(define %search-result-type
(list '* '* '* '* '* '* '* '* '* '* '* '* hashcode
'* time-absolute time-relative
uint32 uint32 uint32 uint32 uint32))
(define (integer->progress-info-status n)
(or (assq-ref progress-info-status-alist n)
(throw 'invalid-arg "integer->progress-info-status" n)))
(define (progress-info-status->integer status)
(or (rassoc-ref progress-info-status-alist status)
(throw 'invalid-arg "progress-info-status->integer" status)))
(define (progress-info-status pointer)
"Returns the status of a struct GNUNET_FS_ProgressInfo as a list of
two keywords. If status is unknown, raises an error."
(let* ((size (sizeof unsigned-int))
(offset (sizeof* (car %progress-info-type)))
(bv (pointer->bytevector pointer size offset))
(code (bytevector-uint-ref bv 0 (native-endianness) size)))
(integer->progress-info-status code)))
(define (parse-c-progress-info pointer)
Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working.
2015-06-24 13:20:18 +02:00
(apply parse-c-struct* pointer %progress-info-type
(progress-info-status pointer)))
Initial commit.
2015-06-20 22:16:34 +02:00
;;; incomplete mapping of GNUNET_FS_SearchResult
;;;+TODO: complete mapping of GNUNET_FS_SearchResult
(define* (bytevector-u8-fold f bv lst init #:optional
(index 0)
(start (expt 2 7)))
(match lst
(() init)
((first . rest)
(let ((n (bytevector-u8-ref bv index)))
(let ((new-init (f init (not (zero? (logand n start))) first))
(new-index (if (= 1 start)
(+ 1 index)
index))
(new-start (if (= 1 start)
(expt 2 7)
(/ start 2))))
(bytevector-u8-fold f bv rest new-init new-index new-start))))))
(define (u8-bitmap->list bv index lst)
(bytevector-u8-fold (lambda (acc bool elt)
(if bool
(cons elt acc)
acc))
bv lst '() index))
(define (bitmap-pointer->list pointer ordered-set)
(let* ((len (/ (+ (length ordered-set) 7) 8))
(bv (pointer->bytevector pointer len)))
(u8-bitmap->list bv 0 ordered-set)))
(define-record-type <search-result>
(%wrap-search-result pointer uri metadata serialization
keywords-matched mandatory-missing optional-support
availability-success availability-trials)
search-result?
(pointer unwrap-search-result)
(uri search-result-uri)
(metadata search-result-metadata)
(serialization search-result-serialization)
(keywords-matched search-result-keywords-matched)
(mandatory-missing search-result-mandatory-missing)
(optional-support search-result-optional-support)
(availability-success search-result-availability-success)
(availability-trials search-result-availability-trials))
(define (make-search-result pointer keywords)
(match (parse-c-struct pointer %search-result-type)
((_ _ _ _ %uri %metadata _ _ _ %serialization
%keyword-bitmap _ _ _ _ _ mandatory-missing optional-support
availability-success availability-trials)
(%wrap-search-result pointer
(wrap-uri %uri)
(wrap-metadata %metadata)
(pointer->string %serialization)
(bitmap-pointer->list %keyword-bitmap keywords)
mandatory-missing optional-support
availability-success availability-trials))))