123 lines
4.0 KiB
Scheme
123 lines
4.0 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 fs uri)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-9)
|
||
#:use-module ((rnrs base) #:select (assert))
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (system foreign)
|
||
#:use-module (gnu gnunet common)
|
||
#:use-module (gnu gnunet binding-utils)
|
||
#:export (<uri>
|
||
uri?
|
||
make-ksk-uri
|
||
make-ksk-uri-pointer
|
||
wrap-uri
|
||
unwrap-uri
|
||
uri-type
|
||
uri-keywords
|
||
uri->string))
|
||
|
||
(define-record-type <uri>
|
||
(%wrap-uri pointer type keywords)
|
||
uri?
|
||
(pointer unwrap-uri)
|
||
(type uri-type)
|
||
(keywords uri-keywords))
|
||
|
||
|
||
;; (define %file-identifier-type
|
||
;; (list uint64
|
||
;; (list uint32
|
||
;; uint32)))
|
||
|
||
;; (define %location-type
|
||
;; (list %file-identifier-type
|
||
;; ecdsa-public-key
|
||
;; time-absolute
|
||
;; eddsa-signature))
|
||
|
||
;; (define %uri-type
|
||
;; (list unsigned-int
|
||
;; (union (list '*
|
||
;; unsigned-int)
|
||
;; (list ecdsa-public-key
|
||
;; '*)
|
||
;; %file-identifier-type
|
||
;; %location-type)))
|
||
|
||
|
||
(define %uri-destroy
|
||
(dynamic-func "GNUNET_FS_uri_destroy" gnunet-fs-ffi))
|
||
|
||
(define-gnunet-fs %uri->string
|
||
"GNUNET_FS_uri_to_string" : '(*) -> '*)
|
||
|
||
(define-gnunet-fs %uri-ksk-create
|
||
"GNUNET_FS_uri_ksk_create" : '(* *) -> '*)
|
||
|
||
|
||
(define (keyword-list->string keywords)
|
||
(string-concatenate/shared (interleave " " keywords)))
|
||
|
||
(define* (wrap-uri pointer #:key (finalize #f))
|
||
(when finalize
|
||
(set-pointer-finalizer! pointer %uri-destroy))
|
||
(%wrap-uri pointer (%uri-get-type pointer) #f))
|
||
|
||
(define (make-ksk-uri-pointer . keywords)
|
||
"Create a foreign pointer to a KSK URI from a list of strings KEYWORDS."
|
||
(assert (not (null? keywords)))
|
||
(let* ((%error-msg-ptr (%make-blob-pointer))
|
||
(%keywords-str (string->pointer (keyword-list->string keywords)))
|
||
(%uri (%uri-ksk-create %keywords-str %error-msg-ptr))
|
||
(%error-msg (dereference-pointer %error-msg-ptr)))
|
||
(cond ((and (eq? %null-pointer %uri)
|
||
(eq? %null-pointer %error-msg))
|
||
(throw 'invalid-result "make-ksk-uri-pointer" "%uri-ksk-create"
|
||
(list %error-msg-ptr)))
|
||
((eq? %null-pointer %uri)
|
||
(%free %error-msg) ; we don’t use error-msg
|
||
(throw 'invalid-arg "make-ksk-uri-pointer" keywords))
|
||
(else
|
||
(set-pointer-finalizer! %uri %uri-destroy)))
|
||
%uri))
|
||
|
||
(define (make-ksk-uri . keywords)
|
||
"Create an <uri> of type #:ksk from the list of strings KEYWORDS."
|
||
(%wrap-uri (apply make-ksk-uri-pointer keywords) #:ksk keywords))
|
||
|
||
(define (%uri-get-type pointer)
|
||
(let* ((bv (pointer->bytevector pointer (sizeof unsigned-int)))
|
||
(type (bytevector-uint-ref bv 0 (native-endianness)
|
||
(sizeof unsigned-int))))
|
||
(case type
|
||
((0) #:chk)
|
||
((1) #:sks)
|
||
((2) #:ksk)
|
||
((3) #:loc))))
|
||
|
||
(define (uri->string uri)
|
||
(let ((%str (%uri->string (unwrap-uri uri))))
|
||
(if (eq? %null-pointer %str)
|
||
(throw 'invalid-arg "uri->string" uri)
|
||
(pointer->string %str))))
|