gnunet/gnu/gnunet/fs/progress-info.scm

;;;; -*- 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))))