299 lines
13 KiB
Scheme
299 lines
13 KiB
Scheme
;;;; -*- 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)
|
||
#:use-module (system foreign-padded)
|
||
#: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
|
||
(make-union ; union {…} value
|
||
(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;
|
||
(make-union ; union {…} specifics
|
||
(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;
|
||
(make-union ; union {…} specifics
|
||
(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;
|
||
(make-union ; union {…} specifics
|
||
(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;
|
||
(make-union ; union {…} specifics
|
||
(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-get-type value specifics)
|
||
"Returns the type specification of struct GNUNET_FS_ProgressInfo
|
||
when its union `value` is VALUE and its union `specifics` is
|
||
SPECIFICS."
|
||
(define (replace-specifics-union type)
|
||
(match type
|
||
((? union?) (union-ref specifics type))
|
||
(_ type)))
|
||
(define (replace-value-union type)
|
||
(match type
|
||
((? union?) (map replace-specifics-union (union-ref value type)))
|
||
(_ type)))
|
||
(map replace-value-union %progress-info-type))
|
||
|
||
(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)
|
||
(parse-c-struct pointer (apply progress-info-get-type
|
||
(progress-info-status pointer))))
|
||
|
||
|
||
;;; 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))))
|