services: postgresql: Use "/tmp" host directory.

[jackhill/guix/guix.git] / gnu / services / configuration.scm

diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 9f28aab..90f12a8 100644 (file)
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -1,5 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,6 +22,7 @@
   #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (guix gexp)
+  #:use-module ((guix utils) #:select (source-properties->location))
   #:autoload   (texinfo) (texi-fragment->stexi)
   #:autoload   (texinfo serialize) (stexi->texi)
   #:use-module (ice-9 match)
@@ -28,20 +31,18 @@
   #:use-module (srfi srfi-35)
   #:export (configuration-field
             configuration-field-name
+            configuration-field-type
             configuration-missing-field
             configuration-field-error
+            configuration-field-serializer
+            configuration-field-getter
+            configuration-field-default-value-thunk
+            configuration-field-documentation
             serialize-configuration
+            define-maybe
             define-configuration
             validate-configuration
             generate-documentation
-            serialize-field
-            serialize-string
-            serialize-name
-            serialize-space-separated-string-list
-            space-separated-string-list?
-            serialize-file-name
-            file-name?
-            serialize-boolean
             serialize-package))
 
 ;;; Commentary:
@@ -74,11 +75,12 @@
   (documentation configuration-field-documentation))
 
 (define (serialize-configuration config fields)
-  (for-each (lambda (field)
-              ((configuration-field-serializer field)
-               (configuration-field-name field)
-               ((configuration-field-getter field) config)))
-            fields))
+  #~(string-append
+     #$@(map (lambda (field)
+               ((configuration-field-serializer field)
+                (configuration-field-name field)
+                ((configuration-field-getter field) config)))
+             fields)))
 
 (define (validate-configuration config fields)
   (for-each (lambda (field)
@@ -88,16 +90,27 @@
                    (configuration-field-name field) val))))
             fields))
 
+(define-syntax-rule (id ctx parts ...)
+  "Assemble PARTS into a raw (unhygienic)  identifier."
+  (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
+
+(define-syntax define-maybe
+  (lambda (x)
+    (syntax-case x ()
+      ((_ stem)
+       (with-syntax
+           ((stem?                (id #'stem #'stem #'?))
+            (maybe-stem?          (id #'stem #'maybe- #'stem #'?))
+            (serialize-stem       (id #'stem #'serialize- #'stem))
+            (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem)))
+         #'(begin
+             (define (maybe-stem? val)
+               (or (eq? val 'disabled) (stem? val)))
+             (define (serialize-maybe-stem field-name val)
+               (if (stem? val) (serialize-stem field-name val) ""))))))))
+
 (define-syntax define-configuration
   (lambda (stx)
-    (define (id ctx part . parts)
-      (let ((part (syntax->datum part)))
-        (datum->syntax
-         ctx
-         (match parts
-           (() part)
-           (parts (symbol-append part
-                                 (syntax->datum (apply id ctx parts))))))))
     (syntax-case stx ()
       ((_ stem (field (field-type def) doc) ...)
        (with-syntax (((field-getter ...)
@@ -117,6 +130,10 @@
                  #,(id #'stem #'% #'stem)
                  #,(id #'stem #'make- #'stem)
                  #,(id #'stem #'stem #'?)
+                 (%location #,(id #'stem #'-location)
+                            (default (and=> (current-source-location)
+                                            source-properties->location))
+                            (innate))
                  (field field-getter (default def))
                  ...)
                (define #,(id #'stem #'stem #'-fields)
@@ -135,40 +152,8 @@
                                            #,(id #'stem #'stem #'-fields))
                    conf))))))))
 
-(define (uglify-field-name field-name)
-  (let ((str (symbol->string field-name)))
-    (string-concatenate
-     (map string-titlecase
-          (string-split (if (string-suffix? "?" str)
-                            (substring str 0 (1- (string-length str)))
-                            str)
-                        #\-)))))
-
-(define (serialize-field field-name val)
-  (format #t "~a ~a\n" (uglify-field-name field-name) val))
-
 (define (serialize-package field-name val)
-  #f)
-
-(define (serialize-string field-name val)
-  (serialize-field field-name val))
-
-(define (space-separated-string-list? val)
-  (and (list? val)
-       (and-map (lambda (x)
-                  (and (string? x) (not (string-index x #\space))))
-                val)))
-(define (serialize-space-separated-string-list field-name val)
-  (serialize-field field-name (string-join val " ")))
-
-(define (file-name? val)
-  (and (string? val)
-       (string-prefix? "/" val)))
-(define (serialize-file-name field-name val)
-  (serialize-string field-name val))
-
-(define (serialize-boolean field-name val)
-  (serialize-string field-name (if val "yes" "no")))
+  "")
 
 ;; A little helper to make it easier to document all those fields.
 (define (generate-documentation documentation documentation-name)
@@ -187,7 +172,7 @@
                                (configuration-field-default-value-thunk f)
                                (lambda _ '%invalid))))
                 (define (show-default? val)
-                  (or (string? default) (number? default) (boolean? default)
+                  (or (string? val) (number? val) (boolean? val)
                       (and (symbol? val) (not (eq? val '%invalid)))
                       (and (list? val) (and-map show-default? val))))
                 `(deftypevr (% (category