gnunet/gnu/gnunet/fs/uri.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 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-pointer)))
          ((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 (eq? #:chk (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))))