;;;; -*- 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 . ;;;; source for libextractor related values: ;;;; https://gnunet.org/svn/Extractor/src/include/extractor.h (define-module (gnu gnunet container metadata) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (system foreign) #:use-module (rnrs bytevectors) #:use-module (gnu gnunet common) #:use-module (gnu gnunet binding-utils) #:export ( make-metadata metadata? wrap-metadata unwrap-metadata make-metadata-item metadata-item? metadata-item-name metadata-item-type metadata-item-format metadata-item-mime-type metadata-item-data metadata-set! metadata-ref metadata-iterate metadata-map metadata-copy metadata-equal? metadata-clear! metadata-add-publication-date! )) (define-record-type (%wrap-metadata pointer) metadata? (pointer unwrap-metadata)) (define metaformat-alist '((#:unknown . 0) (#:utf8 . 1) (#:binary . 2) (#:c-string . 3))) (define (metaformat->integer format) (or (assq-ref metaformat-alist format) (throw 'invalid-arg "metaformat->integer" format))) (define (integer->metaformat n) (or (rassq-ref metaformat-alist n) (begin (warn "Invalid metaformat code" n) #:unknown))) (define metadata-type-alist '((#:publication-date . 24) (#:unknown . 45) (#:original-filename . 180))) (define (metadata-type->integer type) (or (assq-ref metadata-type-alist type) (throw 'invalid-arg "metadata-type->integer" type))) (define (integer->metadata-type n) (or (rassq-ref metadata-type-alist n) (begin (warn "Invalid metadata type code" n) #:unknown))) (define-gnunet %metadata-create "GNUNET_CONTAINER_meta_data_create" : '() -> '*) (define-gnunet %metadata-duplicate "GNUNET_CONTAINER_meta_data_duplicate" : '(*) -> '*) (define %metadata-destroy (dynamic-func "GNUNET_CONTAINER_meta_data_destroy" gnunet-util-ffi)) (define-gnunet %metadata-insert "GNUNET_CONTAINER_meta_data_insert" : (list '* '* unsigned-int unsigned-int '* '* size_t) -> int) (define-gnunet %metadata-test-equal "GNUNET_CONTAINER_meta_data_test_equal" : '(* *) -> int) (define-gnunet %metadata-merge "GNUNET_CONTAINER_meta_data_merge" : '(* *) -> void) (define-gnunet %metadata-delete "GNUNET_CONTAINER_meta_data_delete" : (list '* unsigned-int '* size_t) -> int) (define-gnunet %metadata-clear "GNUNET_CONTAINER_meta_data_clear" : '(*) -> void) (define-gnunet %metadata-add-publication-date "GNUNET_CONTAINER_meta_data_add_publication_date" : '(*) -> void) (define-gnunet %metadata-iterate "GNUNET_CONTAINER_meta_data_iterate" : '(* * *) -> int) (define-gnunet %metadata-get-by-type "GNUNET_CONTAINER_meta_data_get_by_type" : (list '* unsigned-int) -> '*) (define* (wrap-metadata pointer #:key (finalize #f)) (when finalize (set-pointer-finalizer! pointer %metadata-destroy)) (%wrap-metadata pointer)) (define* (make-metadata #:key (finalize #t)) (wrap-metadata (%metadata-create) #:finalize finalize)) (define-record-type (make-metadata-item name type format mime-type data) metadata-item? (name metadata-item-name) (type metadata-item-type) (format metadata-item-format) (mime-type metadata-item-mime-type) (data metadata-item-data)) (define (metadata-item->list item) (list (string->pointer (metadata-item-name item)) (metadata-type->integer (metadata-item-type item)) (metaformat->integer (metadata-item-format item)) (string->pointer (metadata-item-mime-type item)) (bytevector->pointer (metadata-item-data item)) (bytevector-length (metadata-item-data item)))) (define (metadata-set! metadata item) (let ((res (apply %metadata-insert (unwrap-metadata metadata) (metadata-item->list item)))) (when (= res gnunet-system-error) (throw 'entry-already-exist "metadata-set!" metadata item)))) (define (metadata-ref metadata type) (pointer->string (%metadata-get-by-type (unwrap-metadata metadata) (metadata-type->integer type)))) (define (metadata-iterate f metadata) "Iterate through metadata, calling f on each entry found until no entry remain or f returns #f. f: plugin-name × metadata-type × metaformat × mime-type × data → bool where plugin-name is a string, metadata-type is either #:original-filename or #:unknown metaformat is either #:unknown, #:utf8, #:binary or #:c-string, mime-type is a string, data is a bytevector." (let* ((f* (lambda (_ plugin-name metadata-type metaformat data-mime-type data-pointer data-size) (if (f (pointer->string plugin-name) (integer->metadata-type metadata-type) (integer->metaformat metaformat) (pointer->string data-mime-type) (pointer->bytevector data-pointer data-size)) 0 1))) (f-pointer (procedure->pointer int f* (list '* '* unsigned-int unsigned-int '* '* size_t)))) (%metadata-iterate (unwrap-metadata metadata) f-pointer %null-pointer))) (define (metadata-map f metadata) (let ((result '())) (metadata-iterate (lambda (. args) (set! result (cons (apply f args) result)) 0) metadata) (reverse result))) ;;; utility functions (define* (metadata-copy meta #:key (finalize #t)) "Return a newly created copy of META." (let ((ptr (%metadata-duplicate (unwrap-metadata meta)))) (when (eq? %null-pointer ptr) (throw 'invalid-result "metadata-copy" "%metadata-duplicate" %null-pointer)) (wrap-metadata ptr #:finalize finalize))) (define (metadata-equal? m n) "Test if to metadata are equal: two metadata are considered equal if the meta-types, formats and content match (mime-types and plugin names aren’t considered)." (int->bool (%metadata-test-equal (unwrap-metadata m) (unwrap-metadata n)))) ;;+TODO: metadata-merge ;;+TODO: metadata-delete (define (metadata-clear! m) "Remove all items in the metadata." (%metadata-clear (unwrap-metadata m))) (define (metadata-add-publication-date! m) "Add the current time as the publication date to the metadata." (%metadata-add-publication-date (unwrap-metadata m)))