469 lines
19 KiB
Scheme
469 lines
19 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 unions)
|
||
#: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
|
||
|
||
<pinfo-publish>
|
||
pinfo-publish?
|
||
wrap-pinfo-publish
|
||
unwrap-pinfo-publish
|
||
pinfo-publish-status
|
||
pinfo-publish-filename
|
||
pinfo-publish-size
|
||
pinfo-publish-eta
|
||
pinfo-publish-duration
|
||
pinfo-publish-completed
|
||
pinfo-publish-anonymity
|
||
pinfo-publish-chk-uri
|
||
pinfo-publish-sks-uri
|
||
pinfo-publish-message
|
||
|
||
<pinfo-download>
|
||
pinfo-download?
|
||
wrap-pinfo-download
|
||
unwrap-pinfo-download
|
||
pinfo-download-status
|
||
pinfo-download-uri
|
||
pinfo-download-filename
|
||
pinfo-download-size
|
||
pinfo-download-eta
|
||
pinfo-download-duration
|
||
pinfo-download-completed
|
||
pinfo-download-anonymity
|
||
pinfo-download-active?
|
||
pinfo-download-message
|
||
|
||
<pinfo-search>
|
||
pinfo-search?
|
||
wrap-pinfo-search
|
||
unwrap-pinfo-search
|
||
pinfo-search-status
|
||
pinfo-search-query
|
||
pinfo-search-duration
|
||
pinfo-search-anonymity
|
||
pinfo-search-metadata
|
||
pinfo-search-uri
|
||
pinfo-search-result
|
||
pinfo-search-message
|
||
|
||
<pinfo-unindex>
|
||
pinfo-unindex?
|
||
wrap-pinfo-unindex
|
||
unwrap-pinfo-unindex
|
||
pinfo-unindex-status))
|
||
|
||
|
||
|
||
(define %progress-info-type
|
||
(list ; struct GNUNET_FS_ProgressInfo
|
||
(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;
|
||
(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;
|
||
'*) ; GNUNET_FS_URI *sks_uri;
|
||
(list #:completed ; struct {…} completed
|
||
'* ; GNUNET_FS_URI *chk_uri;
|
||
'*) ; GNUNET_FS_URI *sks_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;
|
||
(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;
|
||
(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;
|
||
(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)))
|
||
|
||
;; An alist of each “sub”-status featuring a non-empty “specifics” field in
|
||
;; `struct GNUNET_FS_ProgressInfo`.
|
||
(define has-specifics-alist
|
||
'((#:publish #:progress #:progress-directory #:resume #:completed #:error)
|
||
(#:download #:progress #:start #:resume #:error)
|
||
(#:search #:result #:resume-result #:update #:result-suspend
|
||
#:result-stopped #:resume #:error #:ns)
|
||
(#:unindex #:progress #:resume #:error)))
|
||
|
||
(define %search-result-type
|
||
(list '* '* '* '* '* '* '* '* '* '* '* '* hashcode
|
||
'* time-absolute time-relative
|
||
uint32 uint32 uint32 uint32 uint32))
|
||
|
||
|
||
(define-record-type <pinfo-publish>
|
||
(wrap-pinfo-publish pointer status filename size eta duration completed
|
||
anonymity chk-uri sks-uri message)
|
||
pinfo-publish?
|
||
(pointer unwrap-pinfo-publish)
|
||
(status pinfo-publish-status)
|
||
(filename pinfo-publish-filename)
|
||
(size pinfo-publish-size)
|
||
(eta pinfo-publish-eta)
|
||
(duration pinfo-publish-duration)
|
||
(completed pinfo-publish-completed)
|
||
(anonymity pinfo-publish-anonymity)
|
||
(chk-uri pinfo-publish-chk-uri)
|
||
(sks-uri pinfo-publish-sks-uri)
|
||
(message pinfo-publish-message))
|
||
|
||
(define-record-type <pinfo-download>
|
||
(wrap-pinfo-download pointer status uri filename size eta duration completed
|
||
anonymity active? message)
|
||
pinfo-download?
|
||
(pointer unwrap-pinfo-download)
|
||
(status pinfo-download-status)
|
||
(uri pinfo-download-uri)
|
||
(filename pinfo-download-filename)
|
||
(size pinfo-download-size)
|
||
(eta pinfo-download-eta)
|
||
(duration pinfo-download-duration)
|
||
(completed pinfo-download-completed)
|
||
(anonymity pinfo-download-anonymity)
|
||
(active? pinfo-download-active?)
|
||
(message pinfo-download-message))
|
||
|
||
(define-record-type <pinfo-search>
|
||
(wrap-pinfo-search pointer status query duration anonymity metadata
|
||
uri result message)
|
||
pinfo-search?
|
||
(pointer unwrap-pinfo-search)
|
||
(status pinfo-search-status)
|
||
(query pinfo-search-query)
|
||
(duration pinfo-search-duration)
|
||
(anonymity pinfo-search-anonymity)
|
||
(metadata pinfo-search-metadata)
|
||
(uri pinfo-search-uri)
|
||
(result pinfo-search-result)
|
||
(message pinfo-search-message))
|
||
|
||
(define-record-type <pinfo-unindex>
|
||
(wrap-pinfo-unindex pointer status)
|
||
pinfo-unindex?
|
||
(pointer unwrap-pinfo-unindex)
|
||
(status pinfo-unindex-status))
|
||
|
||
|
||
(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 (has-specifics? status)
|
||
"Return #t if STATUS features a non-empty “specifics” field in `struct
|
||
GNUNET_FS_ProgressInfo`."
|
||
(let ((specifics-list (assq-ref has-specifics-alist (car status))))
|
||
(when (not specifics-list)
|
||
(throw 'invalid-arg "has-specifics?" status))
|
||
(not (not (memq (cadr status) specifics-list)))))
|
||
|
||
(define* (progress-info-status pointer #:optional replace-absent-specifics)
|
||
"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))
|
||
(status (integer->progress-info-status code)))
|
||
(if (and replace-absent-specifics
|
||
(not (has-specifics? status)))
|
||
(list (car status) #f)
|
||
status)))
|
||
|
||
;;; incomplete mappings of ProgressInfo structures, to be completed on demand.
|
||
|
||
(define (make-pinfo-publish status pointer vals)
|
||
(destructuring-bind ((_ _ _ _ %filename size eta duration
|
||
completed anonymity specs) _ _)
|
||
vals
|
||
(apply wrap-pinfo-publish pointer status
|
||
(pointer->string* %filename)
|
||
size eta duration completed anonymity
|
||
(case (cadr status)
|
||
((#:completed)
|
||
(destructuring-bind (%chk-uri %sks-uri) specs
|
||
(list (wrap-uri %chk-uri)
|
||
(and=>% %sks-uri wrap-uri)
|
||
#f)))
|
||
((#:error)
|
||
(list #f #f (pointer->string* (car specs))))
|
||
(else '(#f #f #f))))))
|
||
|
||
(define (make-pinfo-download status pointer vals)
|
||
(destructuring-bind ((_ _ _ _ %uri %filename size eta duration
|
||
completed anonymity %active? specs) _ _)
|
||
vals
|
||
(apply wrap-pinfo-download pointer status
|
||
(wrap-uri %uri)
|
||
(pointer->string %filename)
|
||
size eta duration completed anonymity
|
||
(int->bool %active?)
|
||
(if (eq? #:error (cadr status))
|
||
(list (pointer->string* (car specs)))
|
||
'(#f)))))
|
||
|
||
(define (make-pinfo-search status pointer vals)
|
||
(destructuring-bind ((_ _ _ %query duration anonymity specs) _ _)
|
||
vals
|
||
(apply wrap-pinfo-search pointer status
|
||
%query duration anonymity
|
||
(case (cadr status)
|
||
((#:result #:resume-result)
|
||
(destructuring-bind (%meta %uri %result . rest) specs
|
||
(list (wrap-metadata %meta) (wrap-uri %uri) %result #f)))
|
||
((#:update #:result-suspend #:result-stopped)
|
||
(destructuring-bind (_ %meta %uri . rest) specs
|
||
(list (wrap-metadata %meta) (wrap-uri %uri) #f #f)))
|
||
((#:resume #:error)
|
||
(list #f #f #f (pointer->string* (car specs))))
|
||
(else '(#f #f #f #f))))))
|
||
|
||
;;+TODO: write this mapping
|
||
(define (make-pinfo-unindex status pointer vals)
|
||
(wrap-pinfo-unindex pointer status))
|
||
|
||
(define (parse-c-progress-info pointer)
|
||
(let* ((status (progress-info-status pointer #t))
|
||
(vals (apply parse-c-struct* pointer %progress-info-type status))
|
||
(maker (case (car status)
|
||
((#:publish) make-pinfo-publish)
|
||
((#:download) make-pinfo-download)
|
||
((#:search) make-pinfo-search)
|
||
((#:unindex) make-pinfo-unindex))))
|
||
(maker status pointer vals)))
|
||
|
||
;;; 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))))
|