;;; 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-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))))