services: configuration: Allow specifying a custom serializer.
In some cases, rather than globally disabling serialization, it may be more appropriate to disable or otherwise alter the serialization procedure of a specific field. In large module, multiple configurations may also exist that would need to alter the default serialization procedure, which is named after the field type. Being able to specify a per-field serialization procedure provides more flexibility. * gnu/services/configuration.scm (define-configuration): Add an optional pattern variable to allow specifying a custom serialization procedure. (define-configuration-helper) <field-serializer>: Use it to transform the syntax. (empty-serializer): New procedure. (serialize-package): Alias to ‘empty-serializer’. Signed-off-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
This commit is contained in:
		
							parent
							
								
									3f9a12dc08
								
							
						
					
					
						commit
						b3e99d3399
					
				
					 1 changed files with 25 additions and 13 deletions
				
			
		| 
						 | 
					@ -40,12 +40,17 @@
 | 
				
			||||||
            configuration-field-getter
 | 
					            configuration-field-getter
 | 
				
			||||||
            configuration-field-default-value-thunk
 | 
					            configuration-field-default-value-thunk
 | 
				
			||||||
            configuration-field-documentation
 | 
					            configuration-field-documentation
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					            configuration-error?
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					            define-configuration
 | 
				
			||||||
 | 
					
 | 
				
			||||||
            serialize-configuration
 | 
					            serialize-configuration
 | 
				
			||||||
            define-maybe
 | 
					            define-maybe
 | 
				
			||||||
            define-configuration
 | 
					 | 
				
			||||||
            validate-configuration
 | 
					            validate-configuration
 | 
				
			||||||
            generate-documentation
 | 
					            generate-documentation
 | 
				
			||||||
            configuration->documentation
 | 
					            configuration->documentation
 | 
				
			||||||
 | 
					            empty-serializer
 | 
				
			||||||
            serialize-package))
 | 
					            serialize-package))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
;;; Commentary:
 | 
					;;; Commentary:
 | 
				
			||||||
| 
						 | 
					@ -118,7 +123,7 @@ does not have a default value" field kind)))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define (define-configuration-helper serialize? syn)
 | 
					(define (define-configuration-helper serialize? syn)
 | 
				
			||||||
  (syntax-case syn ()
 | 
					  (syntax-case syn ()
 | 
				
			||||||
    ((_ stem (field (field-type def ...) doc) ...)
 | 
					    ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
 | 
				
			||||||
     (with-syntax (((field-getter ...)
 | 
					     (with-syntax (((field-getter ...)
 | 
				
			||||||
                    (map (lambda (field)
 | 
					                    (map (lambda (field)
 | 
				
			||||||
                           (id #'stem #'stem #'- field))
 | 
					                           (id #'stem #'stem #'- field))
 | 
				
			||||||
| 
						 | 
					@ -137,11 +142,15 @@ does not have a default value" field kind)))
 | 
				
			||||||
                            (syntax 'undefined)))
 | 
					                            (syntax 'undefined)))
 | 
				
			||||||
    			 #'((field-type def ...) ...)))
 | 
					    			 #'((field-type def ...) ...)))
 | 
				
			||||||
                   ((field-serializer ...)
 | 
					                   ((field-serializer ...)
 | 
				
			||||||
                    (map (lambda (type)
 | 
					                    (map (lambda (type custom-serializer)
 | 
				
			||||||
    			   (if serialize?
 | 
					                           (and serialize?
 | 
				
			||||||
    			       (id #'stem #'serialize- type)
 | 
					                                (match custom-serializer
 | 
				
			||||||
    			       #f))
 | 
					                                  ((serializer)
 | 
				
			||||||
    			 #'(field-type ...))))
 | 
					                                   serializer)
 | 
				
			||||||
 | 
					                                  (()
 | 
				
			||||||
 | 
					                                  (id #'stem #'serialize- type)))))
 | 
				
			||||||
 | 
					                         #'(field-type ...)
 | 
				
			||||||
 | 
					                         #'((custom-serializer ...) ...))))
 | 
				
			||||||
       #`(begin
 | 
					       #`(begin
 | 
				
			||||||
    	   (define-record-type* #,(id #'stem #'< #'stem #'>)
 | 
					    	   (define-record-type* #,(id #'stem #'< #'stem #'>)
 | 
				
			||||||
    	     #,(id #'stem #'% #'stem)
 | 
					    	     #,(id #'stem #'% #'stem)
 | 
				
			||||||
| 
						 | 
					@ -184,15 +193,18 @@ does not have a default value" field kind)))
 | 
				
			||||||
(define-syntax define-configuration
 | 
					(define-syntax define-configuration
 | 
				
			||||||
  (lambda (s)
 | 
					  (lambda (s)
 | 
				
			||||||
    (syntax-case s (no-serialization)
 | 
					    (syntax-case s (no-serialization)
 | 
				
			||||||
      ((_ stem (field (field-type def ...) doc) ... (no-serialization))
 | 
					      ((_ stem (field (field-type def ...) doc custom-serializer ...) ...
 | 
				
			||||||
 | 
					          (no-serialization))
 | 
				
			||||||
       (define-configuration-helper
 | 
					       (define-configuration-helper
 | 
				
			||||||
         #f #'(_ stem (field (field-type def ...) doc) ...)))
 | 
					         #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
 | 
				
			||||||
      ((_ stem (field (field-type def ...) doc) ...)
 | 
					                 ...)))
 | 
				
			||||||
 | 
					      ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
 | 
				
			||||||
       (define-configuration-helper
 | 
					       (define-configuration-helper
 | 
				
			||||||
         #t #'(_ stem (field (field-type def ...) doc) ...))))))
 | 
					         #t #'(_ stem (field (field-type def ...) doc custom-serializer ...)
 | 
				
			||||||
 | 
					                 ...))))))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define (serialize-package field-name val)
 | 
					(define (empty-serializer field-name val) "")
 | 
				
			||||||
  "")
 | 
					(define serialize-package empty-serializer)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
;; A little helper to make it easier to document all those fields.
 | 
					;; A little helper to make it easier to document all those fields.
 | 
				
			||||||
(define (generate-documentation documentation documentation-name)
 | 
					(define (generate-documentation documentation documentation-name)
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Reference in a new issue