fix dependency for doc
[vsys.git] / fifowatcher.ml
1 (** fifowatcher.ml: Routines for creating and managing fifos *)
2
3 open Inotify
4 open Unix
5 open Globals
6 open Dirwatcher
7 open Printf
8 open Splice
9
10 (** A connected process, FIFO *)
11 type channel_pipe = Process of Unix.file_descr | Fifo of Unix.file_descr | BrokenPipe
12
13 (** Signed file descriptors. *)
14 type signed_fd = Infd of Unix.file_descr | Outfd of Unix.file_descr | Eventfd of Unix.file_descr
15
16 (** XXX This will get deprecated when we switch to inotify *)                                                                                  
17 let fdmap: (Unix.file_descr,string*string) Hashtbl.t = Hashtbl.create 1024
18
19 (** Maps pids to slice connections. Needed to clean up fds when a script dies
20   with EPIPE *)
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
24
25 (** Receive an event from a running script. This event must be relayed to the
26   slice that invoked it.
27
28   @param idesc fd/fname identifier for process
29   *)
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
33       Not_found->
34         logprint "Fifo fd disappeared\n";raise Bug
35   in
36     match (cp) with 
37       | Fifo(fifo_outfd) ->
38           begin
39             try
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
44                * have (move on)
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
49                 done;
50             with 
51                 Failure(s)->logprint "Transfer failure: %s\n" s
52           end
53       | _ -> logprint "Bug! Process fd received in the channel handler\n";raise Bug
54
55 let rec openentry_int fifoin fifoout (abspath:string*string) =
56   let fdin =
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
59   in
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 =
63   close fdin;
64     Fdwatcher.del_fd fdin;
65     let abspath = try 
66       Hashtbl.find fdmap fdin with _ -> logprint "Bug: Phantom pipe\n";raise Bug
67     in
68       openentry_int fifoin fifoout abspath
69
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
74   *)
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 *)
79   let outfd =
80     match (fname_other) with
81       | Some(str)->
82           (
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
85           )
86       | None-> logprint "Bug, nameless pipe\n";raise Bug
87   in
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
91     | Not_found ->
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
99           in
100             match rpid with
101               | None-> BrokenPipe
102               | Some(pid)->
103                   (* Register fds associated with pid so that they can be cleaned up
104                    * when it dies *)
105                   Hashtbl.add pidmap pid [Infd(script_infd);Outfd(script_outfd);Eventfd(evfd)];
106
107                   (* Connect pipe to running script *)
108                   Hashtbl.add open_fds evfd (Process(script_outfd));
109
110                   (* Connect the running script to the pipe *)
111                   Hashtbl.add open_fds script_infd (Fifo(outfd));
112
113                   (* Activate running script *)
114                   Fdwatcher.add_fd (None,script_infd) (None,script_infd) receive_process_event;
115
116                   (Process(script_outfd))
117   in
118     (* We have the connection to the process - because it was open, or because it
119      just got established *)
120     match (pipe) with
121       | Process(fifo_outfd) -> 
122           begin
123             try
124               let transferred = ref 4096 in
125                 while (!transferred == 4096) do
126                   begin
127                   transferred:=tee evfd fifo_outfd 4096;
128                                  printf "Transferred: %d\n" !transferred;flush Pervasives.stdout
129                   end
130                 done;
131             with Failure(str) ->
132               begin
133                 logprint "Error connecting user to service: %s\n" str
134               end;
135               ignore(sigprocmask SIG_UNBLOCK [Sys.sigchld]);
136                                  printf "Out of the loop\n";flush Pervasives.stdout
137
138           end
139       | BrokenPipe -> ()
140       | Fifo(_) -> logprint "BUG! received process event from fifo\n";raise Bug
141
142
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 _ -> ());
150     (try 
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
160          );
161          Success
162      with 
163          e->logprint "Error creating FIFO: %s->%s. May be something wrong at the frontend.\n" fqp fifoout;Failed)
164
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
170
171 let sigchld_handle s =
172   let pid,_=Unix.waitpid [Unix.WNOHANG] 0 in
173     try
174       let sfd_list = Hashtbl.find pidmap pid in
175       let handle_sfd sfd =
176         match sfd with
177           | Infd(fd) ->
178               close fd;
179               Fdwatcher.del_fd fd
180           | Outfd(fd)->
181               close fd
182           | Eventfd(fd)->
183               Hashtbl.remove open_fds fd (* Disconnect pipe *)
184       in
185         List.iter handle_sfd sfd_list;
186         Hashtbl.remove pidmap pid
187     with 
188         Not_found-> (* Do nothing, probably a grandchild *)
189           ()
190
191 let initialize () = 
192   Sys.set_signal Sys.sigchld (Sys.Signal_handle sigchld_handle)