223 lines
7.4 KiB
Scheme
223 lines
7.4 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/>.
|
||
|
||
;;;; 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 (<metadata>
|
||
make-metadata
|
||
metadata?
|
||
wrap-metadata
|
||
unwrap-metadata
|
||
|
||
<metadata-item>
|
||
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 <metadata>
|
||
(%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
|
||
'((#:filename . 2)
|
||
(#:publication-date . 24)
|
||
(#:unknown . 45)
|
||
(#:original-filename . 180)
|
||
;; temporary until the right meta-type is added to libextractor
|
||
(#:narinfo . 230)))
|
||
|
||
(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 <metadata-item>
|
||
(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)))
|
||
|
||
|