+(* Initialise the toplevel environment.
+ * $Id: init.in,v 1.1 2007/06/28 19:47:26 rjones Exp $
+ * - Removes the Pervasives module and any dangerous functions.
+ * - Loads just the modules we want to give access to, and just
+ * the functions within those modules that we want to give.
+ * - Sets up our custom camlp4 grammar which removes "external"
+ * keyword.
+ * - Chroot to somewhere safe.
+ *)
+
+(* Remove the Pervasives module. *)
+module Pervasives = struct end;;
+
+(* Remove any unsafe imported functions. *)
+let open_out = ()
+let open_out_bin = ()
+let open_out_gen = ()
+let flush = ()
+let flush_all = ()
+let output_value = ()
+let seek_out = ()
+let close_out = ()
+let close_out_noerr = ()
+let set_binary_mode_out = ()
+
+let open_in = ()
+let open_in_bin = ()
+let open_in_gen = ()
+let input_char = ()
+let input_line = ()
+let input = ()
+let really_input = ()
+let input_byte = ()
+let input_binary_int = ()
+let input_value = ()
+let seek_in = ()
+let pos_in = ()
+let in_channel_length = ()
+let close_in = ()
+let close_in_noerr = ()
+let set_binary_mode_in = ()
+
+module LargeFile = struct end;;
+
+(* let exit = () -- do this later *)
+let at_exit = ()
+let valid_float_lexem = ()
+let unsafe_really_input = ()
+let do_at_exit = ()
+
+(* Allow the List function. *)
+module List : sig
+ val length : 'a list -> int
+ val hd : 'a list -> 'a
+ val tl : 'a list -> 'a list
+ val nth : 'a list -> int -> 'a
+ val rev : 'a list -> 'a list
+ val append : 'a list -> 'a list -> 'a list
+ val rev_append : 'a list -> 'a list -> 'a list
+ val concat : 'a list list -> 'a list
+ val flatten : 'a list list -> 'a list
+ val iter : ('a -> unit) -> 'a list -> unit
+ val map : ('a -> 'b) -> 'a list -> 'b list
+ val rev_map : ('a -> 'b) -> 'a list -> 'b list
+ val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
+ val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
+ val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+ val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+ val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+ val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
+ val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
+ val for_all : ('a -> bool) -> 'a list -> bool
+ val exists : ('a -> bool) -> 'a list -> bool
+ val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+ val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+ val mem : 'a -> 'a list -> bool
+ val memq : 'a -> 'a list -> bool
+ val find : ('a -> bool) -> 'a list -> 'a
+ val filter : ('a -> bool) -> 'a list -> 'a list
+ val find_all : ('a -> bool) -> 'a list -> 'a list
+ val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
+ val assoc : 'a -> ('a * 'b) list -> 'b
+ val assq : 'a -> ('a * 'b) list -> 'b
+ val mem_assoc : 'a -> ('a * 'b) list -> bool
+ val mem_assq : 'a -> ('a * 'b) list -> bool
+ val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
+ val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
+ val split : ('a * 'b) list -> 'a list * 'b list
+ val combine : 'a list -> 'b list -> ('a * 'b) list
+ val sort : ('a -> 'a -> int) -> 'a list -> 'a list
+ val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+ val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+ val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+end = struct include List end
+
+(* Allow only safe functions from String. *)
+module String : sig
+ external length : string -> int = "%string_length"
+ external get : string -> int -> char = "%string_safe_get"
+ external set : string -> int -> char -> unit = "%string_safe_set"
+ external create : int -> string = "caml_create_string"
+ val make : int -> char -> string
+ val copy : string -> string
+ val sub : string -> int -> int -> string
+ val fill : string -> int -> int -> char -> unit
+ val blit : string -> int -> string -> int -> int -> unit
+ val concat : string -> string list -> string
+ val iter : (char -> unit) -> string -> unit
+ val escaped : string -> string
+ val index : string -> char -> int
+ val rindex : string -> char -> int
+ val index_from : string -> int -> char -> int
+ val rindex_from : string -> int -> char -> int
+ val contains : string -> char -> bool
+ val contains_from : string -> int -> char -> bool
+ val rcontains_from : string -> int -> char -> bool
+ val uppercase : string -> string
+ val lowercase : string -> string
+ val capitalize : string -> string
+ val uncapitalize : string -> string
+ type t = string
+ val compare: t -> t -> int
+end = struct include String end
+
+(* Load our custom grammar, which disables "external". *)
+
+#load "camlp4o.cma";;
+#load "./pa_noexternal.cmo";;
+
+(* Chroot and setuid to nobody. If this fails, die. *)
+#load "unix.cma";;
+let () =
+ try
+ let pw = Unix.getpwnam "@OCAMLUSER@" in
+ Unix.chdir "@CHROOTDIR@";
+ Unix.chroot "@CHROOTDIR@";
+ Unix.setgid pw.Unix.pw_gid;
+ Unix.setuid pw.Unix.pw_uid
+ with
+ exn ->
+ print_endline (Printexc.to_string exn);
+ exit 1
+
+(* Kill the Unix and UnixLabels modules, and exit function. *)
+module Unix = struct end
+module UnixLabels = struct end
+let exit = ()