(* $Id: rpc_auth_sys.ml 1614 2011-06-09 15:08:56Z gerd $ * ---------------------------------------------------------------------- * *) open Xdr open Rtypes open Rpc type identity = [ `Effective_user | `Real_user | `This_user of (int * int * int array * string) ] let auth_params_type = X_struct [ "stamp", X_uint; "machinename", (X_string (uint4_of_int 255)); "uid", X_uint; "gid", X_uint; "gids", X_array(X_uint,(uint4_of_int 16)) ] ;; let val_auth_params_type = validate_xdr_type auth_params_type;; type state = Init | Auth_sys_sent | Auth_short_sent | Auth_accepted of string (* returned verifier *) let max_uint4_as_int64 = Int64.of_string "0xffffffff";; let client_auth_session identity proto : Rpc_client.auth_session = let (uid, gid, gids, hostname) = match identity with `Effective_user -> (Unix.geteuid(), Unix.getegid(), Unix.getgroups(), Unix.gethostname()) | `Real_user -> (Unix.getuid(), Unix.getgid(), Unix.getgroups(), Unix.gethostname()) | `This_user(u,g,gs,h) -> (u,g,gs,h) in object val mutable state = Init method next_credentials _ _ _ _ = match state with Init | Auth_sys_sent (* handle this case for robustness *) | Auth_short_sent -> (* handle this case for robustness *) (* Send AUTH_SYS credentials: *) let xdr_value = XV_struct [ "stamp", XV_uint (uint4_of_int64 (Int64.logand (Int64.of_float (Unix.time())) max_uint4_as_int64)); "machinename", XV_string hostname; "uid", XV_uint (uint4_of_int uid); "gid", XV_uint (uint4_of_int gid); "gids", XV_array (Array.map (fun g -> XV_uint (uint4_of_int g)) gids) ] in let creds = pack_xdr_value_as_string xdr_value val_auth_params_type [] in state <- Auth_sys_sent; ("AUTH_SYS", creds, "AUTH_NONE", "", None, None) | Auth_accepted creds -> (* Send AUTH_SHORT credentials: *) state <- Auth_short_sent; ("AUTH_SHORT", creds, "AUTH_NONE", "", None, None) method server_rejects _ _ err = match state with Auth_sys_sent -> state <- Init; raise (Rpc_server err) | Auth_short_sent -> (* Retry: *) state <- Init; `Retry | _ -> assert false method server_accepts _ _ flav data = match state with Auth_sys_sent | Auth_short_sent -> ( match flav with "AUTH_SHORT" -> state <- Auth_accepted data | _ -> state <- Init ) | _ -> assert false method auth_protocol = proto end let client_auth_proto identity m : Rpc_client.auth_protocol = let session = ref None in object(self) initializer session := Some(client_auth_session identity self) method state = match !session with | None -> assert false | Some s -> `Done s method emit _ = assert false method receive _ = assert false method auth_method = m end let client_auth_method ?(identity = `Real_user) () : Rpc_client.auth_method = let _ = (identity : identity) in object(self) method name = "AUTH_SYS" method new_session _ user_opt = let user = match user_opt with | None -> identity | Some u -> (* FIXME *) failwith "Rpc_auth_sys: only default user possible" in client_auth_proto user self end type user_name_format = [ `Full | `UID | `Custom of int32 -> int32 -> int32 array -> string -> string ] class server_auth_method ?(lookup_hostname = true) ?(require_privileged_port = true) ?(user_name_as = (`Full : user_name_format)) () : Rpc_server.auth_method = object method name = "AUTH_SYS" method flavors = [ "AUTH_SYS" ] (* We don't reply AUTH_SHORT! *) method peek = `None method authenticate srv cnid details pass = (* Unpack cred_data: *) let cred_flavor, cred_data = details # credential in let xdr = Xdr.unpack_xdr_value cred_data val_auth_params_type [] in match xdr with XV_struct [ "stamp", _; "machinename", XV_string hostname; "uid", XV_uint uid; "gid", XV_uint gid; "gids", XV_array xdr_gids ] -> let gids = Array.map (function XV_uint g -> g | _ -> assert false) xdr_gids in if lookup_hostname then begin match details#client_addr with | Some (Unix.ADDR_INET(a,p)) -> begin try let entry = Uq_resolver.get_host_by_name hostname in let l = Array.to_list entry.Unix.h_addr_list in if not(List.mem a l) then raise Not_found with Uq_resolver.Host_not_found _ -> raise(Rpc_server Auth_bad_cred) end | _ -> () end; if require_privileged_port then begin match details#client_addr with | Some(Unix.ADDR_INET(a,p)) -> if p >= 1024 then raise(Rpc_server Auth_bad_cred) | _ -> (* The Unix syscalls are missing. *) raise(Rpc_server Auth_bad_cred) end; let uid_gid_str = Int32.to_string(Rtypes.logical_int32_of_uint4 uid) ^ "." ^ Int32.to_string(Rtypes.logical_int32_of_uint4 gid) in let gidlist_str = String.concat "." (Array.to_list (Array.map (fun u -> Int32.to_string(Rtypes.logical_int32_of_uint4 u)) gids ) ) in let username = match user_name_as with | `Full -> uid_gid_str ^ (if gidlist_str <> "" then "." ^ gidlist_str else "") ^ "@" ^ hostname | `UID -> Int32.to_string(Rtypes.logical_int32_of_uint4 uid) | `Custom f -> f (Rtypes.logical_int32_of_uint4 uid) (Rtypes.logical_int32_of_uint4 gid) (Array.map (fun u -> Rtypes.logical_int32_of_uint4 u) gids) hostname in pass (Rpc_server.Auth_positive(username, "AUTH_NONE", "",None,None)) | _ -> assert false end let server_auth_method = new server_auth_method let parse_user_name s = let rec parse pos ugs = try let pos' = String.index_from ugs pos '.' in (* or Not_found *) let ds = String.sub ugs pos (pos' - pos) in int_of_string ds :: parse (pos'+1) ugs with Not_found -> let ds = String.sub ugs pos (String.length ugs - pos) in [ int_of_string ds ] in try let at_pos = String.index s '@' in (* or Not_found *) let hostname = String.sub s (at_pos+1) (String.length s - 1 - at_pos) in match parse 0 (String.sub s 0 at_pos) with uid :: gid :: gidlist -> (uid,gid,Array.of_list gidlist,hostname) | _ -> raise Not_found with _ -> failwith "Rpc_auth_sys.parse_user_name" ;;