helm/software/components/library/librarian.ml

   1 (* Copyright (C) 2005, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://helm.cs.unibo.it/
  24  *)
  25
  26 let debug = false;;
  27
  28 let timestamp msg =
  29    if debug then
  30       let times = Unix.times () in
  31       let utime = times.Unix.tms_utime in
  32       let msg = Printf.sprintf "UTIMESTAMP (%s): %f" msg utime in
  33       prerr_endline msg
  34
  35 exception NoRootFor of string
  36
  37 let absolutize path =
  38  let path =
  39    if String.length path > 0 && path.[0] <> '/' then
  40      Sys.getcwd () ^ "/" ^ path
  41    else
  42      path
  43  in
  44    HExtlib.normalize_path path
  45 ;;
  46
  47
  48 let find_root path =
  49   let path = absolutize path in
  50   let paths = List.rev (Str.split (Str.regexp "/") path) in
  51   let rec build = function
  52     | he::tl as l -> ("/" ^ String.concat "/" (List.rev l) ^ "/") :: build tl
  53     | [] -> ["/"]
  54   in
  55   let paths = List.map HExtlib.normalize_path (build paths) in
  56   try HExtlib.find_in paths "root"
  57   with Failure "find_in" ->
  58     raise (NoRootFor (path ^ " (" ^ String.concat ", " paths ^ ")"))
  59 ;;
  60
  61 let ensure_trailing_slash s =
  62   if s = "" then "/" else
  63   if s.[String.length s-1] <> '/' then s^"/" else s
  64 ;;
  65
  66 let remove_trailing_slash s =
  67   if s = "" then "" else
  68   let len = String.length s in
  69   if s.[len-1] = '/' then String.sub s 0 (len-1) else s
  70 ;;
  71
  72 let load_root_file rootpath =
  73   let data = HExtlib.input_file rootpath in
  74   let lines = Str.split (Str.regexp "\n") data in
  75   let clean s =
  76     Pcre.replace ~pat:"[ \t]+" ~templ:" "
  77       (Pcre.replace ~pat:"^ *" (Pcre.replace ~pat:" *$" s))
  78   in
  79   List.map
  80     (fun l ->
  81       match Str.split (Str.regexp "=") l with
  82       | [k;v] -> clean k, Http_getter_misc.strip_trailing_slash (clean v)
  83       | _ -> raise (Failure ("Malformed root file: " ^ rootpath)))
  84     lines
  85 ;;
  86
  87 let rec find_root_for ~include_paths file =
  88  let include_paths = "" :: Sys.getcwd () :: include_paths in
  89  try
  90    let path = HExtlib.find_in include_paths file in
  91    let path = absolutize path in
  92 (*     HLog.debug ("file "^file^" resolved as "^path);  *)
  93    let rootpath, root, buri =
  94      try
  95        let mburi = Helm_registry.get "matita.baseuri" in
  96        match Str.split (Str.regexp " ") mburi with
  97        | [root; buri] when HExtlib.is_prefix_of root path ->
  98            ":registry:", root, buri
  99        | _ -> raise (Helm_registry.Key_not_found "matita.baseuri")
 100      with Helm_registry.Key_not_found "matita.baseuri" ->
 101        let rootpath = find_root path in
 102        let buri = List.assoc "baseuri" (load_root_file rootpath) in
 103        rootpath, Filename.dirname rootpath, buri
 104    in
 105 (*     HLog.debug ("file "^file^" rooted by "^rootpath^"");  *)
 106    let uri = Http_getter_misc.strip_trailing_slash buri in
 107    if String.length uri < 5 || String.sub uri 0 5 <> "cic:/" then
 108      HLog.error (rootpath ^ " sets an incorrect baseuri: " ^ buri);
 109    ensure_trailing_slash root, remove_trailing_slash uri, path
 110  with Failure "find_in" ->
 111    if Filename.check_suffix file ".ma" then begin
 112       let mma = Filename.chop_suffix file ".ma" ^ ".mma" in
 113       HLog.warn ("We look for: " ^ mma);
 114       find_root_for ~include_paths mma
 115    end else begin
 116       HLog.error ("We are in: " ^ Sys.getcwd ());
 117       HLog.error ("Unable to find: "^file^"\nPaths explored:");
 118       List.iter (fun x -> HLog.error (" - "^x)) include_paths;
 119       raise (NoRootFor file)
 120    end
 121 ;;
 122
 123 let mk_baseuri root extra =
 124   let chop name =
 125     assert(Filename.check_suffix name ".ma" ||
 126       Filename.check_suffix name ".mma");
 127     try Filename.chop_extension name
 128     with Invalid_argument "Filename.chop_extension" -> name
 129   in
 130    remove_trailing_slash (HExtlib.normalize_path (root ^ "/" ^ chop extra))
 131 ;;
 132
 133 let baseuri_of_script ~include_paths file =
 134   let root, buri, path = find_root_for ~include_paths file in
 135   let path = HExtlib.normalize_path path in
 136   let root = HExtlib.normalize_path root in
 137   let lpath = Str.split (Str.regexp "/") path in
 138   let lroot = Str.split (Str.regexp "/") root in
 139   let rec substract l1 l2 =
 140     match l1, l2 with
 141     | h1::tl1,h2::tl2 when h1 = h2 -> substract tl1 tl2
 142     | l,[] -> l
 143     | _ -> raise (NoRootFor (file ^" "^path^" "^root))
 144   in
 145   let extra_buri = substract lpath lroot in
 146   let extra = String.concat "/" extra_buri in
 147    root,
 148    mk_baseuri buri extra,
 149    path,
 150    extra
 151 ;;
 152
 153 let find_roots_in_dir dir =
 154   HExtlib.find ~test:(fun f ->
 155     Filename.basename f = "root" &&
 156     try (Unix.stat f).Unix.st_kind = Unix.S_REG
 157     with Unix.Unix_error _ -> false)
 158     dir
 159 ;;
 160
 161 (* make *)
 162 let load_deps_file f =
 163   let deps = ref [] in
 164   let ic = open_in f in
 165   try
 166     while true do
 167       begin
 168         let l = input_line ic in
 169         match Str.split (Str.regexp " ") l with
 170         | [] ->
 171             HLog.error ("Malformed deps file: " ^ f);
 172             raise (Failure ("Malformed deps file: " ^ f))
 173         | he::tl -> deps := (he,tl) :: !deps
 174       end
 175     done; !deps
 176     with End_of_file -> !deps
 177 ;;
 178
 179 type options = (string * string) list
 180
 181 module type Format =
 182   sig
 183     type source_object
 184     type target_object
 185     val load_deps_file: string -> (source_object * source_object list) list
 186     val string_of_source_object: source_object -> string
 187     val string_of_target_object: target_object -> string
 188     val build: options -> source_object -> bool
 189     val root_and_target_of:
 190           options -> source_object -> string option * target_object
 191     val mtime_of_source_object: source_object -> float option
 192     val mtime_of_target_object: target_object -> float option
 193     val is_readonly_buri_of: options -> source_object -> bool
 194   end
 195
 196 module Make = functor (F:Format) -> struct
 197
 198   type status = Done of bool
 199               | Ready of bool
 200
 201   let say s = if debug then prerr_endline ("make: "^s);;
 202
 203   let unopt_or_call x f y = match x with Some _ -> x | None -> f y;;
 204
 205   let fst4 = function (x,_,_,_) -> x;;
 206
 207   let younger_s_t (_,cs, ct, _, _) a b =
 208     let a = try Hashtbl.find cs a with Not_found -> assert false in
 209     let b =
 210       try
 211         match Hashtbl.find ct b with
 212         | Some _ as x -> x
 213         | None ->
 214            match F.mtime_of_target_object b with
 215            | Some t as x ->
 216                Hashtbl.remove ct b;
 217                Hashtbl.add ct b x; x
 218            | x -> x
 219       with Not_found -> assert false
 220     in
 221     match a, b with
 222     | Some a, Some b -> a < b
 223     | _ -> false
 224   ;;
 225
 226   let younger_t_t (_,_,ct, _, _) a b =
 227     let a =
 228       try
 229         match Hashtbl.find ct a with
 230         | Some _ as x -> x
 231         | None ->
 232            match F.mtime_of_target_object a with
 233            | Some t as x ->
 234                Hashtbl.remove ct b;
 235                Hashtbl.add ct a x; x
 236            | x -> x
 237       with Not_found -> assert false
 238     in
 239     let b =
 240       try
 241         match Hashtbl.find ct b with
 242         | Some _ as x -> x
 243         | None ->
 244            match F.mtime_of_target_object b with
 245            | Some t as x ->
 246                Hashtbl.remove ct b;
 247                Hashtbl.add ct b x; x
 248            | x -> x
 249       with Not_found -> assert false
 250     in
 251     match a, b with
 252     | Some a, Some b -> a < b
 253     | _ -> false
 254   ;;
 255
 256   let rec purge_unwanted_roots wanted deps =
 257     let roots, rest =
 258        List.partition
 259          (fun (t,d,_,_) ->
 260            not (List.exists (fun (_,d1,_,_) -> List.mem t d1) deps))
 261          deps
 262     in
 263     let newroots = List.filter (fun (t,_,_,_) -> List.mem t wanted) roots in
 264     if newroots = roots then
 265       deps
 266     else
 267       purge_unwanted_roots wanted (newroots @ rest)
 268   ;;
 269
 270   let is_not_ro (opts,_,_,_,_) (f,_,r,_) =
 271     match r with
 272     | Some root -> not (F.is_readonly_buri_of opts f)
 273     | None -> assert false
 274   ;;
 275
 276   let rec get_status opts what =
 277      let _, _, _, cc, cd = opts in
 278      let t, dependencies, root, tgt = what in
 279      try Done (Hashtbl.find cc t)
 280 (* say "already built" *)
 281      with Not_found ->
 282         let map st d = match st with
 283            | Done false  -> st
 284            | Ready false -> st
 285            | _           ->
 286               let whatd = Hashtbl.find cd d in
 287               let _, _, _, tgtd = whatd in
 288               begin match st, get_status opts whatd with
 289                  | _, Done false         -> Hashtbl.add cc t false; Done false
 290                  | Done true, Done true  ->
 291                     if younger_t_t opts tgt tgtd then Ready true else Done true
 292 (* say (F.string_of_source_object t^" depends on "^F.string_of_target_object unsat^" and "^F.string_of_source_object t^".o is younger than "^ F.string_of_target_object unsat^", thus needs to be built") *)
 293                  | Done true, Ready _    -> Ready false
 294                  | Ready true, Ready _   -> Ready false
 295 (* say (F.string_of_source_object t^" depends on "^ F.string_of_source_object (fst4 unsat)^ " that is not built, thus is not ready") *)
 296                  | Ready true, Done true -> Ready true
 297                  | _                     -> st
 298               end
 299         in
 300         let st = if younger_s_t opts t tgt then Done true else Ready true in
 301         match List.fold_left map st dependencies with
 302            | Done true -> Hashtbl.add cc t true; Done true
 303 (* say(F.string_of_source_object t^" is built" *)
 304            | st     -> st
 305
 306   let list_partition_filter_rev filter l =
 307      let rec aux l1 l2 = function
 308         | []       -> l1, l2
 309         | hd :: tl ->
 310            begin match filter hd with
 311               | None       -> aux l1 l2 tl
 312               | Some true  -> aux (hd :: l1) l2 tl
 313               | Some false -> aux l1 (hd :: l2) tl
 314            end
 315      in
 316      aux [] [] l
 317
 318   let rec make_aux root (lo,_,ct, cc, _ as opts) ok deps =
 319     timestamp "filter get_status: begin";
 320     let map what = match get_status opts what with
 321        | Done _  -> None
 322        | Ready b -> Some b
 323     in
 324     let todo, deps = list_partition_filter_rev map deps in
 325     timestamp "filter get_status: end";
 326     let todo =
 327       let local, remote =
 328         List.partition (fun (_,_,froot,_) -> froot = Some root) todo
 329       in
 330       let local, skipped = List.partition (is_not_ro opts) local in
 331       List.iter
 332        (fun x ->
 333         HLog.warn("Read only baseuri for: "^F.string_of_source_object(fst4 x)))
 334        skipped;
 335       remote @ local
 336     in
 337     if todo <> [] then begin
 338        let ok = List.fold_left
 339           (fun ok (file,_,froot,tgt) ->
 340             let rc =
 341               match froot with
 342               | Some froot when froot = root ->
 343                   Hashtbl.remove ct tgt;
 344                   Hashtbl.add ct tgt None;
 345                   timestamp "building";
 346                   let r = F.build lo file in
 347                   timestamp "done"; r
 348               | Some froot -> make froot [file]
 349               | None ->
 350                   HLog.error ("No root for: "^F.string_of_source_object file);
 351                   false
 352             in
 353             Hashtbl.add cc file rc;
 354             ok && rc
 355           )
 356           ok (List.rev todo)
 357        in
 358       make_aux root opts ok (List.rev deps)
 359     end
 360     else
 361       ok
 362
 363   and  make root targets =
 364     timestamp "entering";
 365     HLog.debug ("Entering directory '"^root^"'");
 366     let old_root = Sys.getcwd () in
 367     Sys.chdir root;
 368     let deps = F.load_deps_file (root^"/depends") in
 369     let local_options = load_root_file (root^"/root") in
 370     let caches,cachet,cachec,cached =
 371        Hashtbl.create 73, Hashtbl.create 73, Hashtbl.create 73, Hashtbl.create 73
 372     in
 373     (* deps are enriched with these informations to sped up things later *)
 374     let deps =
 375       List.map
 376         (fun (file,d) ->
 377           let r,tgt = F.root_and_target_of local_options file in
 378           Hashtbl.add caches file (F.mtime_of_source_object file);
 379           Hashtbl.add cachet tgt (F.mtime_of_target_object tgt);
 380           Hashtbl.add cached file (file, d, r, tgt);
 381           (file, d, r, tgt)
 382         )
 383         deps
 384     in
 385     let opts = local_options, caches, cachet, cachec, cached in
 386     let ok =
 387       if targets = [] then
 388         make_aux root opts true deps
 389       else
 390         make_aux root opts true
 391           (purge_unwanted_roots targets deps)
 392     in
 393     HLog.debug ("Leaving directory '"^root^"'");
 394     Sys.chdir old_root;
 395     timestamp "leaving";
 396     ok
 397   ;;
 398
 399 end
 400
 401 let write_deps_file where deps = match where with
 402    | Some root ->
 403       let oc = open_out (root ^ "/depends") in
 404       let map (t, d) = output_string oc (t^" "^String.concat " " d^"\n") in
 405       List.iter map deps; close_out oc;
 406       HLog.message ("Generated: " ^ root ^ "/depends")
 407    | None ->
 408       print_endline (String.concat " " (List.flatten (List.map snd deps)))
 409
 410 (* FG ***********************************************************************)
 411
 412 (* scheme uri part as defined in URI Generic Syntax (RFC 3986) *)
 413 let uri_scheme_rex = Pcre.regexp "^[[:alpha:]][[:alnum:]\-+.]*:"
 414
 415 let is_uri str =
 416    Pcre.pmatch ~rex:uri_scheme_rex str