services: Add 'system-provenance' procedure.
* gnu/services.scm (sexp->channel, system-provenance): New procedures. * guix/scripts/system.scm (sexp->channel): Remove. (display-system-generation): Use 'system-provenance' instead of parsing the "provenance" file right here.
This commit is contained in:
		
							parent
							
								
									0a72157271
								
							
						
					
					
						commit
						b91a73a6a4
					
				
					 2 changed files with 46 additions and 35 deletions
				
			
		|  | @ -89,6 +89,7 @@ | ||||||
| 
 | 
 | ||||||
|             system-service-type |             system-service-type | ||||||
|             provenance-service-type |             provenance-service-type | ||||||
|  |             system-provenance | ||||||
|             boot-service-type |             boot-service-type | ||||||
|             cleanup-service-type |             cleanup-service-type | ||||||
|             activation-service-type |             activation-service-type | ||||||
|  | @ -423,6 +424,19 @@ be parsed by tools; it's potentially more future-proof than code." | ||||||
|             (branch ,(channel-branch channel)) |             (branch ,(channel-branch channel)) | ||||||
|             (commit ,(channel-commit channel)))) |             (commit ,(channel-commit channel)))) | ||||||
| 
 | 
 | ||||||
|  | (define (sexp->channel sexp) | ||||||
|  |   "Return the channel corresponding to SEXP, an sexp as found in the | ||||||
|  | \"provenance\" file produced by 'provenance-service-type'." | ||||||
|  |   (match sexp | ||||||
|  |     (('channel ('name name) | ||||||
|  |                ('url url) | ||||||
|  |                ('branch branch) | ||||||
|  |                ('commit commit) | ||||||
|  |                rest ...) | ||||||
|  |      ;; XXX: In the future REST may include a channel introduction. | ||||||
|  |      (channel (name name) (url url) | ||||||
|  |               (branch branch) (commit commit))))) | ||||||
|  | 
 | ||||||
| (define (provenance-file channels config-file) | (define (provenance-file channels config-file) | ||||||
|   "Return a 'provenance' file describing CHANNELS, a list of channels, and |   "Return a 'provenance' file describing CHANNELS, a list of channels, and | ||||||
| CONFIG-FILE, which can be either #f or a <local-file> containing the OS | CONFIG-FILE, which can be either #f or a <local-file> containing the OS | ||||||
|  | @ -474,6 +488,24 @@ channels in use and CONFIG-FILE, if it is true." | ||||||
| itself: the channels used when building the system, and its configuration | itself: the channels used when building the system, and its configuration | ||||||
| file, when available."))) | file, when available."))) | ||||||
| 
 | 
 | ||||||
|  | (define (system-provenance system) | ||||||
|  |   "Given SYSTEM, the file name of a system generation, return two values: the | ||||||
|  | list of channels SYSTEM is built from, and its configuration file.  If that | ||||||
|  | information is missing, return the empty list (for channels) and possibly | ||||||
|  | #false (for the configuration file)." | ||||||
|  |   (catch 'system-error | ||||||
|  |     (lambda () | ||||||
|  |       (match (call-with-input-file (string-append system "/provenance") | ||||||
|  |                read) | ||||||
|  |         (('provenance ('version 0) | ||||||
|  |                       ('channels channels ...) | ||||||
|  |                       ('configuration-file config-file)) | ||||||
|  |          (values (map sexp->channel channels) | ||||||
|  |                  config-file)) | ||||||
|  |         (_ | ||||||
|  |          (values '() #f)))) | ||||||
|  |     (lambda _ | ||||||
|  |       (values '() #f)))) | ||||||
|  |  | ||||||
| ;;; | ;;; | ||||||
| ;;; Cleanup. | ;;; Cleanup. | ||||||
|  |  | ||||||
|  | @ -446,19 +446,6 @@ list of services." | ||||||
| ;;; Generations. | ;;; Generations. | ||||||
| ;;; | ;;; | ||||||
| 
 | 
 | ||||||
| (define (sexp->channel sexp) |  | ||||||
|   "Return the channel corresponding to SEXP, an sexp as found in the |  | ||||||
| \"provenance\" file produced by 'provenance-service-type'." |  | ||||||
|   (match sexp |  | ||||||
|     (('channel ('name name) |  | ||||||
|                ('url url) |  | ||||||
|                ('branch branch) |  | ||||||
|                ('commit commit) |  | ||||||
|                rest ...) |  | ||||||
|      ;; XXX: In the future REST may include a channel introduction. |  | ||||||
|      (channel (name name) (url url) |  | ||||||
|               (branch branch) (commit commit))))) |  | ||||||
| 
 |  | ||||||
| (define* (display-system-generation number | (define* (display-system-generation number | ||||||
|                                     #:optional (profile %system-profile)) |                                     #:optional (profile %system-profile)) | ||||||
|   "Display a summary of system generation NUMBER in a human-readable format." |   "Display a summary of system generation NUMBER in a human-readable format." | ||||||
|  | @ -482,13 +469,10 @@ list of services." | ||||||
|                             (uuid->string root) |                             (uuid->string root) | ||||||
|                             root)) |                             root)) | ||||||
|            (kernel      (boot-parameters-kernel params)) |            (kernel      (boot-parameters-kernel params)) | ||||||
|            (multiboot-modules (boot-parameters-multiboot-modules params)) |            (multiboot-modules (boot-parameters-multiboot-modules params))) | ||||||
|            (provenance  (catch 'system-error |       (define-values (channels config-file) | ||||||
|                           (lambda () |         (system-provenance generation)) | ||||||
|                             (call-with-input-file | 
 | ||||||
|                                 (string-append generation "/provenance") |  | ||||||
|                               read)) |  | ||||||
|                           (const #f)))) |  | ||||||
|       (display-generation profile number) |       (display-generation profile number) | ||||||
|       (format #t (G_ "  file name: ~a~%") generation) |       (format #t (G_ "  file name: ~a~%") generation) | ||||||
|       (format #t (G_ "  canonical file name: ~a~%") (readlink* generation)) |       (format #t (G_ "  canonical file name: ~a~%") (readlink* generation)) | ||||||
|  | @ -518,21 +502,16 @@ list of services." | ||||||
|          (format #t (G_ "  multiboot: ~a~%") |          (format #t (G_ "  multiboot: ~a~%") | ||||||
|                  (string-join modules "\n    ")))) |                  (string-join modules "\n    ")))) | ||||||
| 
 | 
 | ||||||
|       (match provenance |       (unless (null? channels) | ||||||
|         (#f #t) |         ;; TRANSLATORS: Here "channel" is the same terminology as used in | ||||||
|         (('provenance ('version 0) |         ;; "guix describe" and "guix pull --channels". | ||||||
|                       ('channels channels ...) |         (format #t (G_ "  channels:~%")) | ||||||
|                       ('configuration-file config-file)) |         (for-each display-channel channels)) | ||||||
|          (unless (null? channels) |       (when config-file | ||||||
|            ;; TRANSLATORS: Here "channel" is the same terminology as used in |         (format #t (G_ "  configuration file: ~a~%") | ||||||
|            ;; "guix describe" and "guix pull --channels". |                 (if (supports-hyperlinks?) | ||||||
|            (format #t (G_ "  channels:~%")) |                     (file-hyperlink config-file) | ||||||
|            (for-each display-channel (map sexp->channel channels))) |                     config-file)))))) | ||||||
|          (when config-file |  | ||||||
|            (format #t (G_ "  configuration file: ~a~%") |  | ||||||
|                    (if (supports-hyperlinks?) |  | ||||||
|                        (file-hyperlink config-file) |  | ||||||
|                        config-file)))))))) |  | ||||||
| 
 | 
 | ||||||
| (define* (list-generations pattern #:optional (profile %system-profile)) | (define* (list-generations pattern #:optional (profile %system-profile)) | ||||||
|   "Display in a human-readable format all the system generations matching |   "Display in a human-readable format all the system generations matching | ||||||
|  |  | ||||||
		Reference in a new issue