
(define (read-template file)
  (call-with-input-file
      file
      (lambda(port)
        (let loop ((line (read-line port))
                   (result '()))
          (cond
           ((eof-object? line)
            (reverse result))
           ((or (string-prefix? "#" line)
                (string-null? line))
            (loop (read-line port) result))
           (else
            (loop (read-line port) (cons line result))))))))

(define *system-template* "/etc/alterator/default-groups")
(define *installer-template* "/usr/share/install3/default-groups")

(define *old-default-groups* '("cdwriter" "cdrom" "audio" "proc" "radio" "camera" "floppy" "xgrp" "scanner"))

(define *default-groups* (or (with-first-readable
                              (list *system-template* *installer-template*) read-template)
                             *old-default-groups*))

(define (wheel-write name args)
  (let ((allow_su (plistq 'allow_su args)))
    (and (pair? allow_su)
         (woo-try (if (cdr allow_su) "new" "delete")
                  (string-append "/local_groups/wheel/" name)))))

(define (groups-write name args)
  (for-each (lambda(group)
              (woo "new" (string-append "/local_groups/" group) 'type "system");;ignore error
              (woo-new (string-append "/local_groups/" group "/" name)))
	      *default-groups*))

(define (cdr-or-null x)
  (if (pair? x) (cdr x) '()))

(object
 #f
 ;;constraints
 ((constraints self objects options)
  (let ((_ (make-translator "alterator-users" (cond-plistq 'language options '())))
        (is-new (string=? (cond-plistq 'orig_action options "") "new")))
    `(name (required
            ,is-new
            ,@(if is-new
                 `(match ("^[a-z_][a-z0-9_-]*$" ,(_"only small latin letters, digits and '_' allowed")))
                 '())
            label
            ,(_ "Name"))
           shell    (label ,(_ "Shell"))
           home     (label ,(_ "Home directory"))
           allow_su (default #f label ,(_ "Allow switching to superuser"))
           passwd1  (required ,is-new equal passwd2 label ,(_ "Password"))
           passwd2  (required ,is-new label ,(_ "Password (repeat)"))
           gecos    (default "" label ,(_ "Gecos")))))
 ;;list users
 ((list self objects options)
  (let ((wheels (woo-list-names "/local_groups/wheel")))
    (map (lambda(x)
           (let ((name (woo-get-option x 'name "no-name")))
             (cons* name
                    'allow_su (->bool (member name wheels))
                    (cdr x))))
         (woo-list (cons "local_users" objects)))))
 
 ;;read user
 ((read self objects options)
  (and (null? objects) (woo-throw "user name is not defined"))
  (cons*
   'allow_su (->bool (member (car objects) (woo-list-names "/local_groups/wheel")))
   (cdr-or-null (woo-read-first (cons "local_users" objects)))))
 ;;modify user
 ((write self objects options)
  (apply woo-write (cons "local_users" objects) options)
  (or (string=? (car objects) "root") (wheel-write (car objects) options))
  '())
 ;;delete user
 ((delete self objects options)
  (apply woo-delete (cons "local_users" objects) options)
  '())
 ;;create user
 ((new self objects options)
  (let ((name (cond-plistq 'name options "")))
    (apply woo-new (list "local_users" name) options)
    (groups-write name options)
    (wheel-write name options)
  '())))
