;;; Guix Home Manager.
;;;
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020 Jelle Licht <jlicht@fsfe.org>
;;;
;;; This file is based on work found in GNU Guix.
;;;
;;; 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 (home provenance)
  #:use-module (gnu services)
  #:use-module (guix channels)
  #:use-module (guix describe)
  #:use-module (guix diagnostics)
  #:autoload   (guix openpgp) (openpgp-format-fingerprint)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix profiles)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (home)
  #:autoload   (ice-9 pretty-print) (pretty-print)
  #:export (provenance-home-type
            home-with-provenance))

(define (object->pretty-string obj)
  "Like 'object->string', but using 'pretty-print'."
  (call-with-output-string
    (lambda (port)
      (pretty-print obj port))))

(define (channel->code channel)
  "Return code to build CHANNEL, ready to be dropped in a 'channels.scm'
file."
  ;; Since the 'introduction' field is backward-incompatible, and since it's
  ;; optional when using the "official" 'guix channel, include it if and only
  ;; if we're referring to a different channel.
  (let ((intro (and (not (equal? (list channel) %default-channels))
                    (channel-introduction channel))))
    `(channel (name ',(channel-name channel))
              (url ,(channel-url channel))
              (branch ,(channel-branch channel))
              (commit ,(channel-commit channel))
              ,@(if intro
                    `((introduction
                       (make-channel-introduction
                        ,(channel-introduction-first-signed-commit intro)
                        (openpgp-fingerprint
                         ,(openpgp-format-fingerprint
                           (channel-introduction-first-commit-signer
                            intro))))))
                    '()))))

(define (channel->sexp channel)
  "Return an sexp describing CHANNEL.  The sexp is _not_ code and is meant to
be parsed by tools; it's potentially more future-proof than code."
  ;; TODO: Add CHANNEL's introduction.  Currently we can't do that because
  ;; older 'guix system describe' expect exactly name/url/branch/commit
  ;; without any additional fields.
  `(channel (name ,(channel-name channel))
            (url ,(channel-url channel))
            (branch ,(channel-branch channel))
            (commit ,(channel-commit channel))))

(define (provenance-file channels configuration-file)
  "Return a 'provenance' file describing CHANNELS, a list of channels, and
CONFIGURATION-FILE, which can be either #f or a <local-file> containing the OS
configuration being used."
  (scheme-file "provenance"
               #~(provenance
                  (version 0)
                  (channels #+@(if channels
                                   (map channel->sexp channels)
                                   '()))
                  (configuration-file #+configuration-file))))

(define (provenance-entry config-file)
  "Return system entries describing the operating system provenance: the
channels in use and CONFIG-FILE, if it is true."
  (define profile
    (current-profile))

  (define channels
    (and=> profile profile-channels))

  (let ((config-file (cond ((string? config-file)
                            (local-file config-file "home.scm"))
                           ((not config-file)
                            #f)
                           (else
                            config-file))))
     `((".provenance" ,(provenance-file channels config-file))
              ,@(if channels
                    `((".channels.scm"
                       ,(plain-file "channels.scm"
                                    (object->pretty-string
                                     `(list
                                       ,@(map channel->code channels))))))
                    '())
              ,@(if config-file
                    `((".home.scm" ,config-file))
                    '()))))

(define provenance-home-type
  (home-type
   (name 'provenance)
   (extensions
    (list
     (home-extension
      (target root-home-type)
      (compute provenance-entry))))
   (description "The provenance home type")))

(define (home-configuration-file h)
  "Return the configuration file of H, based on its 'location' field, or #f
if it could not be determined."
  (let ((file (and=> (home-location h)
                     location-file)))
    (and file
         (or (and (string-prefix? "/" file) file)
             (search-path %load-path file)))))

(define* (home-with-provenance h
                               #:optional
                               (configuration-file
                                (home-configuration-file h)))
  "Return a variant of H that stores its own provenance information,
including CONFIGURATION-FILE, if available.  This is achieved by adding an
instance of PROVENANCE-HOME-TYPE to its configurations."
  (home
   (inherit h)
   (configurations (cons (user-home provenance-home-type configuration-file)
                         (home-configurations h)))))