;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Rémi Birot-Delrue <address@hidden>
;;;
;;; 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)))))