initial static home directory implementation

lib/db_store.ml

@@ -59,12 +59,14 @@ module Make (Raw : S.STORE) = struct
       Lwt_result.return (`Loaded, id)
     | None ->
       Raw.build t.raw ?base ~id (fun dir ->
-          let log_file = dir / "log" in
+          (* Probably a bad workaround to deal with remounting ZFS dirs on macOS *)
+          let log_file = "/tmp" / (Fmt.str "%s-log" id) in
           if Sys.file_exists log_file then Unix.unlink log_file;
           Build_log.create log_file >>= fun log ->
           Lwt.wakeup set_log log;
           fn ~cancelled ~log dir >>= fun res -> 
           finish_log ~set_log (Lwt.return log) >>= fun _ ->
+          Os.copy ~src:log_file ~dst:(dir / "log") >>= fun _ ->
           Lwt.return res
         )
       >>!= fun () ->

lib/os.ml

@@ -146,6 +146,9 @@ let pread ?stderr argv =
   child >>= fun () ->
   Lwt.return data
 
+let copy ~src ~dst =
+  exec ["cp"; src; dst]
+
 let check_dir x =
   match Unix.lstat x with
   | Unix.{ st_kind = S_DIR; _ } -> `Present
@@ -186,7 +189,7 @@ module Macos = struct
           sudo (dscl @ ["-passwd"; user; "hello"]) >>= fun _ -> Lwt.return_ok ()
     end 
 
-  let delete_user ~user = 
+  let delete_user ~user =
     user_exists ~user >>= begin function
       | false -> 
         Log.info (fun f -> f "Not deleting %s as they don't exists" user);
@@ -198,19 +201,35 @@ module Macos = struct
           sudo_result ~pp:(pp "Deleting") delete
     end
 
-  let pkill ~user = 
+  let pkill ~user =
     let pp s ppf = Fmt.pf ppf "[ Mac ] %s\n" s in 
     let delete = ["pkill"; "-u"; user ] in 
     sudo_result ~pp:(pp "Killing") delete >|= function 
       | Ok () -> () 
       | _ -> Log.warn (fun f -> f "Failed to pkill for %s" user); ()
 
-  let copy_template ~base ~local = 
+  let copy_template ~base ~local =
     let pp s ppf = Fmt.pf ppf "[ Mac ] %s\n" s in 
     sudo_result ~pp:(pp "Rsync Brew") ["rsync"; "-avq"; base ^ "/"; local]
+
+  (* A little annoying this ties macOS and ZFS together... *)
+  let zfs_unset_mount ~dataset =
+    let pp s ppf = Fmt.pf ppf "[ Mac ] %s\n" s in
+    sudo_result ~pp:(pp "Unmouting") ["zfs"; "unmount"; "-f"; dataset ] >>= fun _ ->
+    (* Temporary fix -- shouldn't need to remount *)
+    sudo_result ~pp:(pp "Restoring mountpoint") ["zfs"; "set"; Fmt.str "mountpoint=/Volumes/%s" dataset; dataset ] >>= fun _ ->
+    sudo_result ~pp:(pp "Mount") ["zfs"; "mount"; dataset ]
+
+  let zfs_set_mount ~mountpoint ~dataset =
+    let pp s ppf = Fmt.pf ppf "[ Mac ] %s\n" s in
+    let mountpoint = Fmt.str "mountpoint=%s" mountpoint in
+    (* Forcefully remove in order to set mountpoint... probably breaks logging :( *)
+    sudo_result ~pp:(pp "Unmouting") ["zfs"; "unmount"; "-f"; dataset ] >>= fun _ ->
+    sudo_result ~pp:(pp "Set mountpoint") ["zfs"; "set"; mountpoint; dataset ] >>= fun _ ->
+    sudo_result ~pp:(pp "Mount") ["zfs"; "mount"; dataset ]
 
   let change_home_directory_for ~user ~homedir = 
-    ["dscl"; "."; "-create"; "/Users/" ^ user ; "NFSHomeDirectory"; homedir ]
+    [ "dscl"; "."; "-create"; "/Users/" ^ user ; "NFSHomeDirectory"; homedir ]
 
   (* Used by the FUSE filesystem to indicate where a users home directory should be ...*)
   let update_scoreboard ~uid ~scoreboard ~homedir = 

lib/sandbox.macos.ml

@@ -23,7 +23,6 @@ type config = {
 
 let version = "macos-sandboxing"
 
-
 let ( / ) = Filename.concat 
 
 let run_as ~env ~user ~cmd =
@@ -49,65 +48,104 @@ let copy_to_log ~src ~dst =
 let user_name ~prefix ~uid ~from = 
   Fmt.str "%s%s-%s" prefix uid from
 
+let prefix = "mac"
+
+(* For macOS there are three important directories:
+     - The base image currently stored at /Users/<base-image> (one day it might come from docker)
+     - The snapshot (datatset) directory provided by the storage backend (e.g. ZFS)
+     - A fixed home directory (/Users/<user-name> which is guaranteed to be unique per uid)
+
+  The snapshot is mounted to the fixed home directory in order to not confuse tools that don't
+  expect $HOME to be changing from underneath them (e.g. ocamlfind)
+*)
 let from ~log ~from_stage (t : t) =
   log `Heading (Fmt.strf "SYS %s" from_stage);
   let id = Sha256.to_hex (Sha256.string from_stage) in
-  let home = "/Volumes/tank/result" / id in 
-  let uid = string_of_int t.uid in 
-  let username = user_name ~prefix:"mac" ~uid ~from:from_stage in 
+  let dataset = Fmt.str "tank/result/%s" id in (* TODO: the user could specify different ZFS names than 'tank'*)
+  let dataset_dir = "/Volumes/" ^ dataset in
+  let uid = string_of_int t.uid in
+  let username = user_name ~prefix ~uid ~from:from_stage in
+  let home = Fmt.str "/Users/%s" username in
   t.user <- username;
   fun ~cancelled:_ ~log:_ (_ : string) ->
     Os.Macos.create_new_user ~username ~home ~uid ~gid:"1000" >>= fun _ ->
-    Os.Macos.copy_template ~base:("/Users/" ^ from_stage) ~local:home >>= fun _ -> 
+    Os.ensure_dir home;
+    Os.Macos.copy_template ~base:("/Users/" ^ from_stage) ~local:dataset_dir >>= fun _ ->
+    Os.Macos.zfs_set_mount ~mountpoint:home ~dataset >>= fun _ ->
     Os.(sudo @@ Macos.update_scoreboard ~uid:t.uid ~homedir:home ~scoreboard:t.scoreboard) >>= fun _ ->
     Os.sudo [ "chown"; "-R"; ":1000"; home ] >>= fun () ->
     Os.sudo [ "chmod"; "-R"; "g+w"; home ] >>= fun () ->
-    Os.pread @@ Os.Macos.get_tmpdir ~user:username >>= fun s -> 
+    Os.pread @@ Os.Macos.get_tmpdir ~user:username >>= fun s ->
     Log.info (fun f -> f "Setting temporary directory to %s" s);
-    t.tmpdir <- s; 
+    t.tmpdir <- s;
+    Os.Macos.zfs_unset_mount ~dataset >>= fun _ ->
     Lwt.return (Ok () :> (unit, [ `Cancelled | `Msg of string ]) result)
 
-let clean (t : t) = 
+let clean (t : t) =
   (* Os.(sudo (Macos.remove_link ~uid:t.uid ~scoreboard:t.scoreboard)) >>= fun () -> 
   Log.info (fun f -> f "Deleting user %s" t.user);
   Os.Macos.delete_user ~user:t.user >|= function 
     | Ok () -> ()
     | _ -> Log.err (fun f -> f "Failed to delete user: %s" t.user); () *)
   Lwt.return ()
 
+let dataset path = String.split_on_char '/' path |> List.tl |> List.tl |> String.concat "/"
+
+(* ZFS mounting for config mounts *)
+let zfs_mount ~homedir { Config.Mount.src; dst } =
+  let mountpoint = Filename.concat homedir dst in
+  Os.ensure_dir mountpoint;
+  Os.Macos.zfs_set_mount ~mountpoint ~dataset:(dataset src) >>= fun _ ->
+  Os.sudo [ "chown"; "-R"; ":1000"; mountpoint ] >>= fun () ->
+  Os.sudo [ "chmod"; "-R"; "g+w"; mountpoint ] >>= fun () ->
+  Lwt.return ()
+
 (* A build step in macos: 
    - Should be properly sandboxed using sandbox-exec (coming soon...)
    - Umask g+w to work across users if restored from a snapshot
    - Set the new home directory of the user, to the new hash
    - Should be executed by the underlying user (t.uid) *)
-let run ~cancelled ?stdin:stdin ~log (t : t) config homedir =
+let run ~cancelled ?stdin:stdin ~log (t : t)
+  { Config.cwd;
+    argv;
+    hostname = _; (* TODO? *)
+    user = _; (* macOS ignores the user because we use that for "sandboxing" *)
+    env;
+    mounts;
+    network = _; (* TODO? *)
+  } dataset_dir =
   Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w ->
-  let user = t.user in 
-  let uid = string_of_int t.uid in 
-  Os.Macos.create_new_user ~username:user ~home:homedir ~uid ~gid:"1000" >>= fun _ -> 
-  let set_homedir = Os.Macos.change_home_directory_for ~user ~homedir in 
+  let user = t.user in
+  let uid = string_of_int t.uid in
+  let homedir = Fmt.str "/Users/%s" t.user in
+  Os.Macos.create_new_user ~username:user ~home:homedir ~uid ~gid:"1000" >>= fun _ ->
+  let set_homedir = Os.Macos.change_home_directory_for ~user ~homedir in
   let update_scoreboard = Os.Macos.update_scoreboard ~uid:t.uid ~homedir ~scoreboard:t.scoreboard in
-  let osenv = config.Config.env in
   let stdout = `FD_move_safely out_w in
   let stderr = stdout in
   let copy_log = copy_to_log ~src:out_r ~dst:log in
   let proc =
     let stdin = Option.map (fun x -> `FD_move_safely x) stdin in
-    let pp f = Os.pp_cmd f config.Config.argv in
+    let pp f = Os.pp_cmd f argv in
     Os.sudo_result ~pp set_homedir >>= fun _ ->
     Os.sudo_result ~pp update_scoreboard >>= fun _ ->
+    Os.Macos.zfs_set_mount ~mountpoint:homedir ~dataset:(dataset dataset_dir) >>= fun _ ->
     Os.pread @@ Os.Macos.get_tmpdir ~user >>= fun tmpdir ->
     let tmpdir = List.hd (String.split_on_char '\n' tmpdir) in
-    let env = ("TMPDIR", tmpdir) :: osenv in
-    let cmd = run_as ~env ~user ~cmd:config.Config.argv in
-    Os.ensure_dir config.Config.cwd;
-    Os.exec_result ?stdin ~stdout ~stderr ~pp ~cwd:config.Config.cwd cmd
+    let env = ("TMPDIR", tmpdir) :: env in
+    let cmd = run_as ~env ~user ~cmd:argv in
+    Os.ensure_dir cwd;
+    Lwt_list.iter_s (zfs_mount ~homedir) mounts >>= fun () ->
+    Os.exec_result ?stdin ~stdout ~stderr ~pp ~cwd cmd >>= fun res ->
+    (* Unmount mounts necessary ? *)
+    Os.Macos.zfs_unset_mount ~dataset:(dataset dataset_dir) >>= fun _ ->
+    Lwt.return res
   in
   Lwt.on_termination cancelled (fun () ->
   let rec aux () =
         if Lwt.is_sleeping proc then (
           let pp f = Fmt.pf f "Should kill %S" homedir in
-          (* XXX patricoferris: Pkill processes belonging to user then deleter user? *)
+          (* XXX patricoferris: Pkill processes belonging to user then delete user? *)
           Os.Macos.pkill ~user:t.user
           (*clean t*)
         ) else Lwt.return_unit  (* Process has already finished *)