1 (** fifowatcher.ml: Routines for creating and managing fifos *)
10 (** A connected process, FIFO *)
11 type channel_pipe = Process of Unix.file_descr | Fifo of Unix.file_descr | BrokenPipe
13 (** Signed file descriptors. *)
14 type signed_fd = Infd of Unix.file_descr | Outfd of Unix.file_descr | Eventfd of Unix.file_descr
16 (** XXX This will get deprecated when we switch to inotify *)
17 let fdmap: (Unix.file_descr,string*string) Hashtbl.t = Hashtbl.create 1024
19 (** Maps pids to slice connections. Needed to clean up fds when a script dies
21 let pidmap: (int,signed_fd list) Hashtbl.t = Hashtbl.create 1024
22 let backend_prefix = ref ""
23 let open_fds: (Unix.file_descr,channel_pipe) Hashtbl.t = Hashtbl.create 1024
25 (** Receive an event from a running script. This event must be relayed to the
26 slice that invoked it.
28 @param idesc fd/fname identifier for process
30 let receive_process_event (idesc: fname_and_fd) (_: fname_and_fd) =
31 let (_,ifd) = idesc in
32 let cp = try Hashtbl.find open_fds ifd with
34 logprint "Fifo fd disappeared\n";raise Bug
40 printf "Received process event\n";flush Pervasives.stdout;
41 (* transferred = 4096 => there were at least 4096 bytes in the
42 * stream, so we should try again.
43 * transferred < 4096 => EAGAIN => either this is all the data we
45 * OR XXX the receiver is blocking (supposedly this can't happen) *)
46 let transferred = ref 4096 in
47 while (!transferred == 4096) do
48 transferred:=tee ifd fifo_outfd 4096
51 Failure(s)->logprint "Transfer failure: %s\n" s
53 | _ -> logprint "Bug! Process fd received in the channel handler\n";raise Bug
55 let rec openentry_int fifoin fifoout (abspath:string*string) =
57 try openfile fifoin [O_RDONLY;O_NONBLOCK] 0o777 with
58 e->logprint "Error opening and connecting FIFO: %s,%o\n" fifoin 0o777;raise e
60 Hashtbl.replace fdmap fdin abspath;
61 Fdwatcher.add_fd (Some(fifoin),fdin) (Some(fifoout),stdout) receive_fifo_event
62 and reopenentry_int fdin fifoin fifoout =
64 Fdwatcher.del_fd fdin;
66 Hashtbl.find fdmap fdin with _ -> logprint "Bug: Phantom pipe\n";raise Bug
68 openentry_int fifoin fifoout abspath
70 (** receive an event from a fifo and connect to the corresponding service, or to
71 create it if it doesn't exit
72 @param eventdescriptor Name of input pipe,in descriptor
73 @param outdescriptor Name of output pipe, out descriptor
75 and receive_fifo_event eventdescriptor outdescriptor =
76 let (evfname,evfd) = eventdescriptor in
77 let (fname_other,fd_other) = outdescriptor in
78 (* Open the output pipe, or use stdout instead *)
80 match (fname_other) with
83 try openfile str [O_WRONLY;O_NONBLOCK] 0o777 with
84 _->logprint "Output pipe not open, using stdout in place of %s\n" str;stdout
86 | None-> logprint "Bug, nameless pipe\n";raise Bug
88 (* Check if the input descriptor is already registered (=> a session is open).
89 If not, register it and start a new session.*)
90 let pipe = try Hashtbl.find open_fds evfd with
92 (* Ok, need to launch script *)
93 let execpath,slice_name = Hashtbl.find fdmap evfd in
94 let (script_infd,pout) = Unix.pipe () in
95 let (pin,script_outfd) = Unix.pipe () in
96 set_nonblock script_infd;
97 ignore(sigprocmask SIG_BLOCK [Sys.sigchld]);
98 let rpid = try Some(create_process execpath [|execpath;slice_name|] pin pout pout) with e -> logprint "Error executing service: %s\n" execpath;None
103 (* Register fds associated with pid so that they can be cleaned up
105 Hashtbl.add pidmap pid [Infd(script_infd);Outfd(script_outfd);Eventfd(evfd)];
107 (* Connect pipe to running script *)
108 Hashtbl.add open_fds evfd (Process(script_outfd));
110 (* Connect the running script to the pipe *)
111 Hashtbl.add open_fds script_infd (Fifo(outfd));
113 (* Activate running script *)
114 Fdwatcher.add_fd (None,script_infd) (None,script_infd) receive_process_event;
116 (Process(script_outfd))
118 (* We have the connection to the process - because it was open, or because it
119 just got established *)
121 | Process(fifo_outfd) ->
124 let transferred = ref 4096 in
125 while (!transferred == 4096) do
127 transferred:=tee evfd fifo_outfd 4096;
128 printf "Transferred: %d\n" !transferred;flush Pervasives.stdout
133 logprint "Error connecting user to service: %s\n" str
135 ignore(sigprocmask SIG_UNBLOCK [Sys.sigchld]);
136 printf "Out of the loop\n";flush Pervasives.stdout
140 | Fifo(_) -> logprint "BUG! received process event from fifo\n";raise Bug
143 (** Make a pair of fifo entries *)
144 let mkentry fqp abspath perm uname =
145 logprint "Making entry %s->%s\n" fqp abspath;
146 let fifoin=sprintf "%s.in" fqp in
147 let fifoout=sprintf "%s.out" fqp in
148 (try Unix.unlink fifoin with _ -> ());
149 (try Unix.unlink fifoout with _ -> ());
151 let infname =(sprintf "%s.in" fqp) in
152 let outfname =(sprintf "%s.out" fqp) in
153 Unix.mkfifo infname 0o666;
154 Unix.mkfifo outfname 0o666;
155 ( (* Make the user the owner of the pipes in a non-chroot environment *)
156 if (!Globals.nochroot) then
157 let pwentry = Unix.getpwnam uname in
158 Unix.chown infname pwentry.pw_uid pwentry.pw_gid;
159 Unix.chown outfname pwentry.pw_uid pwentry.pw_gid
163 e->logprint "Error creating FIFO: %s->%s. May be something wrong at the frontend.\n" fqp fifoout;Failed)
165 (** Open fifos for a session. Will shutdown vsys if the fifos don't exist *)
166 let openentry fqp abspath perm =
167 let fifoin = String.concat "." [fqp;"in"] in
168 let fifoout = String.concat "." [fqp;"out"] in
169 openentry_int fifoin fifoout abspath
171 let sigchld_handle s =
172 let pid,_=Unix.waitpid [Unix.WNOHANG] 0 in
174 let sfd_list = Hashtbl.find pidmap pid in
183 Hashtbl.remove open_fds fd (* Disconnect pipe *)
185 List.iter handle_sfd sfd_list;
186 Hashtbl.remove pidmap pid
188 Not_found-> (* Do nothing, probably a grandchild *)
192 Sys.set_signal Sys.sigchld (Sys.Signal_handle sigchld_handle)