add ./gnunet-guile program with download subcommand and getopt-long support

Check the help menu to know how it works.

This is missing integration with autotools.

4 files changed, 148 insertions, 22 deletions

diff --git a/Makefile.am b/Makefile.am
index ef40ab6..a681768 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -22,7 +22,8 @@ SUBDIRS = doc
 docdir = $(datadir)/doc/gnunet-guile/
 
 MODULES =                                       \
-  gnunet.scm
+  gnunet.scm \
+  gnunet/subcommand.scm
 
 GOBJECTS = $(MODULES:%.scm=%.go) gnunet/config.go
 
diff --git a/download.scm b/download.scm
deleted file mode 100644
index 6e136ea..0000000
--- a/download.scm
+++ /dev/null
@@ -1,21 +0,0 @@
-(define-module (download))
-
-(use-modules ((gnunet)))
-
-
-(define %configuration (configuration-create))
-(configuration-load! %configuration "etc/p2.conf")
-
-(define %fs-handle #f)
-(define %fs-download #f)
-
-(define (progress info)
-  (pk (fs-progress-info-status info)))
-
-(scheduler-run
- (lambda ()
-   (set! %fs-handle (fs-start %configuration "guile-gnunet" progress))
-   (set! %fs-download (fs-download-start %fs-handle
-                                         (string->uri (cadr (program-arguments)))
-                                         0
-                                         #:filename "gnunet.out"))))
diff --git a/gnunet-guile b/gnunet-guile
new file mode 100755
index 0000000..750cd04
--- /dev/null
+++ b/gnunet-guile
@@ -0,0 +1,72 @@
+#!/bin/sh
+# -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
+exec guile -e '(@ (gnunet-guile) main)' -s "$0" "$@"
+!#
+;;;; Copyright © 2018 Amirouche Boubekki <amirouche@hypermove.net>
+;;;;
+;;;; 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 (gnunet-guile))
+
+(use-modules ((ice-9 getopt-long)))
+(use-modules ((ice-9 match)))
+
+(use-modules ((gnunet)))
+(use-modules ((gnunet subcommand)))
+
+
+;;; download
+
+(define %fs-handle #f)
+(define %fs-download #f)
+
+(define (progress info)
+  (pk (fs-progress-info-status info)))
+
+(define %download-options
+  '((help (single-char #\h) (value #f))))
+
+(define (download args)
+  "gnunet download CONFIGURATION URI FILENAME
+
+Download the URI to FILENAME using CONFIGURATION.
+"
+  (let ((options (getopt-long (cons "gnunet-guile download" args)
+                              %download-options
+                              #:stop-at-first-non-option #f)))
+    (if (option-ref options 'help #f)
+        (display (procedure-documentation download))
+        (match args
+          ((configuration uri filename)
+           (let ((configuration* (configuration-create)))
+             (configuration-load! configuration* configuration)
+             (scheduler-run
+              (lambda ()
+                (set! %fs-handle (fs-start configuration* "gnunet-guile" progress))
+                (fs-download-start %fs-handle
+                                   (string->uri uri)
+                                   0
+                                   #:filename filename)))))))))
+
+;;; publish
+
+(define (publish . args)
+  (pk 'publish args))
+
+;;; cli
+
+(define %cli `((download ,download)
+               (publish ,publish)))
+
+(define-public (main args)
+  (subcommand 'gnunet-guile %cli (cdr args)))
diff --git a/gnunet/subcommand.scm b/gnunet/subcommand.scm
new file mode 100644
index 0000000..d2dd9b5
--- /dev/null
+++ b/gnunet/subcommand.scm
@@ -0,0 +1,74 @@
+;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
+;;;;
+;;;; Copyright © 2018 Amirouche Boubekki <amirouche@hypermove.net>
+;;;;
+;;;; 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/>.
+;;
+;; Comment:
+;;
+;; Command line interface subcommands parsing
+;;
+(define-module (gnunet subcommand))
+
+(use-modules ((srfi srfi-1)))
+
+
+(define (path-display path)
+  (display "  ")
+  (let loop ((path path))
+    (unless (null? path)
+      (display (car path))
+      (display " ")
+      (loop (cdr path))))
+  (display #\newline))
+
+(define (%spec-help path)
+  (lambda (spec)
+    (if (procedure? (cadr spec))
+        (path-display (append path (list (car spec))))
+        (for-each (%spec-help (append path (list (car spec)))) (cdr spec)))))
+
+(define (spec-help name spec)
+  "Display the usage message for this SPEC for the program named NAME"
+  (display "Usage:\n\n")
+  (for-each (%spec-help (list name)) spec))
+
+(define (%lookup spec args)
+  (if (string=? (symbol->string (car spec)) (car args))
+      (values (cdr spec) (cdr args))
+      (values #f #f)))
+
+(define (lookup spec args)
+  (let loop ((spec spec))
+    (if (null? spec)
+        (values #f #f)
+        (call-with-values (lambda () (%lookup (car spec) args))
+          (lambda (procedure-or-spec args)
+            (cond
+             ((and (not procedure-or-spec) (not args))
+              (loop (cdr spec)))
+             ((procedure? (car procedure-or-spec))
+              (values (car procedure-or-spec) args))
+             (else (lookup procedure-or-spec args))))))))
+
+(define-public (subcommand name spec args)
+  "Execute the subcommand of SPEC based on ARGS for the command NAME"
+  (if (or (null? args) (equal? args '("--help")) (equal? args '("-h")))
+      (spec-help name spec)
+      (call-with-values (lambda () (lookup spec args))
+        (lambda (procedure args)
+          (cond
+           ((and procedure args)
+            (procedure args))
+           (else (spec-help name spec)))))))