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)