472 lines
20 KiB
Scheme
472 lines
20 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/>.
|
||
|
||
(define-module (gnu gnunet fs)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-9)
|
||
#:use-module (system foreign)
|
||
#:use-module (gnu gnunet binding-utils)
|
||
#:use-module (gnu gnunet common)
|
||
#:use-module (gnu gnunet configuration)
|
||
#:use-module (gnu gnunet container metadata)
|
||
#:use-module (gnu gnunet identity)
|
||
#:use-module (gnu gnunet fs uri)
|
||
#:use-module (gnu gnunet fs progress-info)
|
||
#:use-module (gnu gnunet scheduler)
|
||
#:export (<file-information>
|
||
wrap-file-information
|
||
unwrap-file-information
|
||
file-information-filename
|
||
file-information-directory?
|
||
file-information-add!
|
||
file-information-iterate
|
||
|
||
make-block-options
|
||
open-filesharing-service
|
||
close-filesharing-service!
|
||
start-search
|
||
stop-search
|
||
start-download
|
||
stop-download
|
||
start-publish
|
||
stop-publish
|
||
is-directory?
|
||
;; to publish a single file
|
||
file->file-information%
|
||
file->file-information
|
||
directory->file-information%
|
||
directory->file-information))
|
||
;; to publish a directory
|
||
;; buggy/unfinished
|
||
; start-directory-scan
|
||
; stop-directory-scan
|
||
; directory-scanner-result
|
||
; share-tree->file-information))
|
||
|
||
|
||
(define struct-fs-handle
|
||
(list '* '* '* '* '* '* '* '* '* '* '* '* '* '* time-relative
|
||
unsigned-int unsigned-int unsigned-int unsigned-int unsigned-int))
|
||
|
||
(define struct-search-context
|
||
(list '* '* '* '* '* '* '* '* '* '* time-absolute time-relative '*
|
||
unsigned-int unsigned-int uint32 uint32 unsigned-int))
|
||
|
||
(define struct-download-context
|
||
(list '* '* '* '* '* '* '* '* '* '* '* '* '* '* '* '* '* '* '* '* '* '* '* '*
|
||
eddsa-public-key '* uint64 uint64 uint64 uint64 time-absolute
|
||
time-relative uint32 unsigned-int unsigned-int int int int))
|
||
|
||
(define default-max-parallel-downloads 16)
|
||
(define default-max-parallel-requests (* 1024 10))
|
||
|
||
|
||
(define-gnunet-fs %fs-stop
|
||
"GNUNET_FS_stop" : '(*) -> void)
|
||
|
||
(define-gnunet-fs %file-information-create-from-file
|
||
"GNUNET_FS_file_information_create_from_file" :
|
||
(list '* '* '* '* '* int '*) -> '*)
|
||
|
||
(define-gnunet-fs %file-information-create-empty-directory
|
||
"GNUNET_FS_file_information_create_empty_directory" :
|
||
'(* * * * * *) -> '*)
|
||
|
||
(define-gnunet-fs %file-information-add!
|
||
"GNUNET_FS_file_information_add" : '(* *) -> int)
|
||
|
||
(define-gnunet-fs %file-information-get-filename
|
||
"GNUNET_FS_file_information_get_filename" : '(*) -> '*)
|
||
|
||
(define-gnunet-fs %file-information-is-directory
|
||
"GNUNET_FS_file_information_is_directory" : '(*) -> int)
|
||
|
||
(define-gnunet-fs %file-information-destroy
|
||
"GNUNET_FS_file_information_destroy" : '(* * *) -> void)
|
||
|
||
(define-gnunet-fs %file-information-inspect
|
||
"GNUNET_FS_file_information_inspect" : '(* * *) -> void)
|
||
|
||
(define-gnunet-fs %directory-scan-start
|
||
"GNUNET_FS_directory_scan_start" : (list '* int '* '* '*) -> '*)
|
||
|
||
(define-gnunet-fs %directory-scan-abort
|
||
"GNUNET_FS_directory_scan_abort" : '(*) -> void)
|
||
|
||
(define-gnunet-fs %directory-scan-get-result
|
||
"GNUNET_FS_directory_scan_get_result" : '(*) -> '*)
|
||
|
||
(define-gnunet-fs %share-tree-trim!
|
||
"GNUNET_FS_share_tree_trim" : '(*) -> void)
|
||
|
||
(define-gnunet-fs %share-tree-free
|
||
"GNUNET_FS_share_tree_free" : '(*) -> void)
|
||
|
||
(define-gnunet-fs %search-start
|
||
"GNUNET_FS_search_start" : (list '* '* uint32 unsigned-int '*) -> '*)
|
||
|
||
(define-gnunet-fs %search-stop
|
||
"GNUNET_FS_search_stop" : (list '*) -> void)
|
||
|
||
(define-gnunet-fs %download-start
|
||
"GNUNET_FS_download_start" :
|
||
(list '* '* '* '* '* uint64 uint64 uint32 unsigned-int '* '*) -> '*)
|
||
|
||
(define-gnunet-fs %download-stop
|
||
"GNUNET_FS_download_stop" : (list '* int) -> void)
|
||
|
||
(define-gnunet-fs %publish-start
|
||
"GNUNET_FS_publish_start" : (list '* '* '* '* '* unsigned-int) -> '*)
|
||
|
||
(define-gnunet-fs %publish-stop
|
||
"GNUNET_FS_publish_stop" : (list '*) -> void)
|
||
|
||
(define-gnunet-fs %test-for-directory
|
||
"GNUNET_FS_meta_data_test_for_directory" : (list '*) -> int)
|
||
|
||
(define* (make-block-options expiration-time anonymity-level
|
||
#:key (content-priority 365)
|
||
(replication-level 1))
|
||
"For the filesharing service at the lower level, everything on the network is
|
||
exchanged as blocks. Block options allow you to specify how to publish such
|
||
blocks."
|
||
(make-c-struct (list time-absolute uint32 uint32 uint32)
|
||
(list expiration-time anonymity-level
|
||
content-priority replication-level)))
|
||
|
||
(define-record-type <file-information>
|
||
(wrap-file-information pointer)
|
||
file-information?
|
||
(pointer unwrap-file-information))
|
||
|
||
(define (call-with-fileinfo-args name f path keywords metadata block-options)
|
||
"Check if PATH and BLOCK-OPTIONS are valid, then call F on PATH, KEYWORDS and
|
||
METADATA as pointers."
|
||
(when (string-null? path)
|
||
(throw 'invalid-arg name path))
|
||
(when (or (null? block-options) (not (pointer? block-options)))
|
||
(throw 'invalid-arg name block-options))
|
||
(f (string->pointer* path)
|
||
(string->pointer* (keyword-list->string keywords))
|
||
(if metadata (unwrap-metadata metadata) %null-pointer)))
|
||
|
||
(define-syntax-rule (with-fileinfo-args (name path keywords metadata
|
||
block-options)
|
||
%args expr expr* ...)
|
||
(call-with-fileinfo-args name (lambda %args expr expr* ...)
|
||
path keywords metadata block-options))
|
||
|
||
(define* (file->file-information% filesharing-handle path block-options
|
||
#:key (keywords '()) metadata (index? #t))
|
||
"Builds a file information object from PATH to be published under
|
||
BLOCK-OPTIONS.
|
||
|
||
KEYWORDS is a list of additional keywords (as strings) under which the file will
|
||
be published, METADATA is some initial metadata, and INDEX? specifies if the
|
||
file should be indexed or not (#t by default)."
|
||
(with-fileinfo-args ("file->file-information%"
|
||
path keywords metadata block-options)
|
||
(%path %keywords %metadata)
|
||
(%file-information-create-from-file filesharing-handle %null-pointer %path
|
||
%keywords %metadata (bool->int index?)
|
||
block-options)))
|
||
|
||
(define (file->file-information . args)
|
||
(let ((res (apply file->file-information% args)))
|
||
(when (eq? %null-pointer res)
|
||
(throw 'invalid-result "file->file-information"
|
||
"%file-information-create-from-file"
|
||
args))
|
||
(wrap-file-information res)))
|
||
|
||
(define* (directory->file-information% filesharing-handle path block-options
|
||
#:key (keywords '()) metadata)
|
||
(with-fileinfo-args ("directory->file-information%"
|
||
path keywords metadata block-options)
|
||
(%path %keywords %metadata)
|
||
(%file-information-create-empty-directory filesharing-handle %null-pointer
|
||
%keywords %metadata block-options
|
||
%path)))
|
||
|
||
(define (directory->file-information . args)
|
||
(wrap-file-information (apply directory->file-information% args)))
|
||
|
||
(define (file-information-filename file-info)
|
||
(let ((%s (%file-information-get-filename
|
||
(unwrap-file-information file-info))))
|
||
(if (eq? %null-pointer %s)
|
||
#f
|
||
(pointer->string %s))))
|
||
|
||
(define (file-information-directory? file-info)
|
||
(int->bool (%file-information-is-directory
|
||
(unwrap-file-information file-info))))
|
||
|
||
(define (file-information-add! directory file)
|
||
"Add FILE to DIRECTORY."
|
||
(when (eq? %null-pointer directory)
|
||
(throw 'invalid-arg "file-information-add!" directory))
|
||
(when (eq? %null-pointer file)
|
||
(throw 'invalid-arg "file-information-add!" file))
|
||
(case (%file-information-add! directory file)
|
||
((gnunet-ok) *unspecified*)
|
||
((gnunet-system-error) (throw 'invalid-result "file-information-add!"
|
||
"%file-information-add!" directory))))
|
||
|
||
(define (file-information-destroy %file-info)
|
||
"Free a file-information structure.
|
||
|
||
WARNING: must NEVER be called on a file-info that has been given to
|
||
START-PUBLISH. In fact, you should probably not be using this function."
|
||
(%file-information-destroy %file-info %null-pointer %null-pointer))
|
||
|
||
(define (procedure->file-information-processor f)
|
||
(define (trim lst) (drop-right! (cdr lst) 1))
|
||
(procedure->pointer int
|
||
(lambda args
|
||
(case (apply f (trim args))
|
||
((#:delete) gnunet-no)
|
||
((#:abort) gnunet-system-error)
|
||
(else gnunet-yes)))
|
||
(list '* '* uint64 '* '* '* '* '*)))
|
||
|
||
(define (file-information-iterate f file-info)
|
||
"Recursively call F on each file and directory of FILE-INFO.
|
||
|
||
F is a function of six arguments:
|
||
– file-information (pointer)
|
||
– length (integer)
|
||
– metadata (pointer)
|
||
– uri (pointer to pointer)
|
||
– block-options (pointer)
|
||
– do-index (pointer to integer)
|
||
representing the currently inspected entry. The metadata, block-options
|
||
and do-index slots can be modified.
|
||
|
||
If can return two special value: #:DELETE to remove the currently inspected
|
||
entry from the collection, and #:ABORT to stop iterating."
|
||
(%file-information-inspect (unwrap-file-information file-info)
|
||
(procedure->file-information-processor f)
|
||
%null-pointer))
|
||
|
||
|
||
#;(define (directory-scanner-result filesharing-handle scanner)
|
||
"Returns the result of the scan as a pointer to a “share tree”.
|
||
|
||
WARNING: the scanner is unusable after a call to DIRECTORY-SCANNER-RESULT (the
|
||
associated memory is freed)."
|
||
(let ((res (%directory-scan-get-result scanner)))
|
||
(%share-tree-trim! res)
|
||
res))
|
||
|
||
#;(define (share-tree->file-information filesharing-handle share-tree index?
|
||
block-options)
|
||
"Transform a pointer to a “share-tree” to an instance of <file-information>.
|
||
|
||
WARNING: the share-tree is unusable after a call to
|
||
SHARE-TREE->FILE-INFORMATION (the associated memory is freed)."
|
||
(match (parse-c-struct share-tree
|
||
(list '* '* '* '* '* '* '* '* '* int))
|
||
((_ _ _ _ _ %metadata %ksk-uri %filename _ %is-directory)
|
||
(when (= gnunet-ok %is-directory)
|
||
(throw 'unimplemented "share-tree->file-information"
|
||
%directory-scan-get-result (list (pointer->string* %filename))))
|
||
(let ((%fi (%file-information-create-from-file
|
||
filesharing-handle %null-pointer %filename %ksk-uri %metadata
|
||
(bool->int index?) block-options)))
|
||
(when (eq? %null-pointer %fi)
|
||
(throw 'invalid-result "share-tree->file-information"
|
||
"%file-information-create-from-file"
|
||
(list filesharing-handle %filename %ksk-uri
|
||
%metadata (bool->int index?))))
|
||
(%share-tree-free share-tree)
|
||
(wrap-file-information %fi)))))
|
||
|
||
#;(define directory-scanner-progress-update-reason-alist
|
||
'((0 . #:file-start)
|
||
(1 . #:file-ignored)
|
||
(2 . #:all-counted)
|
||
(3 . #:extract-finished)
|
||
(4 . #:finished)
|
||
(5 . #:internal-error)))
|
||
|
||
#;(define (number->reason n)
|
||
(assoc-ref directory-scanner-progress-update-reason-alist n))
|
||
|
||
#;(define (scan-progress-callback->pointer thunk)
|
||
(procedure->pointer void (lambda (_ %filename %is-directory %reason)
|
||
(thunk (pointer->string* %filename)
|
||
(int->bool %is-directory)
|
||
(number->reason %reason)))
|
||
(list '* '* int unsigned-int)))
|
||
|
||
#;(define* (start-directory-scan filename progress-cb
|
||
#:key disable-extractor?)
|
||
"Start a directory scan on FILENAME, extracting metadata (unless
|
||
DISABLE-EXTRACTOR? is #t) and calling PROGRESS-CB each time there’s an
|
||
update. The scanning is done asynchronously in a separate process (an instance
|
||
of `gnunet-helper-fs-publish`).
|
||
|
||
PROGRESS-CB must be a procedure of three arguments:
|
||
– the filename of the file currently being scanned;
|
||
– a boolean, true if the current file is in fact a directory;
|
||
– the reason of the update, a keyword from the set:
|
||
#:file-start #:file-ignored #:all-counted
|
||
#:extract-finished #:finished #:internal-error"
|
||
(when (string-null? filename)
|
||
(throw 'invalid-arg "start-directory-scan" filename))
|
||
(let ((%filename (string->pointer filename))
|
||
(%disable-extractor? (if disable-extractor? gnunet-yes gnunet-no))
|
||
(%callback (scan-progress-callback->pointer progress-cb)))
|
||
(or% (%directory-scan-start %filename %disable-extractor? %null-pointer
|
||
%callback %null-pointer)
|
||
(throw 'invalid-result "start-directory-scan" "%directory-scan-start"
|
||
%null-pointer))))
|
||
|
||
#;(define (stop-directory-scan scanner)
|
||
"Abort a scan.
|
||
|
||
WARNING: must NEVER be called inside the “progress callback” of the scanner;
|
||
instead, use ADD-TASK! to schedule its call outside the callback."
|
||
(%directory-scan-abort scanner))
|
||
|
||
|
||
(define (progress-callback->pointer thunk)
|
||
(procedure->pointer '* (lambda (_ %info)
|
||
(thunk (parse-c-progress-info %info)
|
||
(progress-info-status %info))
|
||
%null-pointer)
|
||
(list '* '*)))
|
||
|
||
;; This is a temporary replacement for the actual GNUNET_FS_start function that
|
||
;; is variadic and, hence, not currently handlable by Guile’s Dynamic FFI.
|
||
;;
|
||
;;+TODO: dynamically allocate the entire structure & client-name, so that we can
|
||
;; call GNUNET_FS_stop on the returned handle.
|
||
(define (%fs-start %config %client-name %progress-callback)
|
||
(let* ((size (sizeof struct-fs-handle))
|
||
(%handle (%malloc size))
|
||
(bv (pointer->bytevector %handle size))
|
||
(write-c-struct (@@ (system foreign) write-c-struct)))
|
||
(write-c-struct bv 0 struct-fs-handle
|
||
(list %config
|
||
%client-name
|
||
%progress-callback
|
||
%null-pointer ; progress-cb closure
|
||
%null-pointer ; top_head
|
||
%null-pointer ; top_tail
|
||
%null-pointer ; running_head
|
||
%null-pointer ; running_tail
|
||
%null-pointer ; pending_head
|
||
%null-pointer ; pending_tail
|
||
%null-pointer ; probes_head
|
||
%null-pointer ; probes_tail
|
||
%null-pointer ; queue_job
|
||
%null-pointer ; probe_ping_task
|
||
(time-rel #:minutes 1) ; avg_block_latency
|
||
0 ; active_downloads
|
||
0 ; active_blocks
|
||
0 ; flags
|
||
default-max-parallel-downloads
|
||
default-max-parallel-requests))
|
||
%handle))
|
||
|
||
(define (open-filesharing-service config client-name progress-callback)
|
||
"Set up and return a handle to the filesharing service. CONFIG must be a
|
||
configuration handle, CLIENT-NAME a string (a priori the name of your program),
|
||
and PROGRESS-CALLBACK a function of one arg (a foreign pointer to a `struct
|
||
GNUNET_FS_ProgressInfo`) that will be called every time something happens in the
|
||
filesharing service (a search is started, a download is completed, etc.)."
|
||
(when (null? client-name)
|
||
(throw 'invalid-arg "open-filesharing-service" client-name))
|
||
(or% (%fs-start (unwrap-configuration config)
|
||
(string->pointer client-name)
|
||
(progress-callback->pointer progress-callback))
|
||
(throw 'invalid-result "open-filesharing-service" "%fs-start"
|
||
%null-pointer)))
|
||
|
||
(define (close-filesharing-service! handle)
|
||
"Close our connection to the filesharing service. OPEN-FILESHARING-SERVICE’s
|
||
callback will not be called anymore after this function returns.
|
||
|
||
WARNING: this function must *not* be called from OPEN-FILESHARING-SERVICE’s
|
||
callback (it frees the handle which is still used after the callback returns).
|
||
|
||
WARNING: the handle will be unusable after this function returns."
|
||
(%fs-stop handle))
|
||
|
||
(define (start-search filesharing-handle uri)
|
||
(or% (%search-start filesharing-handle
|
||
(unwrap-uri uri)
|
||
0 0 %null-pointer)
|
||
(throw 'invalid-result "start-search" "%search-start" %null-pointer)))
|
||
|
||
(define (stop-search search-handle)
|
||
(%search-stop search-handle))
|
||
|
||
(define (start-download filesharing-handle uri filename)
|
||
(or% (%download-start filesharing-handle (unwrap-uri uri) %null-pointer
|
||
(string->pointer filename) %null-pointer 0
|
||
(uri-file-size uri) 0 0 %null-pointer %null-pointer)
|
||
(throw 'invalid-result "start-download" "%download-start"
|
||
%null-pointer)))
|
||
|
||
(define* (stop-download download-handle #:key delete-incomplete?)
|
||
(%download-stop download-handle (if delete-incomplete? gnunet-yes gnunet-no)))
|
||
|
||
(define* (start-publish filesharing-handle file-information
|
||
#:key namespace identifier
|
||
update-identifier simulate?)
|
||
"Publish a file or a directory. If SIMULATE? is #t, no data will be stored in
|
||
the datastore.
|
||
|
||
By default, publishing is made in the global namespace (keywords extracted from
|
||
the file are used to identify it). If NAMESPACE is set (to an instance of
|
||
<ego>), then IDENTIFIER should also be set (to a string that will be used to
|
||
identify the publication in place of the extracted keywords)."
|
||
;; if namespace is set, identifier must be, and conversely
|
||
(when (or (and namespace (not identifier))
|
||
(and identifier (not namespace)))
|
||
(throw 'invalid-arg "start-publish" namespace identifier))
|
||
;; update-identifier has no sense if namespace is #f
|
||
(when (and update-identifier (not namespace))
|
||
(throw 'invalid-arg "start-publish" namespace update-identifier))
|
||
(let ((%priv (if namespace (ego-private-key namespace) %null-pointer))
|
||
(%identifier (if identifier (string->pointer identifier) %null-pointer))
|
||
(%update-id (if update-identifier (string->pointer update-identifier)
|
||
%null-pointer))
|
||
(%simulate? (if simulate? gnunet-yes gnunet-no)))
|
||
(or% (%publish-start filesharing-handle (unwrap-file-information
|
||
file-information) %priv %identifier
|
||
%update-id %simulate?)
|
||
(throw 'invalid-result "start-publish" "%publish-start" %null-pointer))))
|
||
|
||
(define (stop-publish publish-handle)
|
||
"Stops a publication.
|
||
|
||
WARNING: must NEVER be called inside the “progress callback” of the Filesharing
|
||
system; instead, use ADD-TASK! to schedule its call outside the callback."
|
||
(%publish-stop publish-handle))
|
||
|
||
;;+TODO: should be (is-directory? search-result) or
|
||
;; (result-is-directory? result)
|
||
(define (is-directory? metadata)
|
||
"Checks some search result’s METADATA if its mime-type matches
|
||
GNUNET_FS_DIRECTORY_MIME."
|
||
(= gnunet-yes (%test-for-directory (unwrap-metadata metadata))))
|