#!/run/current-system/profile/bin/sh
# -*- scheme -*-
exec ${GUILE:-$(which guile)} $GUILE_FLAGS -e '(@@ (maintenance) main)' -s "$0" "$@"
!#

;;;; guix-maintenance --- Script to get a list of my contributed packages
;;;; Copyright © 2020, 2022 Oleg Pykhalov <go.wigust@gmail.com>
;;;; Released under the GNU GPLv3 or any later version.

;; This file contains machinery to find all my packages.  To do that, run:
;;
;;  guile -l manifests/maintenance.scm -c exit
;;
;; The result is a directory hierarchy that can be used as the manual/
;; sub-directory of the web site.

(define-module (maintenance)
  #:use-module (gnu packages)
  #:use-module (guix build utils)
  #:use-module (guix channels)
  #:use-module (guix git)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37))

(define %options
  (let ((display-and-exit-proc (lambda (msg)
                                 (lambda (opt name arg loads)
                                   (display msg) (quit)))))
    (list (option '(#\v "version") #f #f
                  (display-and-exit-proc "guile-ssh version 0.0.1\n"))
          (option '(#\h "help") #f #f
                  (display-and-exit-proc
                   "Usage: guile-ssh ...")))))

(define %default-options
  '())

(define %author "go.wigust@gmail.com")

(define %source-dir
  (and=> (getenv "HOME")
         (lambda (home)
           (string-append home "/src/git.savannah.gnu.org/git/guix"))))

(define (git-output . args)
  "Execute 'git ARGS ...' command and return its output without trailing
newspace."
  (with-directory-excursion %source-dir
    (let* ((port   (apply open-pipe* OPEN_READ "git" args))
           (output (read-string port)))
      (close-port port)
      (string-trim-right output #\newline))))

(define (string-drop-suffix suffix string)
  (if (string-suffix? suffix string)
      (string-drop-right string (string-length suffix))
      string))

(define (string-drop-prefix prefix string)
  (if (string-prefix? prefix string)
      (string-drop string (string-length prefix))
      string))

(define (main args)
  (define opts
    (args-fold (cdr (program-arguments))
               %options
               (lambda (opt name arg loads)
                 (error "Unrecognized option `~A'" name))
               (lambda (op loads)
                 (cons op loads))
               %default-options))
  (let ((packages (map (compose (cut string-drop-prefix "gnu: Add " <>)
                                (cut string-drop-suffix "." <>))
                       (filter (cut string-prefix? "gnu: Add" <>)
                               (string-split (git-output "log" (string-append "--author=" %author) "--format=%s")
                                             #\newline)))))
    (format #t "~{~a~%~}" packages)))
