;;;; -*- 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 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? 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? 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? 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? 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 (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 (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 (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 (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 (%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))))