173 lines
5.9 KiB
Scheme
173 lines
5.9 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 bytevectors)
|
||
#:use-module (system foreign)
|
||
#:use-module (gnu gnunet common)
|
||
#:use-module (gnu gnunet binding-utils)
|
||
#:export (<uri>
|
||
uri?
|
||
parse-uri
|
||
make-ksk-uri
|
||
make-ksk-uri-pointer
|
||
make-sks-uri
|
||
make-sks-uri-pointer
|
||
wrap-uri
|
||
unwrap-uri
|
||
uri-type
|
||
uri-file-size
|
||
uri->string
|
||
|
||
keyword-list->string))
|
||
|
||
(define-record-type <uri>
|
||
(%wrap-uri pointer type)
|
||
uri?
|
||
(pointer unwrap-uri)
|
||
(type uri-type))
|
||
|
||
|
||
;; (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-parse
|
||
"GNUNET_FS_uri_parse" : '(* *) -> '*)
|
||
|
||
(define-gnunet-fs %uri-ksk-create
|
||
"GNUNET_FS_uri_ksk_create" : '(* *) -> '*)
|
||
|
||
(define-gnunet-fs %uri-sks-create
|
||
"GNUNET_FS_uri_sks_create" : '(* *) -> '*)
|
||
|
||
(define-gnunet-fs %uri-chk-get-file-size
|
||
"GNUNET_FS_uri_chk_get_file_size" : '(*) -> uint64)
|
||
|
||
|
||
(define (keyword-list->string keywords)
|
||
(string-concatenate/shared (interleave " " keywords)))
|
||
|
||
(define* (wrap-uri pointer #:key (finalize #f))
|
||
(when (eq? %null-pointer pointer)
|
||
(throw 'invalid-arg "wrap-uri" pointer))
|
||
(when finalize
|
||
(set-pointer-finalizer! pointer %uri-destroy))
|
||
(%wrap-uri pointer (%uri-get-type pointer)))
|
||
|
||
(define (parse-uri str)
|
||
(when (or (null? str) (string-null? str))
|
||
(throw 'invalid-arg "parse-uri" str))
|
||
(let* ((%error-message-ptr (%make-blob-pointer))
|
||
(%uri (%uri-parse (string->pointer str) %error-message-ptr))
|
||
(%error-message (dereference-pointer %error-message-ptr)))
|
||
(cond ((and (eq? %null-pointer %uri)
|
||
(eq? %null-pointer %error-message))
|
||
(throw 'invalid-result "parse-uri" "%uri-parse"
|
||
(list str %error-message-ptr)))
|
||
((eq? %null-pointer %uri)
|
||
(%free %error-message) ; we don’t use error-message
|
||
(throw 'invalid-arg "parse-uri" str))
|
||
(else
|
||
(wrap-uri %uri #:finalize #t)))))
|
||
|
||
(define (make-ksk-uri-pointer . keywords)
|
||
"Create a foreign pointer to a KSK URI from a list of strings KEYWORDS."
|
||
(when (null? keywords)
|
||
(throw 'invalid-arg "make-ksk-uri-pointer" 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))
|
||
|
||
(define (make-sks-uri-pointer namespace identifier)
|
||
(when (string-null? identifier)
|
||
(throw 'invalid-arg "make-sks-uri-pointer" identifier))
|
||
;; GNUNET_FS_uri_sks_create cannot return a NULL pointer; on memory shortage,
|
||
;; it aborts.
|
||
(%uri-sks-create namespace (string->pointer identifier)))
|
||
|
||
;;+TODO: divide <uri> into four types (ksk, sks, chk, loc) and ship valuable
|
||
;; information, such as namespace & identifier (for the sks URIs).
|
||
(define (make-sks-uri namespace identifier)
|
||
(wrap-uri (make-sks-uri-pointer namespace identifier) #:finalize #t))
|
||
|
||
(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-file-size uri)
|
||
"Return the size of the file pointed by URI. Raises an invalid-arg error if
|
||
URI is not a chk uri."
|
||
(when (not (or (eq? #:chk (uri-type uri))
|
||
(eq? #:loc (uri-type uri))))
|
||
(throw 'invalid-arg "uri-file-size" uri))
|
||
(%uri-chk-get-file-size (unwrap-uri uri)))
|
||
|
||
(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))))
|