gnunet/gnu/gnunet/container/metadata.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/>.

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