init.in

   1 (* Initialise the toplevel environment. -*- tuareg -*-
   2  * $Id: init.in,v 1.9 2010/04/04 19:38:40 rjones Exp $
   3  * - Removes the Pervasives module and any dangerous functions.
   4  * - Loads just the modules we want to give access to, and just
   5  *   the functions within those modules that we want to give.
   6  * - Sets up our custom camlp4 grammar which removes "external"
   7  *   keyword.
   8  * - Chroot to somewhere safe.
   9  *)
  10
  11 (* Load some libraries. *)
  12 #load "dynlink.cma";;
  13 #load "nums.cma";;
  14 #load "unix.cma";;
  15 #load "str.cma";;
  16
  17 (* Remove the Pervasives module. *)
  18 module Pervasives = struct end;;
  19
  20 (* Remove any unsafe imported functions. *)
  21 let open_out = ()
  22 let open_out_bin = ()
  23 let open_out_gen = ()
  24 let flush = ()
  25 let flush_all = ()
  26 let output_value = ()
  27 let seek_out = ()
  28 let close_out = ()
  29 let close_out_noerr = ()
  30 let set_binary_mode_out = ()
  31
  32 let open_in = ()
  33 let open_in_bin = ()
  34 let open_in_gen = ()
  35 let input_char = ()
  36 let input_line = ()
  37 let input = ()
  38 let really_input = ()
  39 let input_byte = ()
  40 let input_binary_int = ()
  41 let input_value = ()
  42 let seek_in = ()
  43 let pos_in = ()
  44 let in_channel_length = ()
  45 let close_in = ()
  46 let close_in_noerr = ()
  47 let set_binary_mode_in = ()
  48
  49 module LargeFile = struct end;;
  50
  51 (* let exit = () -- do this later *)
  52 let at_exit = ()
  53 let valid_float_lexem = ()
  54 let unsafe_really_input = ()
  55 let do_at_exit = ()
  56
  57 (* Modules which have been checked and appear to be all safe. *)
  58 let _ = Big_int.zero_big_int
  59 let _ = Buffer.create
  60 let _ = Complex.zero
  61 let _ = Hashtbl.create
  62 let _ = Int32.to_string
  63 let _ = Int64.to_string
  64 let _ = Lazy.force
  65 let _ = List.length
  66 let _ = Nativeint.to_string
  67 let _ = Num.add_num
  68 let _ = Random.int
  69 let _ = Ratio.null_denominator
  70 let _ = Stack.create
  71 let _ = Str.regexp
  72
  73 (* Allow only safe functions from String. *)
  74 module String : sig
  75   external length : string -> int = "%string_length"
  76   external get : string -> int -> char = "%string_safe_get"
  77   external set : string -> int -> char -> unit = "%string_safe_set"
  78   external create : int -> string = "caml_create_string"
  79   val make : int -> char -> string
  80   val copy : string -> string
  81   val sub : string -> int -> int -> string
  82   val fill : string -> int -> int -> char -> unit
  83   val blit : string -> int -> string -> int -> int -> unit
  84   val concat : string -> string list -> string
  85   val iter : (char -> unit) -> string -> unit
  86   val escaped : string -> string
  87   val index : string -> char -> int
  88   val rindex : string -> char -> int
  89   val index_from : string -> int -> char -> int
  90   val rindex_from : string -> int -> char -> int
  91   val contains : string -> char -> bool
  92   val contains_from : string -> int -> char -> bool
  93   val rcontains_from : string -> int -> char -> bool
  94   val uppercase : string -> string
  95   val lowercase : string -> string
  96   val capitalize : string -> string
  97   val uncapitalize : string -> string
  98   type t = string
  99   val compare: t -> t -> int
 100 end = struct include String end
 101
 102 (* Allow only safe functions from Filename. *)
 103 module Filename : sig
 104   val current_dir_name : string
 105   val parent_dir_name : string
 106   val concat : string -> string -> string
 107   val is_relative : string -> bool
 108   val is_implicit : string -> bool
 109   val check_suffix : string -> string -> bool
 110   val chop_suffix : string -> string -> string
 111   val chop_extension : string -> string
 112   val basename : string -> string
 113   val dirname : string -> string
 114   val quote : string -> string
 115 end = struct include Filename end
 116
 117 (* Allow only safe functions from Char. *)
 118 module Char : sig
 119   external code : char -> int = "%identity"
 120   val chr : int -> char
 121   val escaped : char -> string
 122   val lowercase : char -> char
 123   val uppercase : char -> char
 124   type t = char
 125   val compare: t -> t -> int
 126 end = struct include Char end
 127
 128 (* Allow only safe functions from Array. *)
 129 module Array : sig
 130   external length : 'a array -> int = "%array_length"
 131   external get : 'a array -> int -> 'a = "%array_safe_get"
 132   external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
 133   external make : int -> 'a -> 'a array = "caml_make_vect"
 134   external create : int -> 'a -> 'a array = "caml_make_vect"
 135   val init : int -> (int -> 'a) -> 'a array
 136   val make_matrix : int -> int -> 'a -> 'a array array
 137   val create_matrix : int -> int -> 'a -> 'a array array
 138   val append : 'a array -> 'a array -> 'a array
 139   val concat : 'a array list -> 'a array
 140   val sub : 'a array -> int -> int -> 'a array
 141   val copy : 'a array -> 'a array
 142   val fill : 'a array -> int -> int -> 'a -> unit
 143   val blit : 'a array -> int -> 'a array -> int -> int -> unit
 144   val to_list : 'a array -> 'a list
 145   val of_list : 'a list -> 'a array
 146   val iter : ('a -> unit) -> 'a array -> unit
 147   val map : ('a -> 'b) -> 'a array -> 'b array
 148   val iteri : (int -> 'a -> unit) -> 'a array -> unit
 149   val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array
 150   val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
 151   val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
 152   val sort : ('a -> 'a -> int) -> 'a array -> unit
 153   val stable_sort : ('a -> 'a -> int) -> 'a array -> unit
 154   val fast_sort : ('a -> 'a -> int) -> 'a array -> unit
 155 end = struct include Array end
 156
 157 (* Allow only safe functions from Printf. *)
 158 module Printf : sig
 159   val printf : ('a, out_channel, unit) format -> 'a
 160   val sprintf : ('a, unit, string) format -> 'a
 161 end = struct include Printf end
 162
 163 (* Allow only safe functions from Scanf. *)
 164 module Scanf : sig
 165   module Scanning : sig
 166     type scanbuf;;
 167     val stdib : scanbuf;;
 168     val from_string : string -> scanbuf;;
 169     val from_function : (unit -> char) -> scanbuf;;
 170     val end_of_input : scanbuf -> bool;;
 171     val beginning_of_input : scanbuf -> bool;;
 172     val name_of_input : scanbuf -> string;;
 173   end;;
 174   exception Scan_failure of string;;
 175   type ('a, 'b, 'c, 'd) scanner =
 176        ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;;
 177   val bscanf : Scanning.scanbuf -> ('a, 'b, 'c, 'd) scanner;;
 178   val sscanf : string -> ('a, 'b, 'c, 'd) scanner;;
 179   val scanf : ('a, 'b, 'c, 'd) scanner;;
 180   val kscanf :
 181     Scanning.scanbuf -> (Scanning.scanbuf -> exn -> 'd) ->
 182       ('a, 'b, 'c, 'd) scanner;;
 183   val bscanf_format :
 184     Scanning.scanbuf -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
 185       (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;;
 186   val sscanf_format :
 187     string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
 188       (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;;
 189   val format_from_string :
 190     string ->
 191       ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6;;
 192 end = struct include Scanf end
 193
 194 (* Set and Map. *)
 195 module StringSet = Set.Make(String)
 196 module StringMap = Map.Make(String)
 197
 198 (* Create an object, so we get the CamlinternalOO module ... *)
 199 let _ = object end
 200
 201 (* ... but prevent public access to CamlinternalOO. *)
 202 module CamlinternalOO = struct end
 203
 204 #load "camlp4o.cma";;
 205 #load "./pa_noexternal.cmo";;
 206
 207 (* Chroot and setuid to nobody.  If this fails, die. *)
 208 let () =
 209   try
 210     let pw = Unix.getpwnam "@OCAMLUSER@" in
 211     Unix.chdir "@CHROOTDIR@";
 212     Unix.chroot "@CHROOTDIR@";
 213     Unix.setgid pw.Unix.pw_gid;
 214     Unix.setuid pw.Unix.pw_uid
 215   with
 216     exn ->
 217       print_endline (Printexc.to_string exn);
 218       exit 1
 219
 220 (* Kill the Unix and UnixLabels modules, and exit function. *)
 221 module Unix = struct end
 222 module UnixLabels = struct end
 223 let exit = ()