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 modified_before_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 modified_before_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 (* FG: Old sorting algorithm ************************************************)
 276 (*
 277   let rec get_status opts what =
 278      let _, _, _, cc, cd = opts in
 279      let t, dependencies, root, tgt = what in
 280      try Done (Hashtbl.find cc t)
 281 (* say "already built" *)
 282      with Not_found ->
 283         let map st d = match st with
 284            | Done false  -> st
 285            | Ready false -> st
 286            | _           ->
 287               let whatd = Hashtbl.find cd d in
 288               let _, _, _, tgtd = whatd in
 289               begin match st, get_status opts whatd with
 290                  | _, Done false         -> Hashtbl.add cc t false; Done false
 291                  | Done true, Done true  ->
 292                     if modified_before_t_t opts tgt tgtd then Ready true else Done true
 293 (* 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") *)
 294                  | Done true, Ready _    -> Ready false
 295                  | Ready true, Ready _   -> Ready false
 296 (* say (F.string_of_source_object t^" depends on "^ F.string_of_source_object (fst4 unsat)^ " that is not built, thus is not ready") *)
 297                  | Ready true, Done true -> Ready true
 298                  | _                     -> st
 299               end
 300         in
 301         let st = if modified_before_s_t opts t tgt then Done true else Ready true in
 302         match List.fold_left map st dependencies with
 303            | Done true -> Hashtbl.add cc t true; Done true
 304 (* say(F.string_of_source_object t^" is built" *)
 305            | st     -> st
 306
 307   let list_partition_filter_rev filter l =
 308      let rec aux l1 l2 = function
 309         | []       -> l1, l2
 310         | hd :: tl ->
 311            begin match filter hd with
 312               | None       -> aux l1 l2 tl
 313               | Some true  -> aux (hd :: l1) l2 tl
 314               | Some false -> aux l1 (hd :: l2) tl
 315            end
 316      in
 317      aux [] [] l
 318
 319   let rec make_aux root (lo,_,ct, cc, _ as opts) ok deps =
 320     timestamp "filter get_status: begin";
 321     let map what = match get_status opts what with
 322        | Done _  -> None
 323        | Ready b -> Some b
 324     in
 325     let todo, deps = list_partition_filter_rev map deps in
 326     timestamp "filter get_status: end";
 327     let todo =
 328       let local, remote =
 329         List.partition (fun (_,_,froot,_) -> froot = Some root) todo
 330       in
 331       let local, skipped = List.partition (is_not_ro opts) local in
 332       List.iter
 333        (fun x ->
 334         HLog.warn("Read only baseuri for: "^F.string_of_source_object(fst4 x)))
 335        skipped;
 336       remote @ local
 337     in
 338     if todo <> [] then begin
 339        let ok = List.fold_left
 340           (fun ok (file,_,froot,tgt) ->
 341             let rc =
 342               match froot with
 343               | Some froot when froot = root ->
 344                   Hashtbl.remove ct tgt;
 345                   Hashtbl.add ct tgt None;
 346                   timestamp "building";
 347                   let r = F.build lo file in
 348                   timestamp "done"; r
 349               | Some froot -> make froot [file]
 350               | None ->
 351                   HLog.error ("No root for: "^F.string_of_source_object file);
 352                   false
 353             in
 354             Hashtbl.add cc file rc;
 355             ok && rc
 356           )
 357           ok (List.rev todo)
 358        in
 359       make_aux root opts ok (List.rev deps)
 360     end
 361     else
 362       ok
 363 *)
 364 (* FG: new sorting algorithm ************************************************)
 365
 366   let rec make_aux root opts ok deps =
 367     List.fold_left (make_one root opts) ok deps
 368
 369   and make_one root opts ok what =
 370     let lo, _, ct, cc, cd = opts in
 371     let t, deps, froot, tgt = what in
 372     let map (okd, okt) d =
 373        let (_, _, _, tgtd) as whatd = (Hashtbl.find cd d) in
 374        make_one root opts okd whatd, okt && modified_before_t_t opts tgtd tgt
 375     in
 376     try ok && Hashtbl.find cc t
 377 (* say "already built" *)
 378     with Not_found ->
 379        let okd, okt = List.fold_left map (true, modified_before_s_t opts t tgt) deps in
 380        let res =
 381           if okd then
 382           if okt then true else
 383           let str = F.string_of_source_object t in
 384           match froot with
 385              | Some froot when froot = root ->
 386                 if is_not_ro opts what then begin
 387                    Hashtbl.remove ct tgt;
 388                    Hashtbl.add ct tgt None;
 389                    timestamp "building";
 390                    let res = F.build lo t in
 391                    timestamp "done"; res
 392                 end else begin
 393                    HLog.warn("Read only baseuri for: "^ str); false
 394                 end
 395              | Some froot -> make froot [t]
 396              | None ->
 397                 HLog.error ("No root for: " ^ str); false
 398           else false
 399        in
 400        Hashtbl.add cc t res; ok && res
 401
 402 (****************************************************************************)
 403
 404   and make root targets =
 405     timestamp "entering";
 406     HLog.debug ("Entering directory '"^root^"'");
 407     let old_root = Sys.getcwd () in
 408     Sys.chdir root;
 409     let deps = F.load_deps_file (root^"/depends") in
 410     let local_options = load_root_file (root^"/root") in
 411     let caches,cachet,cachec,cached =
 412        Hashtbl.create 73, Hashtbl.create 73, Hashtbl.create 73, Hashtbl.create 73
 413     in
 414     (* deps are enriched with these informations to sped up things later *)
 415     let deps =
 416       List.map
 417         (fun (file,d) ->
 418           let r,tgt = F.root_and_target_of local_options file in
 419           Hashtbl.add caches file (F.mtime_of_source_object file);
 420           Hashtbl.add cachet tgt (F.mtime_of_target_object tgt);
 421           Hashtbl.add cached file (file, d, r, tgt);
 422           (file, d, r, tgt)
 423         )
 424         deps
 425     in
 426     let opts = local_options, caches, cachet, cachec, cached in
 427     let ok =
 428       if targets = [] then
 429         make_aux root opts true deps
 430       else
 431         make_aux root opts true
 432           (purge_unwanted_roots targets deps)
 433     in
 434     HLog.debug ("Leaving directory '"^root^"'");
 435     Sys.chdir old_root;
 436     timestamp "leaving";
 437     ok
 438   ;;
 439
 440 end
 441
 442 let write_deps_file where deps = match where with
 443    | Some root ->
 444       let oc = open_out (root ^ "/depends") in
 445       let map (t, d) = output_string oc (t^" "^String.concat " " d^"\n") in
 446       List.iter map deps; close_out oc;
 447       HLog.message ("Generated: " ^ root ^ "/depends")
 448    | None ->
 449       print_endline (String.concat " " (List.flatten (List.map snd deps)))
 450
 451 (* FG ***********************************************************************)
 452
 453 (* scheme uri part as defined in URI Generic Syntax (RFC 3986) *)
 454 let uri_scheme_rex = Pcre.regexp "^[[:alpha:]][[:alnum:]\-+.]*:"
 455
 456 let is_uri str =
 457    Pcre.pmatch ~rex:uri_scheme_rex str