(* $Id: plasma_ug.ml 418 2011-09-23 11:31:30Z gerd $ *)

open Plasma_util

class type ug_admin =
object
  method getpwnam : string -> Unix.passwd_entry
  method getpwuid : int -> Unix.passwd_entry
  method getgrnam : string -> Unix.group_entry
  method getgrgid : int -> Unix.group_entry
  method getgroups : string -> Plasma_util.StrSet.t
  method users : Unix.passwd_entry list
  method groups : Unix.group_entry list
  method add_group : Unix.group_entry -> unit
  method del_group : string -> unit
  method add_user : Unix.passwd_entry -> unit
  method del_user : string -> unit
  method admin_tables : (string * string) list
end

class type ug_admin_ro =
object
  method getpwnam : string -> Unix.passwd_entry
  method getpwuid : int -> Unix.passwd_entry
  method getgrnam : string -> Unix.group_entry
  method getgrgid : int -> Unix.group_entry
  method getgroups : string -> Plasma_util.StrSet.t
  method users : Unix.passwd_entry list
  method groups : Unix.group_entry list
  method admin_tables : (string * string) list
end

let req_admin_tables = [ "passwd"; "group" ]

let colon_re = Netstring_str.regexp ":"
let comma_re = Netstring_str.regexp ","

let split_line s =
  Netstring_str.split_delim colon_re s

let split_members s =
  Netstring_str.split comma_re s

let passwd_entry_of_line s =
  try
    match split_line s with
      | [ uname; pw; uid_s; gid_s; gecos; home; sh ] ->
	  let uid = int_of_string uid_s in
	  let gid = int_of_string gid_s in
	  { Unix.pw_name = uname;
	    pw_passwd = pw;
	    pw_uid = uid;
	    pw_gid = gid;
	    pw_gecos = gecos;
	    pw_dir = home;
	    pw_shell = sh
	  }
      | _ -> raise Not_found
  with
    | _ -> failwith "Bad passwd line"


let line_of_passwd_entry u =
  let open Unix in
  String.concat ":"
    [ u.pw_name; 
      u.pw_passwd; 
      string_of_int u.pw_uid;
      string_of_int u.pw_gid;
      u.pw_gecos;
      u.pw_dir;
      u.pw_shell
    ]


let group_entry_of_line s =
  try
    match split_line s with
      | [ gname; pw; gid_s; mems ] ->
	  let gid = int_of_string gid_s in
	  { Unix.gr_name = gname;
	    gr_passwd = pw;
	    gr_gid = gid;
	    gr_mem = Array.of_list(split_members mems)
	  }
      | _ -> raise Not_found
  with
    | _ -> failwith "Bad group line"


let line_of_group_entry g =
  let open Unix in
  String.concat ":"
    [ g.gr_name;
      g.gr_passwd;
      string_of_int g.gr_gid;
      String.concat "," (Array.to_list g.gr_mem)
    ]

let parse_ug_admin tabs =
  let open Unix in
  let passwd_text =
    try List.assoc "passwd" tabs
    with Not_found -> failwith "Plasma_ug: 'passwd' is required but missing" in
  let passwd_lines =
    Netchannels.lines_of_in_obj_channel
      (new Netchannels.input_string passwd_text) in
  let group_text =
    try List.assoc "group" tabs
    with Not_found -> failwith "Plasma_ug: 'group' is required but missing" in
  let group_lines =
    Netchannels.lines_of_in_obj_channel
      (new Netchannels.input_string group_text) in
  let users =
    List.flatten
      (List.map
	 (fun line -> try [passwd_entry_of_line line] with _ -> [])
	 passwd_lines) in
  let groups =
    List.flatten
      (List.map
	 (fun line -> try [group_entry_of_line line] with _ -> [])
	 group_lines) in
  let pwnam = Hashtbl.create 5 in
  let pwuid = Hashtbl.create 5 in
  let grnam = Hashtbl.create 5 in
  let grgid = Hashtbl.create 5 in
  let ugroups = Hashtbl.create 5 in
  let mgroups = Hashtbl.create 5 in
  List.iter
    (fun g ->
       Hashtbl.replace grnam g.gr_name g;
       Hashtbl.replace grgid g.gr_gid g.gr_name
    )
    groups;
  List.iter
    (fun u ->
       if Hashtbl.mem grgid u.pw_gid then (
	 Hashtbl.replace pwnam u.pw_name u;
	 Hashtbl.replace pwuid u.pw_uid u.pw_name;
       )
    )
    users;
  let refresh() =  (* ugroups and mgroups *)
    (* We cannot delay this recomputation until needed, because we want
       that [ug_admin_ro] can be put into shared memory as constant.
     *)
    Hashtbl.clear ugroups;
    Hashtbl.clear mgroups;
    Hashtbl.iter
      (fun _ u ->
	 if Hashtbl.mem grgid u.pw_gid then (
	   let gname = Hashtbl.find grgid u.pw_gid in
	   Hashtbl.replace mgroups gname ();
	   Hashtbl.replace ugroups u.pw_name (StrSet.add gname StrSet.empty)
	 )
      )
      pwnam;
    Hashtbl.iter
      (fun _ g ->
	 Array.iter
	   (fun uname ->
	      let s = 
		try Hashtbl.find ugroups uname with Not_found -> StrSet.empty in
	      let s' =
		StrSet.add g.gr_name s in
	      Hashtbl.replace ugroups uname s'
	   )
	   g.gr_mem
      )
      grnam in
  refresh();
  ( object (self)
      method getpwnam n = Hashtbl.find pwnam n
      method getpwuid id = Hashtbl.find pwnam (Hashtbl.find pwuid id)
      method getgrnam n = Hashtbl.find grnam n
      method getgrgid id = Hashtbl.find grnam (Hashtbl.find grgid id)
      method getgroups n = Hashtbl.find ugroups n
      method users = Hashtbl.fold (fun _ u acc -> u::acc) pwnam []
      method groups = Hashtbl.fold (fun _ g acc -> g::acc) grnam []
      method add_group g =
	Hashtbl.replace grnam g.gr_name g;
	Hashtbl.replace grgid g.gr_gid g.gr_name;
	refresh()
      method del_group gname =
	if Hashtbl.mem mgroups gname then
	  failwith "del_group: this group is still used";
	if Hashtbl.mem grnam gname then (
	  let g = Hashtbl.find grnam gname in
	  Hashtbl.remove grnam gname;
	  Hashtbl.remove grgid g.gr_gid;
	  refresh()
	)
      method add_user u =
	if Hashtbl.mem grgid u.pw_gid then (
	  Hashtbl.replace pwnam u.pw_name u;
	  Hashtbl.replace pwuid u.pw_uid u.pw_name;
	  refresh()
	)
	else failwith "add_user: unknown group"
      method del_user uname =
	if Hashtbl.mem pwnam uname then (
	  let u = Hashtbl.find pwnam uname in
	  Hashtbl.remove pwnam uname;
	  Hashtbl.remove pwuid u.pw_uid;
	  refresh()
	)
      method admin_tables =
	let passwd_buf = Buffer.create 500 in
	let group_buf = Buffer.create 500 in
	Hashtbl.iter
	  (fun uname u ->
	     Buffer.add_string passwd_buf (line_of_passwd_entry u);
	     Buffer.add_string passwd_buf "\n";
	  )
	  pwnam;
	Hashtbl.iter
	  (fun gname g ->
	     Buffer.add_string group_buf (line_of_group_entry g);
	     Buffer.add_string group_buf "\n";
	  )
	  grnam;
	[ "passwd", Buffer.contents passwd_buf;
	  "group", Buffer.contents group_buf
	]

    end
  )


let serialize_auth_ticket ~rpc_user ~rpc_password ~user ~group ~supp_groups
                          ~verifier =
  let enc = Netencoding.Base64.encode in
  String.concat ":"
    [ "SCRAM-SHA1";
      enc rpc_user;
      enc rpc_password;
      enc user;
      enc group;
      String.concat "," (List.map enc (StrSet.elements supp_groups));
      Int64.to_string verifier
    ]


let rpc_login_of_auth_ticket s =
  let dec = Netencoding.Base64.decode in
  try
    match split_line s with
      | [ "SCRAM-SHA1"; rpc_user_e; rpc_password_e; _; _; _; _ ] ->
	  (dec rpc_user_e, dec rpc_password_e)
      | _ ->
	  raise Not_found
  with
    | _ -> failwith "Plasma_ug.rpc_login_of_auth_ticket"


let principal_of_auth_ticket s =
  let dec = Netencoding.Base64.decode in
  try
    match split_line s with
      | [ "SCRAM-SHA1"; _; _; user_e; group_e; supp_groups_e; _ ] ->
	  let l1 = split_members supp_groups_e in
	  let l2 = List.map dec l1 in
	  let supp_groups = 
	    List.fold_left
	      (fun acc g -> StrSet.add g acc)
	      StrSet.empty
	      l2 in
	  (dec user_e, dec group_e, supp_groups)
      | _ ->
	  raise Not_found
  with
    | _ -> failwith "Plasma_ug.principal_of_auth_ticket"


let verifier_of_auth_ticket s =
  try
    match split_line s with
      | [ "SCRAM-SHA1"; _; _; _; _; _; verifier_s ] ->
	  Int64.of_string verifier_s
      | _ ->
	  raise Not_found
  with
    | _ -> failwith "Plasma_ug.verifier_of_auth_ticket"