164 lines
5.5 KiB
Scheme
164 lines
5.5 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))
|
||
|
||
|
||
(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
|
||
'((#: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 %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-get-by-type
|
||
"GNUNET_CONTAINER_meta_data_get_by_type" : (list '* unsigned-int) -> '*)
|
||
|
||
(define-gnunet %metadata-iterate
|
||
"GNUNET_CONTAINER_meta_data_iterate" : (list '* '* '*) -> int)
|
||
|
||
|
||
(define* (wrap-metadata pointer #:key (finalize #f))
|
||
(when finalize
|
||
(set-pointer-finalizer! pointer %metadata-destroy))
|
||
(%wrap-metadata pointer))
|
||
|
||
(define (make-metadata)
|
||
(wrap-metadata (%metadata-create)))
|
||
|
||
(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)
|
||
(apply %metadata-insert (unwrap-metadata metadata)
|
||
(metadata-item->list 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)))
|