;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*- ;;;; ;;;; Copyright © 2015 Rémi Delrue ;;;; ;;;; 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 . (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 ( 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 (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 . 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 ), 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))))