;;;
;;; Lookup/update effective POSIX group information.
;;;

(module posix-groups
  (group-information initialize-groups get-groups set-groups!)
  (import scheme)
  (import chicken.base chicken.fixnum chicken.foreign)

#>

#include <grp.h>

static C_TLS struct group *C_group;
static C_TLS gid_t *C_groups;

#define C_get_gid(n)      C_fix(C_groups[ C_unfix(n) ])
#define C_set_gid(n, id)  (C_groups[ C_unfix(n) ] = C_unfix(id), C_SCHEME_UNDEFINED)
#define C_set_groups(n)   C_fix(setgroups(C_unfix(n), C_groups))

#ifdef __ANDROID__
#define C_getgrnam(n)       C_SCHEME_FALSE
#define C_getgrgid(n)       C_SCHEME_FALSE
#else
#define C_getgrnam(n)       C_mk_bool((C_group = getgrnam((char *)C_data_pointer(n))) != NULL)
#define C_getgrgid(u)       C_mk_bool((C_group = getgrgid(C_unfix(u))) != NULL)
#endif

<#

(define-foreign-variable _group-name nonnull-c-string "C_group->gr_name")
(define-foreign-variable _group-passwd nonnull-c-string "C_group->gr_passwd")
(define-foreign-variable _group-gid int "C_group->gr_gid")

(define group-member
  (foreign-lambda* c-string ((int i))
    "C_return(C_group->gr_mem[ i ]);"))

(define (group-information group #!optional as-vector)
  (and (if (fixnum? group)
           (##core#inline "C_getgrgid" group)
           (begin
             (##sys#check-string group 'group-information)
             (##core#inline "C_getgrnam" (##sys#make-c-string group 'group-information))))
       ((if as-vector vector list)
        _group-name
        _group-passwd
        _group-gid
        (let loop ((i 0))
          (let ((n (group-member i)))
            (if n (cons n (loop (fx+ i 1))) '()))))))

(define _get-groups
  (foreign-lambda* int ((int n))
    "C_return(getgroups(n, C_groups));"))

(define _ensure-groups
  (foreign-lambda* bool ((int n))
    "if(C_groups != NULL) C_free(C_groups);"
    "C_groups = (gid_t *)C_malloc(sizeof(gid_t) * n);"
    "if(C_groups == NULL) C_return(0);"
    "else C_return(1);"))

(define (get-groups)
  (let ((n (foreign-value "getgroups(0, C_groups)" int)))
    (when (fx< n 0)
      (##sys#update-errno)
      (##sys#error 'get-groups "cannot retrieve supplementary group ids"))
    (unless (_ensure-groups n)
      (##sys#error 'get-groups "out of memory"))
    (when (fx< (_get-groups n) 0)
      (##sys#update-errno)
      (##sys#error 'get-groups "cannot retrieve supplementary group ids"))
    (let loop ((i 0))
      (if (fx>= i n)
          '()
          (cons (##core#inline "C_get_gid" i) (loop (fx+ i 1)))))))

(define (set-groups! lst0)
  (unless (_ensure-groups (length lst0))
    (##sys#error 'set-groups! "out of memory"))
  (do ((lst lst0 (##sys#slot lst 1))
       (i 0 (fx+ i 1)))
      ((null? lst)
       (when (fx< (##core#inline "C_set_groups" i) 0)
         (##sys#update-errno)
         (##sys#error 'set-groups! "cannot set supplementary group ids" lst0)))
    (let ((n (##sys#slot lst 0)))
      (##sys#check-fixnum n 'set-groups!)
      (##core#inline "C_set_gid" i n))))

(define initialize-groups
  (let ((init (foreign-lambda int "initgroups" c-string int)))
    (lambda (user id)
      (##sys#check-string user 'initialize-groups)
      (##sys#check-fixnum id 'initialize-groups)
      (when (fx< (init user id) 0)
        (##sys#update-errno)
        (##sys#error 'initialize-groups "cannot initialize supplementary group ids" user id))))))