;------------------------------------------------ -*- scheme -*-
(use-modules (srfi srfi-1)
             (srfi srfi-2)              ; and-let*
             (srfi srfi-11)             ; let-values
             (srfi srfi-13)             ; string
             (ice-9 pretty-print)
             (alterator algo)
             (evms))

;---------------------------------------------------------------
(define current-task (make-fluid))
(define current-object (make-fluid))
(define current-operation (make-fluid))
(define current-transaction (make-fluid))

(fluid-set! current-task #f)
(fluid-set! current-object #f)
(fluid-set! current-operation #f)
(fluid-set! current-transaction #f)

;;{{{ evms obj properties

(define (obj->type obj)
  (and (procedure? obj)
       (procedure-property obj 'type)))

(define fsim-alist
  '(("Ext2/3" "131" "142" "253")
    ("XFS" "131" "142" "253")
    ("JFS" "131" "142" "253")
    ("ReiserFS" "131" "142" "253")
    ("SWAPFS" "130")
    ("FAT16" "4" "6" "14" "20" "22")
    ("FAT32" "11" "12" "27" "28")
    ("NTFS" "7" "23")))

(define (fsims)
  (map
   (lambda (name) (evms 'plugin #:name name))
   (map car fsim-alist)))

(define (fsims-by-seg-type type)
  (let ((fsims (filter-map
                (lambda (elt)
                  (and (member type (cdr elt))
                       (evms 'plugin #:name (car elt))))
                fsim-alist)))
    (if (= (length fsims) 1)
        (car fsims)
        fsims)))

(define (evms-fsims-for args)
  (let ((type (assv-ref args 'type-by-number)))
    (if type (fsims-by-seg-type type)
        evms-fsims)))

; FIXME too expensive
(define (obj->name obj)
  (assv-ref (obj) 'name))

(define (obj->obj obj)
  (assv-ref (obj) 'object))

(define (obj->ctype obj)
  (and (compat? obj)
       (obj->type (obj->obj obj))))

(define (obj->dtype obj)
  (or (assv-ref (obj) 'data-type)
      (and (compat? obj)
           (assv-ref ((obj->obj obj)) 'data-type))))

(define (obj->plugin obj)
  (let ((o (obj)))
    (or (assv-ref o 'plugin)
        (assv-ref o 'fsim))))

(define (obj->plugin->name obj)
  (and-let* ((plugin (obj->plugin obj)))
            (obj->name plugin)))

(define (obj->children obj)
  (assv-ref (obj) 'children))

(define (obj->parents obj)
  (assv-ref (obj) 'parents))

(define (obj->producer obj)
  (assv-ref (obj) 'producer))

(define (obj->flags obj)
  (assv-ref (obj) 'flags))

(define (obj->start obj)
  (case (obj->type obj)
    ((segment) (assv-ref (obj) 'start))
    ((volume) (obj->start (obj->obj obj)))
    (else -1)))

(define (obj->size obj)
  (assv-ref (obj) 'size))

;;}}}
;;{{{ evms predicates
(define (enough? obj)                   ; FIXME
  (and-let* ((size (obj->size obj)))
            ;;(format #t "size: ~S ~S\n" (obj->name obj) size)
            (< 16384 size)))

(define (compat? obj)
  (memq 'compatibility (obj->flags obj)))

(define (disk? obj)
  (case (obj->type obj)
    ((volume)
     (eqv? (obj->ctype obj) 'disk))
    ((disk) #t)
    (else #f)))

(define (segment? obj)
  (case (obj->type obj)
    ((volume)
     (eqv? (obj->ctype obj) 'segment))
    ((segment) #t)
    (else #f)))

(define (raid? obj)
  (case (obj->type obj)
    ((volume) (and (compat? obj) (raid? (obj->obj obj))))
    ((region)
     (and (member (obj->plugin->name obj)
                  '("MDRaid0RegMgr" "MDRaid1RegMgr" "MDRaid5RegMgr")) #t))
    (else #f)))

(define (lvm? obj)
  (case (obj->type obj)
    ((volume) (and (compat? obj) (lvm? (obj->obj obj))))
    ((region) (and (string=? (obj->plugin->name obj) "LVM2") #t))
    (else #f)))

(define (evms? obj)
  (and (eqv? (obj->type obj) 'volume)
       (not (compat? obj))))

(define (container? obj)
  (eqv? (obj->type obj) 'container))

;;}}}
;;{{{ tree stuff

(define (objects)
  (append
   (evms 'volume-list)
   (evms 'object-list #:flags '(top) #:data-type 'data)
   (filter enough? (evms 'object-list #:flags '(top) #:data-type 'free))))

(define (expand-obj obj pred)
  (letrec
      ((w (lambda (obj)
            (cond
             ((not obj) '())
             ((pred obj) (list obj))
             (#t (next obj)))))
       (next (lambda (obj)
               ;; (format #t "-------- ~A --------\n" (assv-ref (obj) 'name))
               ;; (pretty-print (obj))
               (case (obj->type obj)
                 ((volume)
                  (w (obj->obj obj)))
                 ((region)
                  (if (assv-ref (obj) 'producer)
                      (w (assv-ref (obj) 'producer))
                      (append-map w (assv-ref (obj) 'children))))
                 ((container)
                  (append-map w (assv-ref (obj) 'consumed)))
                 (else (append-map w (assv-ref (obj) 'children)))))))
    (w obj)))

(define (object-tuple node-pred leaf-pred)
  (map
   (lambda (obj)
     (if (eqv? node-pred raid?)         ; FIXME ugly
         (cons obj (expand-obj obj leaf-pred))
         (append (expand-obj obj leaf-pred) (list obj))))
   (filter node-pred (objects))))

(define (alist-merge = lst)
  (map
   (lambda (elt)
     (cons elt (append-map cdr (filter (lambda (p) (= (car p) elt)) lst))))
   (delete-duplicates (map car lst))))

;; (map obj->type (expand-obj (car (filter lvm? (objects))) container?))
;; (apply map obj->type (object-tuple segment? disk?))
;; (apply map obj->type (object-tuple raid? (lambda (o) (or (segment? o) (disk? o)))))
;; (apply map obj->type (object-tuple lvm? container?))
;; (map obj->type (objects))

;---------------------------------------------------------------
(define tree-hide-empty-branches #f)

(define (name-of thing) (thing 'name '()))
(define (value-of thing) (thing 'value '()))
(define (tree-of thing) (thing 'tree '()))

(define (tree-item name obj)
  (case (obj->type obj)
    ((disk) `(#((,name . "vm/disk.png") ,@(properties-for obj '(size #f #f #f)))))
    ((segment) `(#((,name . ,(if (eqv? (obj->dtype obj) 'free) "vm/unused.png" "vm/partition.png"))
                   ,@(properties-for obj '(size #f #f #f)))))
    ((region container) `(#((,name . ,(if (eqv? (obj->dtype obj) 'free) "vm/unused.png" "vm/partition.png"))
                            ,@(properties-for obj '(size #f #f #f)))))
    ((volume)
     `(#((,name . ,(if (assv-ref (obj) 'mountpoint) "vm/mounted.png" "vm/umounted.png"))
         ,@(properties-for obj (list 'size 'fsim (if evms-prefix 'mntpoint 'mountpoint) 'mntoptions)))))
    (else `(#(,name "" "")))))

(define (size->string size)
  (if (< size 20971520)
      (string-append (number->string (inexact->exact (/ size 2048))) " MB")
      (string-append (number->string (inexact->exact (/ size 2097152))) " GB")))

(define (properties-for obj props)
  (let ((prop-alist (append (obj) (evms 'options obj `(force-mkfs . ,props)))))
    (map
     (lambda (key)
       (let ((value (assv-ref prop-alist key)))
         (cond                        ; FIXME more serialization cases
          ((eqv? key 'fsim)
           (let ((fsim (assv-ref prop-alist 'fsim)))
             (if fsim
                 (cons (obj->name fsim)
                       (if (and (assv-ref prop-alist 'mntpoint)
                                (assv-ref prop-alist 'force-mkfs))
                           "vm/caution.png"
                           "theme:null"))
                 "")))
          ((eqv? key 'mntoptions)
           (or (and (assv-ref prop-alist 'mntpoint)
                    (assv-ref prop-alist 'mntoptions))
               ""))
          ((eqv? key 'size)
           (size->string (or
                          ;; new fssize after expanding will be shown
                          ;; only after commit. that sucks, so, volsize.
                          ;;(and-let* ((sz (assv-ref prop-alist 'fssize)))
                          ;;          (and (< 0 sz) sz))
                          (assv-ref prop-alist 'volsize)
                          (assv-ref prop-alist 'size))))
          ((eqv? key 'free)
           (if (eqv? (obj->type obj) 'disk)
               (size->string (apply + (map obj->size (filter pr-disk-free-slot? (obj->parents obj)))))
               ""))
          ((procedure? value)
           (obj->name value))
          ((not value) "")
          (#t (sure-string value)))))
     props)))

(define (create-node thing)
  (apply create-node-proc (normalize thing)))

(define (create-node-proc name first . rest) ; one or more objects of same type
  (let ((value (if (null? rest) first (cons first rest))))
    (lambda (command junk . args)
      (case command
        ((name) name)
        ((value) value)
        ((tree) (tree-item name value))
        ((task) (apply tasks-compound 'new '() value '(start . #t) args))
        ((ops) `(quote ,@(operations-for first)))
        ((props) `(quote ,@(properties-for first (assv-ref args 'props))))))))

(define (mangle-name obj)
  (string-join (string-split (obj->name obj) #\/) "|" 'infix))

(define (truncate-name obj)
  (car (reverse (string-split (obj->name obj) #\|))))

(define (normalize thing)
  (cond ((string? thing)
         (list thing (lambda x `((name . ,thing)))))
        ((eqv? (obj->type thing) 'plugin)
         (mangle-name thing))            ; for Ext2/3
        ((memq (obj->type thing) '(disk segment region feature container volume))
         (list (case (obj->dtype thing)
                 ((free)
                  (string-append
                   "<unused" (string-filter (obj->name thing) char-numeric?) ">"))
                 (else (truncate-name thing)))
               thing))
        (#t thing)))

(define (sort-nodes parent-obj nodes)
  (cond
   ((eqv? (obj->type parent-obj) 'disk)
    (sort nodes (lambda (a b)
                  (< (obj->start (value-of a)) (obj->start (value-of b))))))
   (#t (sort nodes (lambda (a b) (string< (name-of a) (name-of b)))))))

(define (create-compound node . nodes)
  (let ((contents (map (lambda (x) (cons (name-of x) x)) nodes)))
    (lambda (command path . args)
      (if (null? path)
          (case command
            ((tree)
             (let ((parent (tree-item (name-of node) (value-of node)))
                   (children (append-map tree-of (sort-nodes (value-of node) nodes))))
               (if (null? children) (if tree-hide-empty-branches '() parent)
                   (append parent `(,children)))))
            ((list)
             (map list (map car contents)))
            (else (apply node command '() args)))
          (apply (assoc-ref contents (car path))
                 command (cdr path) args)))))

(define (apply-compound arglist)
  (apply create-compound (map create-node arglist)))

(define (create-subtree nodespec . limits)
  (apply create-compound (create-node nodespec)
         (map apply-compound
              (alist-merge
               eqv?
               (apply append-map object-tuple (apply zip limits))))))

(define (create-disk-subtree)
  (create-subtree
   `("Disks"
     ,(evms 'plugin #:name "DosSegMgr"))
   `(,segment? ,disk?) `(,disk? ,(lambda (x) #f))))
; (pretty-print ((create-disk-subtree) 'tree '()))
; (pretty-print ((create-disk-subtree) 'read '()))

(define (create-raid-subtree)
  (create-subtree
   `("RAID"
     ,(evms 'plugin #:name "MDRaid1RegMgr")
     ,(evms 'plugin #:name "MDRaid0RegMgr")
     ,(evms 'plugin #:name "MDRaid5RegMgr"))
   ;;`(,raid? ,(lambda (x) (or (segment? x) (disk? x))))
   `(,raid? ,(lambda (x) #f))))
; (pretty-print ((create-raid-subtree) 'tree '()))
; (pretty-print ((create-raid-subtree) 'read '()))
; (pretty-print ((create-raid-subtree) 'task '() '(operation . create)))

(define (create-lvm-subtree)
  (create-subtree
   `("LVM"
     ,(evms 'plugin #:name "LVM2"))
   `(,lvm? ,container?)))
; (pretty-print ((create-lvm-subtree) 'tree '()))
; (pretty-print ((create-lvm-subtree) 'read '()))
; (pretty-print ((create-lvm-subtree) 'task '() '(operation . create-container)))

;;}}}
;;{{{ task stuff

(define (create? op plugin)
  (and-let*
   ((task (false-if-exception (evms op plugin)))
    (acceptable (false-if-exception (not (null? (task 'acceptable))))))
   (task 'destroy)
   #t))

(define (create-segment? obj)
  (and-let*
   ((task (false-if-exception (evms 'create (evms 'plugin #:name "DosSegMgr"))))
    (acceptable (false-if-exception (task 'acceptable))))
   (task 'destroy)
   (case (obj->type obj)
     ((disk) (and (any (lambda (x) (memv x acceptable)) (obj->parents obj)) #t))
     (else (and (memv obj acceptable) #t)))))

(define (mkfs? obj)
  (any (lambda (fsim) (false-if-exception (obj 'mkfs? fsim)))
       evms-fsims))

(define (setmntent? vol)
  (assv-ref (vol) 'fsim))

(define (operations-for thing)
  (case (obj->type thing)
    ((plugin)
     (let ((name (obj->name thing)))
       (cond
        ((equal? name "MDRaid1RegMgr")
         `((op-raid-create . ,(create? 'create thing))))
        ((equal? name "LVM2")
         `((op-vg-create . ,(create? 'create-container thing))))
        (#t '()))))
    ((disk)
     (if (null? (obj->parents thing))
         ;; no segmgr yet, we can assign segmgr, or use whole disk
         `((op-pt-create . ,(thing 'assign?))
           (op-volume-create . ,(thing 'create-compat?)))
         ;; OR, create segment or remove segmgr
         `((op-segment-create . ,(create-segment? thing))
           (op-pt-destroy . ,(thing 'unassign?)))))
    ((segment)
     ;; allow create segment on explicitly selected freespace
     (case (obj->dtype thing)
       ((free)
        `((op-segment-create . ,(create-segment? thing))))
       (else
        `((op-segment-expand . ,(thing 'expand?))
          (op-segment-shrink . ,(thing 'shrink?))
          (op-segment-destroy . ,(thing 'destroy?))
          (op-volume-create . ,(thing 'create-compat?))))))
    ((region)
     (let ((plugin (obj->plugin->name thing)))
       (cond
        ((member plugin '("MDRaid0RegMgr" "MDRaid1RegMgr" "MDRaid5RegMgr"))
         `((op-volume-create . ,(thing 'create-compat?))
           (op-raid-destroy . ,(thing 'destroy?))))
        ((equal? plugin "LVM2")
         `((op-lv-create . #t)          ; FIXME pred
           (op-volume-create . ,(thing 'create-compat?))
           (op-lv-expand . ,(thing 'expand?))
           (op-lv-shrink . ,(thing 'shrink?))
           (op-lv-destroy . ,(thing 'destroy?))))
        (#t '()))))
    ((container)
     (let ((plugin (obj->plugin->name thing)))
       (cond
        ((equal? plugin "LVM2")
         `((op-vg-expand . ,(thing 'expand?))
           (op-vg-shrink . ,(thing 'shrink?))
           (op-vg-destroy . (thing 'delete?)))) ; FIXME check for lvs here too
        (#t '()))))
    ((volume)
     `((op-volume-mkfs . ,(mkfs? thing))
       (op-volume-fsck . ,(thing 'fsck?))
       (op-volume-unmkfs . ,(thing 'unmkfs?))
       (op-volume-expand . ,(thing 'expand?))
       (op-volume-shrink . ,(thing 'shrink?))
       (op-volume-mount . ,(thing 'mount?))
       (op-volume-umount . ,(thing 'umount?))
       (op-volume-remount . ,(thing 'remount?))
       (op-volume-setmntent . ,(setmntent? thing))
       (op-volume-destroy . ,(thing 'destroy?))))
    (else '())))

(define task-id
  (let ((counter 0))
    (lambda () (set! counter (1+ counter)) counter)))

(define (task-path task)
  (string-append "/evms/tasks/" (name-of task)))

(define (create-task obj . args)
  (format #t "CREATE-TASK: ~S ~S\n" obj args)
  (let ((start (assv-ref args 'start))
        (verbose (assv-ref args 'verbose))
        (op (assv-ref args 'operation))
        (args (alist-delete 'start (alist-delete 'verbose (alist-delete 'operation args)))))
    (let-values (((op obj actual-op actual-obj next-op next-obj initially-verbose) (mangle-task-args op obj args)))
      (cond
       ((procedure? actual-obj)         ; will return ordinary task
        (create-task-node op obj
                          next-op next-obj
                          actual-op actual-obj
                          (if start initially-verbose verbose)
                          args))
       ((list? actual-obj)              ; will return list of tasks
        (let* ((verbose (if start initially-verbose verbose))
               (tasks (filter-map (lambda (object)
                                    (create-task-node op obj
                                                      next-op next-obj
                                                      actual-op object
                                                      verbose
                                                      args))
                                  actual-obj)))
          (if (null? tasks) #f tasks)))))))

(define (mangle-task-args op obj args)
  (case op
    ((op-pt-create)
     ;; (values op obj 'assign (evms 'plugin #:name "DosSegMgr") 'op-segment-create obj #t))
     ;; short-circuit to op-segment-create
     (let ((task (evms 'assign (evms 'plugin #:name "DosSegMgr"))))
       (set! (task 'selected) (list obj))
       (task 'apply))
     (let ((obj (cadr (assv-ref (obj) 'parents))))  ; second seg maps to freespace
       (format #t "OP-PT-CREATE: ~S\n" (obj))
       (values 'op-segment-create obj 'create (evms 'plugin #:name "DosSegMgr") 'op-volume-create #f #t)))
    ((op-pt-destroy)
     (values op obj 'unassign obj #f #f #t))
    ((op-segment-create)
     (values op obj 'create (evms 'plugin #:name "DosSegMgr") 'op-volume-create #f #t))
    ((op-raid-create)
     (values op obj 'create obj 'op-volume-create #f #t))
    ((op-vg-create)
     (values op obj 'create-container obj 'op-lv-create #f #t))
    ((op-lv-create)
     (values op obj 'create (obj->plugin obj) 'op-volume-create #f #t))
    ((op-segment-expand op-vg-expand op-lv-expand)
     (values op obj 'expand obj #f #f #t))
    ((op-segment-shrink op-vg-shrink op-lv-shrink)
     (values op obj 'shrink obj #f #f #t))
    ((op-volume-create)
     (values op obj 'create-compat obj 'op-volume-mkfs #f #t))
    ((op-volume-expand)
     (values op obj 'expand (obj->obj obj) #f #f #t))
    ((op-volume-shrink)
     (values op obj 'shrink (obj->obj obj) #f #f #t))
    ((op-volume-mkfs)
     (if evms-prefix
         (values op obj 'mkfs (evms-fsims-for args) 'op-volume-setmntent obj #t)
         (values op obj 'mkfs (evms-fsims-for args) #f obj #t)))
    ((op-volume-fsck)
     (values op obj 'fsck obj #f #f #t))
    ((op-volume-unmkfs)
     (values op obj 'unmkfs obj #f #f #t))
    ((op-volume-mount)
     (values op obj 'mount obj #f #f #t))
    ((op-volume-setmntent)
     (values op obj 'setmntent obj #f #f #t))
    ((op-volume-umount)
     (values op obj 'umount obj #f #f #t))
    ((op-volume-remount)
     (values op obj 'remount obj #f #f #t))
    ((op-segment-delete op-vg-delete op-lv-delete op-raid-delete op-volume-delete)
     (values op obj 'delete obj #f #f #t))
    ((op-segment-destroy op-vg-destroy op-lv-destroy op-raid-destroy op-volume-destroy)
     (values op obj 'destroy obj #f #f #t))))

(define (select-one-object task obj)
  (set! (task 'selected) (list obj)) #t)

(define (select-one-acceptable task obj objs)
  (and (memv obj objs)
       (select-one-object task obj)))

(define (select-acceptable task objs)
  (and (not (null? objs))
       (false-if-exception (set! (task 'selected) objs))
       ;; avoid selection from one object
       (or (null? (cdr objs)) '())))

(define (select-task-objects task op obj)
  ;; return #t if no further selection required, '() otherwise
  ;; #f cancels task
  (and-let*
   ((acceptable (false-if-exception (task 'acceptable))))
   (case op
     ((op-pt-create) (select-one-object task obj))
     ((op-segment-create)
      (case (obj->type obj)
        ((disk)
         ;; select freespace on given disk
         (select-acceptable
          task (filter (lambda(o) (memv obj (obj->children o))) acceptable)))
        ((segment) (select-one-object task obj))))
     ((op-segment-expand op-segment-shrink)
      (select-acceptable task acceptable))
     ((op-vg-create op-vg-expand op-raid-create)
      (select-acceptable task acceptable))
     ((op-lv-create)
      (case (obj->type obj)
        ((container)
         ;; select freespace on given container
         (select-acceptable
          task (filter (lambda(o) (eqv? (obj->producer o) obj)) acceptable)))
        ;; FIXME noop right now, allow op on freespace probably
        (else (set! (task 'selected) acceptable) #t)))
     ((op-volume-create) (select-one-object task obj))
     ((op-volume-mkfs op-volume-fsck op-volume-mount op-volume-umount op-volume-unmkfs op-volume-setmntent)
      (select-one-acceptable task obj acceptable))
     ((op-pt-destroy op-segment-destroy op-vg-destroy op-lv-destroy op-raid-destroy op-volume-destroy)
      (select-one-object task obj))
     ((op-volume-expand op-volume-shrink)
      (if (segment? obj)
          (select-acceptable task acceptable)
          '()))
     (else ; free for all: op-vg-shrink
      '()))))

(define (filter-option:custom option)
  (and option
       (case (fluid-ref current-operation)
         ((op-pt-create)
          ;; no OS/2 selection, we're linux
          #f)
         ((op-segment-create)
          ;; TypeByName should be enough
          (cond ((equal? (assv-ref option 'name) "TypeByNumber")
                 (set-task-option! 'type-by-number (assv-ref option 'value)) #f)
                ((equal? (assv-ref option 'name) "Bootable") #f)
                (#t option)))
         ((op-volume-mkfs)
          (cond ((equal? (assv-ref option 'name) "version") #f)
                (#t option)))
         (else option))))

(define (filter-option:active option)
  (and option
       (if (memq 'inactive (assv-ref option 'flags)) #f
           option)))

(define (mangle-option:custom option)
  (cond
   ((member (assv-ref option 'name) '("Size" "Offset"))
    (assv-set! option 'flags `(important . ,(assv-ref option 'flags))))
   ((equal? (assv-ref option 'name) "TypeByName")
    (let ((option
           (assv-set! option 'constraint
                      (reverse (cons "Linux RAID"
                                     (cdr (reverse (delete "HPFS" (assv-ref option 'constraint)))))))))
      (cond ((equal? (task-option 'type-by-number) "253")
             (assv-set!
              (assv-set! option 'value "Linux RAID")
              'flags `(lasthop . ,(assv-ref option 'flags))))
            ((equal? (assv-ref option 'value) "Linux LVM")
             (assv-set! option 'flags `(lasthop . ,(assv-ref option 'flags))))
            (#t option))))
   (#t option)))

(define (mangle-option:to-value option)
  (acons 'to-value
         (case (assv-ref option 'widget)
           ((slider)
            (let ((step (caddr (assv-ref option 'constraint))))
              (lambda (v) (inexact->exact (* step v)))))
           ((combobox combobox/ex edit)
            (case (assv-ref option 'type)
              ((number) string->number)                           ; #f on ""
              ((string) (lambda (s) (if (string-null? s) #f s)))  ; #f on ""
              (else values)))
           (else values))
         option))

(define (scale-generic min max step)
  (values
   #f
   (lambda(v)
     (number->string (* step v)))
   (lambda(s)
     (and-let*
      ((v (false-if-exception (inexact->exact (/ (string->number s) step)))))
      (and (<= min v max) v)))))

(define (scale-megabytes min max step)
  (values
   "MB"
   (lambda(v)
     (number->string (inexact->exact (* step v))))
   (lambda(s)
     (and-let*
      ((v (false-if-exception (inexact->exact (/ (string->number s) step)))))
      (and (<= min v max) v)))))

(define (scale-sectors-staged min max step)
  ;; assume bytes/sector eqv 512, vg reports all-zero geom
  (let* ((gbs (< 20971520 (* step (- max min))))  ; ~10G
         (units (if gbs "GB" "MB"))
         (scale (if gbs (/ step 2097152) (/ step 2048)))
         (rscale (if gbs (/ 2097152 step) (/ 2048 step))))
    (values
     units
     (lambda(v)
       (number->string (inexact->exact (* v scale))))
     (lambda(s)
       (and-let*
        ((v (false-if-exception (inexact->exact (* (string->number s) rscale)))))
        (and (<= min v max) v))))))

(define (scale-sectors min max step)
  ;; assume bytes/sector eqv 512, vg reports all-zero geom
  (let* ((scale (/ step 2048))
         (rscale (/ 2048 step)))
    (values
     "MB"
     (lambda(v)
       (number->string (inexact->exact (* v scale))))
     (lambda(s)
       (and-let*
        ((v (false-if-exception (inexact->exact (* (string->number s) rscale)))))
        (and (<= min v max) v))))))

(define (mangle-option:scale option)
  (if (eq? 'slider (assv-ref option 'widget))
      (let ((constraint (assv-ref option 'constraint)))
        (cond ((apply = 0 constraint)
               (acons 'scale (values "MB" (lambda(v) "0") (lambda(s) 0)) option))
              ((eqv? 'sector (assv-ref option 'unit))
               (acons 'scale (apply scale-sectors constraint) option))
              ((eqv? 'mb (assv-ref option 'unit))
               (acons 'scale (apply scale-megabytes constraint) option))
              (#t (acons 'scale (apply scale-generic constraint) option))))
      option))

(define (mangle-option:value option)
  (let ((value (assv-ref option 'value)))
    (case (assv-ref option 'widget)
      ((edit)
       (assv-set! option 'value
                  (if (number? value)
                      (number->string value)
                      (or value ""))))
      ((slider)
       (assv-set! option 'value
                  (let ((vstep (caddr (assv-ref option 'constraint))))
                    (if (= 0 vstep) value
                        (inexact->exact (/ value vstep))))))
      (else option))))

(define (mangle-option:pixmap option)
  (acons 'pixmap
         (if (memq 'not-required (assv-ref option 'flags))
             ""
             "reqfield.gif")
         option))

(define (mangle-option:widget option)
  (cond
   ((eq? 'boolean (assv-ref option 'type))
    (acons 'widget 'checkbox option))
   ((eq? 'list (assv-ref option 'constraint-type))
    (acons 'widget
           (if (memq 'value-is-list (assv-ref option 'flags))
               'checklist
               (if (memq 'expandable (assv-ref option 'flags))
                   'combobox/ex
                   'combobox))
           option))
   ((eq? 'range (assv-ref option 'constraint-type))
    ;; convert range to list, when appropriate
    ;; or normalize min/max vs step
    (let ((vmin (car (assv-ref option 'constraint)))
          (vmax (cadr (assv-ref option 'constraint)))
          (vstep (caddr (assv-ref option 'constraint))))
      (acons 'widget 'slider
             (assv-set! option 'constraint
                        (list (if (= vstep 0) vmin (inexact->exact (/ vmin vstep)))
                              (if (= vstep 0) vmax (inexact->exact (/ vmax vstep)))
                              vstep)))))
   (#t (acons 'widget 'edit option))))

(define (mangle-option:flags option)
  (let ((flags (assv-ref option 'flags)))
    (acons 'ready (or (and (memq 'not-required flags) #t)
                      (not (memq 'no-initial-value flags)))
           option)))

(define (mangle-option:constraint option)
  (let ((constraint (assv-ref option 'constraint)))
    (acons 'type (car constraint)
           (acons 'constraint-type (cadr constraint)
                  (acons 'constraint (caddr constraint)
                         (alist-delete 'constraint option))))))

(define (mangle-option:name option)
  (acons 'name (car option) (cdr option)))

(define (probe-option option)
  (format #t "PROBE  ---------------------------------------------------------\n~S\n" option)
  option)

(define (mangle-option option)
  (filter-option:custom
   (filter-option:active
    (mangle-option:custom
     (mangle-option:to-value
      (mangle-option:scale
       (mangle-option:value
        (mangle-option:pixmap
         (mangle-option:widget
          (mangle-option:flags
           (mangle-option:constraint
            (mangle-option:name option))))))))))))

(define (set-task-option! name value)
  (and-let*
   ((task (fluid-ref current-task)))
   (set-procedure-property!
    task
    'context
    (assv-set! (procedure-property task 'context)
               name value))))

(define (task-option name)
  (and-let*
   ((task (fluid-ref current-task))
    (options (procedure-property task 'context)))
   (assv-ref options name)))

(define (mangle-task-options op obj task)
  (with-fluids
   ((current-operation op)
    (current-object obj)
    (current-task task))
   (sort
    (filter-map mangle-option (task 'options))
    option-importance<)))

(define (option-importance< opta optb)
  (and
   (or (memq 'important (assv-ref opta 'flags))
       (memq 'not-required (assv-ref optb 'flags))) #t))

(define (create-task-node op obj next-op next-obj mangled-op mangled-obj verbose args)
  (format #t "CREATE-TASK-NODE: ~S ~S ~S ~S ~S\n" op mangled-op (obj->name mangled-obj) verbose args)
  (and-let*
   ((task (false-if-exception (apply evms mangled-op mangled-obj args)))
    (selection (select-task-objects task op obj))
    (id (number->string (task-id))))
   (lambda (command junk . args)
     (case command
       ((name) id)
       ((value) task)
       ((verbose) `(quote ,verbose))
       ((action) (list op next-op))
       ((tree) (list id))
       ((read) `(title ,(assv-ref (mangled-obj) 'long-name) next-op ,next-op))
       ((objects) (if (null? selection) `(quote ,@(map obj->name (task 'acceptable))) '()))
       ((options) `(quote ,@(mangle-task-options op obj task)))
       ((set-objects!)
        (format #t "SET-OBJECTS! ~S\n" (assv-ref args 'objects))
        (let-values
            (((effect declined-objects)
              (set! (task 'selected)
                    (filter (lambda (obj) (member (obj->name obj) (assv-ref args 'objects)))
                            (task 'acceptable)))))
          (format #t "DECLINED: ~S\n" (map obj->name declined-objects))
          effect))
       ((set-options!)           ; yeah, our set has return value :)
        (let ((margs (if (equal? "Linux RAID" (assoc-ref args "TypeByName"))
                         (acons "TypeByNumber" 253 (alist-delete "TypeByName" args))
                         args)))
          (format #t "SET-OPTIONS! ~S\n" margs)
          (catch 'swig-system-error
            (lambda () `(quote #t ,@(set! (task 'options) margs)))
            (lambda (key funcname msg . args) `(quote #f ,msg)))))
       ((apply)
        (format #t "TASK-APPLY: ~S\n" args)
        (let ((verbose (assv-ref args 'verbose))
              (next-hop (assv-ref args 'next-hop)))
          (catch 'swig-system-error ; FIXME return paths to newly created objs
            (lambda ()
              (let ((context (procedure-property task 'context))
                    (objs (task 'apply)))
                (format #t "TASK-NEXT(~S): ~S ~S ~S\n" next-hop next-op next-obj objs)
                (let ((next-obj (or next-obj (and (not (null? objs)) (car objs)))))
                  (if (and next-hop next-op next-obj)
                      (apply tasks-compound 'new '() next-obj `(verbose . ,verbose) `(operation . ,next-op) (or context '()))
                      `(quote #t)))))
            (lambda (key funcname msg . args) `(quote #f ,msg)))))
       ((destroy)
        (catch 'swig-system-error
          (lambda () (task 'destroy) `(quote #t))
          (lambda (key funcname msg . args) `(quote #f ,msg))))))))

(define tasks-compound
  (let* ((tasks '())
         (task-add! (lambda (t) (set! tasks (acons (name-of t) t tasks))))
         (task-remove! (lambda (n) (set! tasks (alist-delete! n tasks))))
         (node (create-node "tasks")))
    (lambda (command path . args)
      (if (null? path)
          (case command
            ((new)
             (and-let*
              ((result (apply create-task args)))
              (cond
               ((procedure? result)     ; will return ordinary task
                (task-add! result)
                `(quote task ,@(result 'action '()) ,(task-path result)))
               ((list? result)          ; will return list of tasks
                (for-each task-add! result)
                `(quote choice ,@((car result) 'action '()) ,@(map task-path result))))))
            ((delete) '())
            ((tree)
             (let ((children (append-map tree-of (map cdr tasks))))
               (if (null? children) (list (name-of node))  ;;'()
                   (list (name-of node) children))))
            ((list)
             (map list (map car tasks)))
            (else (apply node command '() args)))
          (apply (assoc-ref tasks (car path))
                 command (cdr path) args)))))

;;}}}
;;{{{ profiles
(define vm-profile-custom
  '(none (title . "Custom") (action . none)))

(define vm-profile-file "/var/cache/alterator/vm-profile.scm")

(define (create-profiles)
  (let ((ext (or (and (access? vm-profile-file R_OK)
                      (map create-profile
                           (with-input-from-file vm-profile-file read)))
                 '())))
    (append ext (list (create-profile vm-profile-custom)))))

(define (profile-size profile)
  (if (eqv? (assv-ref  profile 'action) 'none) ""
      (size->string
       (apply + (map pr-min-size
                     (map (lambda (v) (assv-ref v 'size))
                          (map cdr (assv-ref profile 'actiondata))))))))

(define (create-profile profile)
  ;;(format #t "CREATE-PROFILE: ~S\n" profile)
  (let ((name (symbol->string (car profile)))
        (profile (cdr profile)))
    (lambda (command junk . args)
      ;; (format #t "COMMAND: ~S REST: ~S\n" command args)
      (case command
        ((name) name)
        ((value) (lambda () profile))
        ((tree) (list name))
        ((title) `(quote ,(assv-ref profile 'title)))
        ((size) `(quote ,(profile-size profile)))
        ((apply)
         (format #t "APPLYING PROFILE: ~S ~S\n" name args)
         (and (assv-ref args 'clearall) (pr-clearall))
         (with-fluids
          ((pr-exclude (assv-ref args 'exclude)))
          (case (assv-ref profile 'action)
            ((trivial) (pr-trivial (assv-ref args 'commit)
                                   (assv-ref profile 'actiondata)))
            ((none) '(quote nexthop /vm/table))
            (else '(quote #f "Unknown profile type")))))))))

;---------------------------------------------------------------
(define pr-exclude (make-fluid))

(define (pr-clearall)
  (let ((kill (lambda (x) (false-if-exception (x 'destroy)))))
    (let ((killall (lambda (x) (for-each kill (apply evms x)))))
      (for-each killall
                '((volume-list)
                  (object-list #:type region #:data-type data)
                  (container-list)
                  (object-list #:type region #:data-type data)
                  (object-list #:type segment #:data-type data)))))
  (for-each
   (lambda (x) (and (x 'unassign?) (x 'unassign)))
   (evms 'object-list #:type 'disk)))

(define (pr-trivial commit data)
  (format #t "TRIVIAL: commit: ~S data: ~S\n" commit data)
  (if (every pr-place data)
      (if commit '(quote #t)
          '(quote nexthop /vm/table))
      '(quote #f "")))

(define (pr-place args)
  (let ((name (car args))
        (args (cdr args)))
    (format #t "PLACE: ~S ~S\n" name args)
    (let* ((fsim (assv-ref args 'fsim))
           (type (if (equal? fsim "SWAPFS") 130 131)))
      (pr-make-volume
       name fsim
       (pr-place-one type (assv-ref args 'size)
                     (assv-ref args 'methods))))))

(define (pr-make-volume name fsim object)
  (and object
       (format #t "MAKE-VOLUME: ~S ~S ~S\n" name fsim (obj->name (car object)))
       (and-let*
        ((vol (car ((evms 'create-compat (car object)) 'apply))))
        (format #t "MAKE-VOLUME: volume: ~S\n" (obj->name vol))
        (let ((task (evms 'mkfs (evms 'plugin #:name fsim))))
          (set! (task 'selected) (list vol))
          (task 'apply))
        (format #t "MAKE-VOLUME: fsim: ~S\n" (obj->plugin->name vol))
        (or (equal? fsim "SWAPFS")      ; do not assign swap mntpoit, will be done later
            (let ((task (evms 'setmntent vol)))
              (set! (task 'options) `((mntpoint . ,name)))
              (task 'apply)))
        (format #t "MAKE-VOLUME: finished\n")
        vol)))

(define (pr-place-one type size methods)
  (format #t "PLACE-ONE: ~S ~S ~S\n" type size methods)
  (if (null? methods) #f
      (or (case (car methods)
            ((plain) (pr-place-plain type size))
            ((raid+lvm) (format #t "raid+lvm\n") #f)
            ((raid) (format #t "raid\n") #f)
            ((lvm) (format #t "lvm\n") #f)
            (else (format #t "wtf?\n") #f))
          (pr-place-one type size (cdr methods)))))

(define (pr-place-size< placea placeb)
  ;; TODO complex criteria
  (let-values (((obja junka junktooa) placea)
               ((objb junkb junktoob) placeb))
    (< (obj->size obja) (obj->size objb))))

(define (pr-place-plain type size)
  (let loop ((places (sort (append-map (lambda(dsk) (pr-disk->freespace dsk size))
                                       (pr-candidates)) pr-place-size<)))
    ;;(format #t "PLACE-PLAIN: ~S\n" (map obj->name places))
    (and (not (null? places))
         (or (false-if-exception
              (let-values (((seg splittable primary) (car places)))
                (let ((task (evms 'create (evms 'plugin #:name "DosSegMgr"))))
                  (format #t "MAKE-PARTITION: selected: ~S acceptable: ~S\n"
                          (obj->name seg) (map obj->name (task 'acceptable)))
                  (set! (task 'selected) (list seg))
                  (and (number? (pr-max-size size))
                       (set! (task 'options) `(("Size" . ,(pr-max-size size)))))
                  (set! (task 'options) `(("Primary" . ,primary) ("TypeByNumber" . ,type)))
                  ;; (pretty-print (task 'options))
                  (task 'apply))))
             (loop (cdr places))))))

(define (pr-disk->freespace disk size)
  (let ((parents (obj->parents disk)))
    (format #t "DISK->FREESPACE: ~S parents: ~S\n" (obj->name disk) (map obj->name parents))
    (cond  ((null? parents)        ; no partition table yet
            (format #t "DISK->FREESPACE: no pt, creating\n")
            (pr-create-pt disk)
            (pr-disk->freespace disk size))
           ((not (pr-disk-dos? (car parents)))
            (format #t "DISK->FREESPACE: not a dos pt, skipping\n")
            '())
           (#t
            (let ((numslots (apply pr-numslots (map obj->name (cons disk (filter pr-disk-data-slot? parents))))))
              (format #t "DISK->FREESPACE: SLOTS: ~S\n" numslots)
              (fold
               (lambda (seg accum)
                 (if (and (pr-disk-free-slot? seg) (pr-size< size (obj->size seg)))
                     (let-values (((before after) (partition (lambda(segn) (pr-seg< segn seg)) parents)))
                       (format #t "DISK->FREESPACE: ~S X ~S\n"
                               (map obj->name before) (map obj->name (cdr after)))
                       (cond ((< 3 numslots)
                              ;; empty disk: splittable, primary
                              (cons (values seg #t #t) accum))
                             ((not (null? (filter pr-disk-meta-slot? after)))
                              ;; freespace, then ext'd: maybe-splittable, primary
                              (cons (values seg (< 2 numslots) #t) accum))
                             ((< 1 (length (filter pr-disk-meta-slot? before)))
                              ;; ext'd, then free
                              (if (pr-disk-meta-slot? (cadr (reverse before)))
                                  ;; no pri after ext'd: splittable, logical
                                  (cons (values seg #t #f) accum)
                                  ;; pri after ext'd: maybe-splittable, primary
                                  (cons (values seg (< 2 numslots) #f) accum)))
                             (#t
                              ;; primary only
                              (cons (values seg (< 2 numslots) (< 2 numslots)) accum))))
                     accum))
               '() parents))))))

(define (pr-candidates)
  (filter pr-wholedisk?
          (filter pr-candidate?
                  (evms 'object-list #:type 'disk))))

(define (pr-candidate? disk)
  (not (member (obj->name disk)
               (fluid-ref pr-exclude))))

(define (pr-wholedisk? disk)
  (and (pr-purge-fake-volume disk) disk))

(define (pr-purge-fake-volume disk)
  (not (and-let*
        ((vol (assv-ref (disk) 'volume)))
        (or (assv-ref (vol) 'fsim)
            (begin (vol 'delete) #f)))))

(define (pr-disk-dos? obj)
  (string=? "DosSegMgr" (obj->plugin->name obj)))

(define (pr-disk-data-slot? obj)
  (eqv? 'data (obj->dtype obj)))

(define (pr-disk-meta-slot? obj)
  (eqv? 'meta (obj->dtype obj)))

(define (pr-disk-free-slot? obj)
  (eqv? 'free (obj->dtype obj)))

(define (pr-numslots diskname . segnames)
  (format #t "PR-NUMSLOTS: ~S ~S\n" diskname segnames)
  (let ((pslots (map (lambda(s) (string-append diskname s)) '("1" "2" "3" "4"))))
    (let-values (((pri log) (partition (lambda(x) (member x pslots)) segnames)))
      (- 4 (length pri) (if (null? log) 0 1)))))

(define (pr-create-pt disk)
  (let ((task (evms 'assign (evms 'plugin #:name "DosSegMgr"))))
    (set! (task 'selected) (list disk))
    (task 'apply)))

(define (pr-seg< sega segb)
  (< (assv-ref (sega) 'start)
     (assv-ref (segb) 'start)))

(define (pr-size< size num)
  (< (pr-min-size size) num))

(define (pr-min-size size)
  (if (pair? size) (car size) size))

(define (pr-max-size size)
  (if (pair? size) (cdr size) size))

;;}}}

;;{{{ control node et al
;---------------------------------------------------------------
(define (control-node command junk . args)
  (case command
    ((name) "control")
    ((value) #t)
    ((tree) '("control"))
    ((read)
     (case (assv-ref args 'control)
       ((version) `(version ,(evms 'version)))
       ((pending) `(pending ,(evms 'pending)))
       ((assigned) `(assigned ,(evms 'assigned)))
       ((postponed) `(postponed ,(evms 'postponed)))
       (else '())))
    ((write)
     (case (assv-ref args 'control)
       ((open)
        (if evms '()
            (evms-catch
             (lambda ()
               (set! evms-prefix (if (assv-ref args 'installer) "/mnt/destination" #f))
               (set! evms (engine #:mode 'rw #:prefix evms-prefix))
               (set! evms-fsims (fsims))
               (or (not (evms 'pending)) (evms 'commit)) ; activate volumes, just in case
               '()))))
       ((reset)
        (evms-catch
         (lambda ()
           (evms 'close)
           (set! evms (engine #:mode 'rw #:logfile #f #:prefix evms-prefix))
           (set! evms-fsims (fsims))
           '())))
       ((update) (set! /evms (create-tree)) '()) ;;(evms 'update))
       ((commit) (evms-catch (lambda () (evms 'commit) '())))
       ((close) ;; assumes all changes commited
        (if evms (evms-close-with (assv-ref args 'ignore))
            '()))))))

(define (evms-close-with args)
  (format #t "CLOSE-WITH: ~S\n" args)
  (cond ((not (or #t (eqv? 'bootable args)))  ; don't care about bootable from now
         '(quote bootable "There is no bootable partitions. Some BIOS'es will not work correctly. Continue?"))
        (#t
         (evms-catch (lambda ()
                       (evms 'finalize)
                       (evms 'close)
                       (set! evms #f)
                       '())))))

(define (evms-catch thunk)
  (catch 'swig-system-error thunk
         (lambda (key func msg . rest) `(error ,(string-append func ":" msg)))))
;---------------------------------------------------------------
(define (create-tree)
  (create-compound
   (create-node "evms")
   (create-compound
    (create-node "tree")
    (create-disk-subtree)
    (create-raid-subtree)
    (create-lvm-subtree))
   (apply create-compound
          (create-node "storage")
          (map apply-compound
               `(("disks" . ,(evms 'object-list #:type 'disk))
                 ;;("segments" . ,(evms 'object-list #:type 'segment))
                 ;;("regions" . ,(evms 'object-list #:type 'region))
                 ;;("features" . ,(evms 'object-list #:type 'feature))
                 ;;("containers" . ,(evms 'container-list))
                 ("volumes" . ,(evms 'volume-list)))))
   tasks-compound
   (apply create-compound (create-node "profiles") (create-profiles))
   control-node))

;;}}}

;---------------------------------------------------------------
(define evms #f)
(define evms-prefix #f)
(define evms-fsims #f)
(define /evms (create-compound (create-node "evms") control-node))

(lambda (self path args)
  (let ((args (alist-delete 'language (plist->alist args)))) ;no wayz
    ;;(format #t "ARGS: ~S\n" args)
    (apply /evms
           (sure-symbol (assv-ref args 'action))
           path
           (alist-delete 'action args))))
