Hello!
it’s been a while since my last report, time for some news.
What happened since last time?
——————————————————————————————
After our meeting with Ludovic and Christian, I started working on the
downloading and publication related functions. The tests and example
programs were rapidly riddled with bugs and segfaults, and I’ve spent
around one month trying to get the publication working.
Once these problems have been addressed (i.e. a week ago), I could
finally start working on the GNUnet publisher for Guix. Its first
version can only upload one store item at a time, and isn’t even
functional yet: a fikle segfault deems it unusable. Before noticing
this segfault (it doesn’t always happen), I started working on a more
complex version that would allow bulk publication of store items, but
this gain in complexity came with a hole new set of strange and hardly
traceable errors (SIGILL and SIGBUS), and it’s far from being
usable. Moreover, the two version seem to have difficulties handling
symlinks.
Guile – GNUnet
——————————————
The bindings are focused on the FileSharing service, and seem
usable. I’ll write detailed documentation before the end of the GSoC,
and list the pitfalls to avoid (at least those I’m aware of). There’s
still work to do, notably:
— unify the names, according to Scheme/Guile/Guix conventions, and
reorganize the source.
— check every function for lacks of arguments checking, verify
everything that’s given to foreign functions.
— replace all ad-hoc exceptions with more meaningful srfi-34
exceptions;
— replace `invalid-result` exceptions, raised whenever a foreign
function returns NULL, with more meaningful ones (by inspecting
the GNUnet source);
— use the various “context pointers” to allow a more functional
style: discarded in the current bindings, these are transmitted
from one function call to another (akin `fold`).
— improve testing, document everything, complete the bindings and
extend them to other GNUnet services.
Publishing packages
———————————————————
Eclosed you’ll find the more usable version of the publisher, “tested”
with the following software:
— Guix: commit 7cb6f648b2486b0e6060a333564432a0830637de
— GNUnet: rev. 36242
— Libextractor: rev. 36031
— the bindings: commit dc6f74d269fcb324d8649f3c511299b7ba2be2a4
It’s important to use a recent version of GNUnet, because its API
changed recently (especially, Guix’s currently packaged version isn’t
good).
This publisher can be tested: for that you’ll have to put
`publish-gnunet.scm` and `publish-utils.scm` in `guix/scripts`, and
start GNUnet (see my previous reports). Then you can create an ego:
$ gnunet-identity -C mytestego
and call the publisher with:
$ guix publish-gnunet -c /path/to/gnunet.conf -P mytestego \
/gnu/store/somedirectory
The file `publish-utils.scm` contains code shared between the HTTP
publisher and this one; I did not knew were to store it, thus the
improper module in (guix scripts). `publish-gnunet-multi.scm` is the
WIP second version, not usable at all :(
As usual, do not hesitate to contact me for any question or remark!
--
Rémi
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Rémi Birot-Delrue <asg...@free.fr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts publish-gnunet)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module ((srfi srfi-26) #:select (cut))
#:use-module (srfi srfi-37)
#:use-module ((rnrs bytevectors) #:select (string->utf8
utf8->string))
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
#:use-module (ice-9 regex)
#:use-module (system foreign)
#:use-module (guix base32)
#:use-module (guix pki)
#:use-module (guix store)
#:use-module (guix ui)
#:use-module ((guix config) #:select (%store-directory))
#:use-module ((gnu gnunet common) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet configuration) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet scheduler) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet container metadata)
#:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet identity) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet fs) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet fs progress-info)
#:renamer (symbol-prefix-proc 'gn:))
#:use-module (guix scripts publish-utils)
#:export (guix-publish-gnunet))
;; debug variables
(define *simulate?* #t)
(define *index?* #t)
(define *anonymity* 0)
(define (show-help)
(display (_ "Usage: guix publish-gnunet [OPTION]...PACKAGE...
Publish PACKAGE... over GNUnet.\n"))
(display (_ "
-P, --pseudonym=NAME publish the store under the namespace specified by
pseudonym NAME"))
(newline)
(display (_ "
-h, --help display this help and exit"))
(display (_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
;;+TODO: handle -L (loglevel) and -l (logfile) options
(define %options
(let ((register (lambda (id)
(lambda (opt name arg opts targets)
(values (alist-cons id arg opts) targets)))))
(list (option '(#\h "help") #f #f
(lambda _
(show-help)
(exit 0)))
(option '(#\V "version") #f #f
(lambda _
(show-version-and-exit "guix publish-gnunet")))
(option '(#\c "config") #t #f (register 'config-file))
(option '(#\P "pseudonym") #t #f (register 'pseudonym)))))
(define %default-options '())
;; option for the blocks weâre going to publish
(define %block-options
(gn:make-block-options (gn:time-relative->absolute (gn:time-rel #:days (* 180)))
*anonymity*))
(define %default-config-file "~/.config/gnunet.conf")
;; handles -- connection to a GNUnet service or operation
(define %config #f)
(define %identity #f)
(define %ego #f)
(define %filesharing #f)
;;; utilities to keep track of the publish handles
(define %publish-entries #f)
(define (print-state)
(simple-format (current-error-port) "--- state ---
config \t~a~%
identity \t~a~%
ego \t~a~%
filesharing\t~a~%
entries \t~a~%"
%config %identity %ego %filesharing %publish-entries))
;;;+TODO: replace the `identifier` slot with the use of a hash-table
;;; for %publish-entries.
(define-record-type <publish-entry>
(%make-publish-entry handle identifier completed? stopped? error?)
publish-entry?
(handle publish-entry-handle %set-publish-handle!)
(identifier publish-entry-id)
(completed? publish-entry-completed? %set-publish-entry-completeness!)
(stopped? publish-entry-stopped? %set-publish-entry-stopness!)
(error? publish-entry-error? %set-publish-entry-errorness!))
(define (publish-entry-complete! entry)
(when (publish-entry-completed? entry)
(warning (_ "~A: already completed~%") entry))
(%set-publish-entry-completeness! entry #t))
(define (publish-entry-stop! entry)
(when (publish-entry-stopped? entry)
(warning (_ "~A: already stopped~%") entry))
(%set-publish-entry-stopness! entry #t))
(define (publish-entry-error! entry)
(when (publish-entry-error? entry)
(warning (_ "~A: already on error~%") entry))
(%set-publish-entry-errorness! entry #t))
(define* (start-publish filesharing file-info namespace identifier)
"Start the publication of FILE-INFO under NAMESPACE with IDENTIFIER,
return a publish entry."
(simple-format (current-error-port) "start-publish: ~a~%" (gn:file-information-filename file-info))
(%make-publish-entry (gn:start-publish filesharing file-info
#:namespace namespace
#:identifier identifier)
identifier
#f #f #f))
(define* (stop-publish entry)
;; we must advance the entryâs state before calling gn:stop-publish,
;; as otherwise progress-callback would be called with a non-updated
;; entry state.
(simple-format (current-error-port) "stop-publish: ~a~%" entry)
(publish-entry-stop! entry)
(gn:stop-publish (publish-entry-handle entry))
(%set-publish-handle! entry #f))
(define (find-entry id lst)
(find (compose (cut string=? id <>) publish-entry-id) lst))
;; used to make publish-entries identifiers
(define %store-item-regexp
(make-regexp (string-append "^" %store-directory
"/([a-z0-9]+)" ; hash
"-"
"[^/]+" ; program name
"(/.*)?$")))
(define (path->hash path)
"Extract the hash part of the store item PATH."
(match:substring (regexp-exec %store-item-regexp path) 1))
(define (store-item? path)
"Return #t if PATH is of the form:
`%store-directory/<hash>-<name-version>`."
(not (match:substring (regexp-exec %store-item-regexp path) 2)))
;;; utilities to scan a directory and collect each file
;;+FIXME: is the âsymlink targetâ metadata really needed?
(define (file->file-information* path stat)
"Create a file information from a file. If PATH denotes a symlink,
add its target to its metadata (under the #:filename metatype)."
(let* ((meta (gn:make-metadata))
(type (stat:type stat))
(item (case type
((symlink)
(gn:make-metadata-item
;; name of the âextractorâ
"guix publish-gnunet"
;; we use the #:filename (EXTRACTOR_METADATA_FILENAME)
;; metatype because itâs never used in GNUnet
;; (see gnunet/src/fs/fs_dirmetascan.c:374).
#:filename
#:utf8
"text/plain"
(string->utf8 (readlink path))))
((regular) #f)
(else
(leave (_ "~A: invalid file type (~a)~%") path type)))))
(when item (gn:metadata-set! meta item))
(let ((res (gn:file->file-information% %filesharing path %block-options
#:index? #t #:metadata meta)))
;;+FIXME: which exception should be raised?
(when (eq? %null-pointer res)
(throw 'invalid-result "file->file-information*"
"gn:file->file-information%"
(list %filesharing path %block-options #:index #t
#:metadata meta)))
res)))
(define* (directory->file-information* path #:key (add-metadata '()))
"Create a file information from a directory; the content of the
directory isnât scanned.
ADD-METADATA is a list of metadata entries to add to the directoryâs
metadata."
(let ((meta (gn:make-metadata)))
(when (not (null? add-metadata))
(for-each (lambda (item) (gn:metadata-set! meta item)) add-metadata))
(gn:directory->file-information% %filesharing path %block-options
#:metadata meta)))
(define (tree->file-information path tree . meta)
(define (prefix relpath) (string-append path "/" relpath))
(match tree
((file stat) (file->file-information* (prefix file) stat))
((dir stat files ...)
(let ((info (directory->file-information* (prefix dir)
#:add-metadata meta)))
(map (compose (cut gn:file-information-add! info <>)
(cut tree->file-information (prefix dir) <>))
files)
info))
(_ ; shouldnât happen
(leave (_ "failed to access ~A~%") path))))
;;+FIXME: prefix
;;+TODO: optimize?
(define (scan-directory path . metadata)
"Scan the directory PATH, collect each file, and add METADATA to the
root file information."
(apply tree->file-information (dirname path) (file-system-tree path)
metadata))
(define (scan-store-path store path)
"Scan the PATH as a path in STORE and return a file-information."
(let* ((path-info (query-path-info store path))
(narinfo (narinfo-string path path-info (force %private-key)))
(meta-item (gn:make-metadata-item "guix publish-gnunet" #:narinfo
#:utf8 "text/plain"
(string->utf8 narinfo))))
(gn:wrap-file-information (scan-directory path meta-item))))
;;+TODO: handle GNUNET_ARGS
;;+TODO: handle XDG_CONFIG_HOME
;;+TODO: properly handle GNUnet configuration file
;; (add something in Guixâs conf?)
(define (guix-publish-gnunet . args)
(let*-values (((opts paths)
(args-fold* args %options
(lambda (opt name . rest)
(leave (_ "~A: unrecognized option~%") name))
(lambda (arg opts paths)
(values opts (cons arg paths)))
%default-options
(values '() '())))
((pseudo config-file)
(values (assoc-ref opts 'pseudonym)
(or (assoc-ref opts 'config-file)
(begin
(warning (_ "using default config file ~A~%")
%default-config-file)
%default-config-file)))))
(when (not pseudo)
(leave (_ "missing pseudonym option~%")))
(when (null? paths)
(leave (_ "missing store item argument~%")))
(map (lambda (path)
(when (not (access? path R_OK))
(leave (_ "failed to access ~A~%") path)))
paths)
(catch 'file-unavailable
(lambda () (set! %config (gn:load-configuration config-file)))
(lambda (key . args)
(leave (_ "failed to access ~A~%") config-file)))
;;+TODO: add stop-task
(gn:call-with-scheduler
%config
(lambda (_)
(set! %identity
(gn:open-identity-service %config
(identity-callback pseudo paths)))
(gn:add-task! stop-task #:delay (gn:time-rel #:forever))))))
(define (identity-callback pseudo paths)
(lambda (ego name)
"Function called by GNUnetâs identity service. Itâs mapped on each
available ego."
(cond ((not ego) ; last call
(display "identity-callback: last call\n" (current-error-port))
(set! %filesharing
(gn:open-filesharing-service %config "guix publish-gnunet"
progress-callback))
(gn:add-task! (lambda (_) (scan-&-publish paths))))
((and name (string=? pseudo name))
(set! %ego ego)))))
(define (scan-&-publish paths)
"Scan each of the PATHS and start publishing them. Return a list of
publish entries."
(with-error-handling
(with-store store
(set! %publish-entries
(fold (lambda (path entries)
(let ((info (scan-store-path store path))
(hash (path->hash path)))
(cons (start-publish %filesharing info %ego hash)
entries)))
'()
paths)))))
(define (progress-callback info status)
"Called by the filesharing service each time thereâs something to
report about one of our publications."
;;+TODO: shouldnât we stop every publication once all are finished,
;; instead of closing each one separately?
(define (schedule-stop! entry)
(simple-format (current-error-port) " schedule-stop!: ~a~%" entry)
(when (not (publish-entry-stopped? entry))
(display " add-task: STOP-PUBLISH~%" (current-error-port))
(gn:add-task! (lambda (_) (stop-publish entry)))))
(define pinfo-publish-entry
(compose (cut find-entry <> %publish-entries)
path->hash
gn:pinfo-publish-filename))
(simple-format #t "progress-callback: ~a ~a~%"
(gn:pinfo-publish-filename info) status)
(match status
((#:publish #:error)
(let ((entry (pinfo-publish-entry info)))
(simple-format #t (_ "Error publishing: ~a\n")
(gn:pinfo-publish-message info))
(publish-entry-error! entry)
(schedule-stop! entry)))
((#:publish #:completed)
;; only the root directories (e.g. store items) have SKS URIs
(when (gn:pinfo-publish-sks-uri info)
(let ((entry (pinfo-publish-entry info)))
(simple-format #t (_ "~A: published.~%")
(gn:pinfo-publish-filename info))
(publish-entry-complete! entry)
(schedule-stop! entry))))
((#:publish #:stopped)
(simple-format (current-error-port) "progress-cb: ~a~%" (gn:pinfo-publish-filename info))
(when (store-item? (gn:pinfo-publish-filename info))
(simple-format (current-error-port) " store-item!~%")
(when (every publish-entry-stopped? %publish-entries)
(simple-format (current-error-port) " every publish entry stopped:~% ~a~%" %publish-entries)
(gn:schedule-shutdown!)
(display " scheduled shutdown!\n" (current-error-port))
(print-state)
(force-output (current-error-port)))))
;;+TODO: add #:suspend and co
((#:publish (or #:start #:progress #:progress-directory))
*unspecified*)))
#;(define (sum-up)
"Print an overview of the publication."
(let ((failures (filter (compose (cut eq? #:aborted <>)
publish-entry-state)
%publish-entries))
(unknowns (filter (compose not publish-entry-stopped?)
%publish-entries))
(print-entry (compose (cut simple-format #t " ~A~%" <>)
publish-entry-id))
(entries-num (length %publish-entries)))
(when (not (null? failures))
(simple-format #t (_ "~A store item(s) werenât published:~%")
(length failures))
(map print-entry failures))
(when (not (null? unknowns))
(simple-format #t (_ "~A store item(s) have an unknown state:~%")
(length unknowns))
(map print-entry failures))
(simple-format #t (_ "~A/~A store items successfully published.~%")
(- entries-num (length failures)) entries-num)))
;;+FIXME: is running STOP-TASK a second time really needed?
;; GN:STOP-PUBLISH seem synchronous.
(define (stop-task _)
"Stop the various GNUnet services in the right order."
(simple-format (current-error-port) "stop-task: ~a~%" %publish-entries)
(print-state)
(force-output (current-error-port))
(sleep 1)
(cond (%identity
(gn:close-identity-service %identity)
(set! %identity #f))
;; All the publish handles should be stopped before closing the
;; filesharing handle.
(%publish-entries
(map (lambda (entry)
(when (not (publish-entry-stopped? entry))
(simple-format (current-error-port) " stopping ~a:~%" entry)
(force-output)))
%publish-entries)
(display " adding another stop task\n" (current-error-port))
(gn:add-task! stop-task))
(%filesharing
(display " will close filesharing\n" (current-error-port))
(force-output (current-error-port))
;;+TODO: add a hook here?
; (sum-up)
(gn:close-filesharing-service! %filesharing)
(set! %filesharing #f))))
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Rémi Birot-Delrue <asg...@free.fr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts publish-gnunet)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module ((srfi srfi-26) #:select (cut))
#:use-module (srfi srfi-37)
#:use-module ((rnrs bytevectors) #:select (string->utf8))
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
#:use-module (system foreign)
#:use-module (guix base32)
#:use-module (guix pki)
#:use-module (guix store)
#:use-module (guix ui)
#:use-module ((gnu gnunet common) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet configuration) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet scheduler) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet container metadata)
#:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet identity) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet fs) #:renamer (symbol-prefix-proc 'gn:))
#:use-module ((gnu gnunet fs progress-info)
#:renamer (symbol-prefix-proc 'gn:))
#:use-module (guix scripts publish-utils)
#:export (guix-publish-gnunet))
;; debug variables
(define *simulate?* #t)
(define *index?* #t)
(define *anonymity* 0)
(define (show-help)
(display (_ "Usage: guix publish-gnunet [OPTION]...PACKAGE...
Publish PACKAGE... over GNUnet.\n"))
(display (_ "
-P, --pseudonym=NAME publish the store under the namespace specified by
pseudonym NAME"))
(newline)
(display (_ "
-h, --help display this help and exit"))
(display (_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
;;+TODO: handle -L (loglevel) and -l (logfile) options
(define %options
(let ((register (lambda (id)
(lambda (opt name arg opts targets)
(values (alist-cons id arg opts) targets)))))
(list (option '(#\h "help") #f #f
(lambda _
(show-help)
(exit 0)))
(option '(#\V "version") #f #f
(lambda _
(show-version-and-exit "guix publish-gnunet")))
(option '(#\c "config") #t #f (register 'config-file))
(option '(#\P "pseudonym") #t #f (register 'pseudonym)))))
(define %default-options '())
;; option for the blocks weâre going to publish
(define %block-options
(gn:make-block-options (gn:time-relative->absolute (gn:time-rel #:days (* 180)))
*anonymity*))
(define %default-config-file "~/.config/gnunet.conf")
;; handles -- connection to a GNUnet service or operation
(define %config #f)
(define %identity #f)
(define %ego #f)
(define %filesharing #f)
(define %publish #f)
(define %publish-completed? #f)
(define %publish-error? #f)
(define %publish-stopped? #f)
;;; utilities to scan a directory and collect each file
(define (file->file-information* path stat)
"Create a file information from a file. If PATH denotes a symlink,
add its target to its metadata (under the #:filename metatype)."
(let ((res (gn:file->file-information% %filesharing path
%block-options #:index? #t)))
;;+FIXME: which exception should be raised?
(when (eq? %null-pointer res)
(throw 'invalid-result "file->file-information*"
"gn:file->file-information%"
(list %filesharing path %block-options #:index #t)))
res))
(define* (directory->file-information* path #:key (add-metadata '()))
"Create a file information from a directory; the content of the
directory isnât scanned.
ADD-METADATA is a list of metadata entries to add to the directoryâs
metadata."
(let ((meta (gn:make-metadata)))
(when (not (null? add-metadata))
(for-each (lambda (item) (gn:metadata-set! meta item)) add-metadata))
(gn:directory->file-information% %filesharing path %block-options
#:metadata meta)))
(define (tree->file-information path tree . meta)
(define (prefix relpath) (string-append path "/" relpath))
(match tree
((file stat) (file->file-information* (prefix file) stat))
((dir stat files ...)
(let ((info (directory->file-information* (prefix dir)
#:add-metadata meta)))
(map (compose (cut gn:file-information-add! info <>)
(cut tree->file-information (prefix dir) <>))
files)
info))))
(define (scan-directory path . metadata)
"Scan the directory PATH, collect each file, and add METADATA to the
root file information."
(apply tree->file-information (dirname path) (file-system-tree path)
metadata))
(define (scan-store-path store path)
(let* ((path-info (query-path-info store path))
(narinfo (narinfo-string path path-info (force %private-key)))
(meta-item (gn:make-metadata-item "guix publish-gnunet" #:narinfo
#:utf8 "text/plain"
(string->utf8 narinfo))))
(gn:wrap-file-information (scan-directory path meta-item))))
;;+TODO: handle GNUNET_ARGS
;;+TODO: handle XDG_CONFIG_HOME
;;+TODO: properly handle GNUnet configuration file
;; (add something in Guixâs conf?)
(define (guix-publish-gnunet . args)
(let*-values (((opts paths)
(args-fold* args %options
(lambda (opt name . rest)
(leave (_ "~A: unrecognized option~%") name))
(lambda (arg opts paths)
(values opts (cons arg paths)))
%default-options
(values '() '())))
((pseudo config-file)
(values (assoc-ref opts 'pseudonym)
(or (assoc-ref opts 'config-file)
(begin
(warning (_ "using default config file ~A~%")
%default-config-file)
%default-config-file)))))
(when (not pseudo)
(leave (_ "missing pseudonym option~%")))
(when (null? paths)
(leave (_ "missing store item argument~%")))
(map (lambda (path)
(when (not (access? path R_OK))
(leave (_ "failed to access ~A~%") path)))
paths)
(catch 'file-unavailable
(lambda ()
(set! %config (gn:load-configuration config-file)))
(lambda args
(leave (_ "failed to access ~A~%") config-file)))
(gn:call-with-scheduler
%config
(lambda (_)
(set! %identity
(gn:open-identity-service %config
(identity-callback pseudo paths)))
(gn:add-task! (get-stop-task (car paths))
#:delay (gn:time-rel #:seconds 30))))))
(define (identity-callback pseudo paths)
(lambda (ego name)
"Function called by GNUnetâs identity service. Itâs mapped on each
available ego."
(cond ((not name)
(set! %filesharing
(gn:open-filesharing-service %config "guix publish-gnunet"
(get-progress-callback
(car paths))))
(when (not (null? (cdr paths)))
(warning (_ "Additional store paths will be ignored.~%")))
(scan-&-publish (car paths)))
((string= pseudo name)
(set! %ego ego)))))
(define (scan-&-publish path)
"Scan each of the PATHS and start publishing them."
(define (start-publish-path store path)
(let ((filename (basename path))
(id (basename path)))
(set! %publish
(gn:start-publish %filesharing (scan-store-path store path)
#:namespace %ego #:identifier id))))
(with-error-handling
(with-store store
(start-publish-path store path))))
(define (get-progress-callback path)
(lambda (info status)
"Called by the filesharing service each time thereâs something to
report about one of our publications."
(define parent? (string=? path (gn:pinfo-publish-filename info)))
(match status
((#:publish #:start)
(when parent?
(simple-format #t (_ "Publishing ~A...~%") path)))
((#:publish #:completed)
;; only the root directories (e.g. store items) have SKS URIs
(when (gn:pinfo-publish-sks-uri info)
(set! %publish-completed? #:t)
(simple-format #t (_ "~A: published.~%") (gn:pinfo-publish-filename info))
(gn:add-task! (lambda (_)
(when %publish
(gn:stop-publish %publish)
(set! %publish #f))
#t))))
((#:publish #:stopped)
(when parent?
(set! %publish-stopped? #t)
(gn:schedule-shutdown!)))
((#:publish #:error)
(set! %publish-error? #t)
(simple-format #t (_ "Error publishing ~a:~%\t~a~%")
(gn:pinfo-publish-filename info)
(gn:pinfo-publish-message info))
(gn:schedule-shutdown!))
((#:publish (or #:progress #:progress-directory))
*unspecified*))))
(define (sum-up path)
(simple-format #t (if %publish-error?
(_ "~A: has not been published.~%")
(_ "~A: successfully published.~%")) path))
;;+FIXME: is running STOP-TASK a second time really needed?
;; GN:STOP-PUBLISH seem synchronous.
(define (get-stop-task path)
(lambda (_)
"Stop the various GNUnet services in the right order."
(force-output)
(usleep 200)
(when %identity
(gn:close-identity-service %identity))
;; All the publish handles should be stopped before closing the
;; filesharing handle.
(cond (%publish
(gn:stop-publish %publish)
(set! %publish #f)
(gn:add-task! stop-task))
(%filesharing ; last call to stop-task
;;+TODO: add a hook here?
(sum-up path)
(gn:close-filesharing-service! %filesharing)
(set! %filesharing #f)))))
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <da...@gnu.org>
;;; Copyright © 2015 Ludovic Courtès <l...@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts publish-utils)
#:use-module (ice-9 format)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (guix base32)
#:use-module (guix base64)
#:use-module (guix derivations)
#:use-module (guix hash)
#:use-module (guix pk-crypto)
#:use-module (guix pki)
#:use-module (guix store)
#:export (%public-key
%private-key
narinfo-string))
;;; Comment:
;;;
;;; This is shared code between the HTTP and the GNUnet "publishers"
;;; that has been extracted from `guix/scripts/publish.scm'.
;;;
;;; Code:
(define (lazy-read-file-sexp file)
"Return a promise to read the canonical sexp from FILE."
(delay
(call-with-input-file file
(compose string->canonical-sexp
get-string-all))))
#;(define %private-key
(lazy-read-file-sexp %private-key-file))
(define %private-key (delay "dummy-private-key"))
(define %public-key
(lazy-read-file-sexp %public-key-file))
(define (load-derivation file)
"Read the derivation from FILE."
(call-with-input-file file read-derivation))
(define (signed-string s)
"Sign the hash of the string S with the daemon's key."
(let* ((public-key (force %public-key))
(hash (bytevector->hash-data (sha256 (string->utf8 s))
#:key-type (key-type public-key))))
(signature-sexp hash (force %private-key) public-key)))
(define base64-encode-string (compose base64-encode string->utf8))
(define (narinfo-string store-path path-info key)
"Generate a narinfo key/value string for STORE-PATH using the details in
PATH-INFO. The narinfo is signed with KEY."
(let* ((url (string-append "nar/" (basename store-path)))
(hash (bytevector->nix-base32-string
(path-info-hash path-info)))
(size (path-info-nar-size path-info))
(references (string-join
(map basename (path-info-references path-info))
" "))
(deriver (path-info-deriver path-info))
(base-info (format #f
"StorePath: ~a
URL: ~a
Compression: none
NarHash: sha256:~a
NarSize: ~d
References: ~a~%"
store-path url hash size references))
;; Do not render a "Deriver" or "System" line if we are rendering
;; info for a derivation.
(info (if (string-null? deriver)
base-info
(let ((drv (load-derivation deriver)))
(format #f "~aSystem: ~a~%Deriver: ~a~%"
base-info (derivation-system drv)
(basename deriver)))))
(signature (base64-encode-string
"dummy-signature"
#;(canonical-sexp->string (signed-string info)))))
(format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
