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