Source

rebildol / src / post_template.ml

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600

open Venvs

open Printf
open Unix

open Reb_sys


(**********************************************************)

let depdbg fmt = Printf.ifprintf () fmt

let ( !! ) = Lazy.force

module Do_rebuild
  (Cfg :
     sig
       val buildconf_prefix : string
       val buildconf_work_src : string
     end
  ) =
struct

  open Cfg

  module Context : CONTEXT =
    struct

      let prefix = buildconf_prefix

      let var n =
        match n with
        | "prefix" -> prefix
        | "bindir" -> prefix </> "bin"
        | "datadir" -> prefix </> "share"
        | n -> failwith "var: unknown variable %S" n

    end

  (* when 'rebuild all', *)
  let () =
    ( Reb_sys.rm_rf buildconf_work_src
    ; Reb_sys.rm_rf buildconf_prefix
    ; create_dest_in buildconf_prefix
    ; assure_dir buildconf_work_src
    )

  let work_dir_of_pkg_name n =
    string_map
      (fun c ->
         match c with
         | 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' | '-' -> c
         | _ -> '_'
      )
      n

  type pkgdesc =
    { p_pkg_name : string
    ; p_provides : pkg list
    ; p_requires : requires
    ; p_is_installed : pkg (* one of [provides] *) -> bool
    ; p_install : action
    ; p_uninstall : action
    ; p_source : source
    ; p_pkg_work_dir : string
    }

  let pkgdescs = ref []

  let pkgdesc p =
    try List.assoc p !pkgdescs
    with Not_found -> failwith "can't find pkgdesc of package %S" (Pkg.name p)

  module Store_pkgdesc (P : PKGDESC) =
    struct
      let r =
        let pd =
          { p_pkg_name = P.pkg_name
          ; p_provides = P.provides_pkgs
          ; p_requires = P.requires
          ; p_is_installed = P.is_installed
          ; p_install = P.install
          ; p_uninstall = P.uninstall
          ; p_source = P.source
          ; p_pkg_work_dir = work_dir_of_pkg_name P.pkg_name
          }
        in
          pkgdescs := (List.map (fun p -> (p, pd)) pd.p_provides) @ !pkgdescs
    end

  module Store_res = PkgList(Context)(Store_pkgdesc)


  let () =
    List.iter
      (fun (p1, pd1) ->
         List.iter
           (fun (p2, pd2) ->
              if pd1.p_pkg_work_dir = pd2.p_pkg_work_dir
                 && pd1 != pd2
              then
                failwith "different packages %S and %S have the same \
                          work directory %S.  (now it's error.)"
                         (Pkg.dump p1) (Pkg.dump p2) pd1.p_pkg_work_dir
              else
                ()
           )
           !pkgdescs
      )
      !pkgdescs


  module Cache
   =
    struct

      let cachedbg fmt = Printf.ksprintf
        (Printf.eprintf "DBG/cache: %s\n%!") fmt

      let cache_prefix = lazy
        (try (Sys.getenv "HOME") </> ".cache/rebildol"
         with | Not_found -> failwith "no $HOME environment variable"
        )

      let is_dir d = Sys.file_exists d && Sys.is_directory d

      let get_cache_dir kind =
        lazy
          (try
             let prefix = !!cache_prefix in
             let dir = prefix </> kind in
             if is_dir prefix && is_dir dir
             then
               let () = cachedbg "found dir %S, using to cache %s"
                 dir kind
               in
               Some dir
             else
               let () = cachedbg "can't find dir %S, won't cache %s"
                 dir kind
               in
               None
           with
           | e -> ( cachedbg "error looking for cache for %s: %s \
                              (so, no caching)"
                      kind (Printexc.to_string e)
                  ; None
                  )
          )

      let cache_dir_files = get_cache_dir "files"

      let cache_dir_repos = get_cache_dir "repos"


      let get_sources_cache pd ~dest ~rkind ~dlfunc ~cachedir =
(*
        .

        учитывать, что source = `Remote и s_kind = `Dir -- assert false
*)
( ignore pd ; ignore dest ; ignore rkind ; ignore dlfunc ; ignore cachedir ; failwith "qwe" )



      let get_sources_no_cache pd ~dest ~s_download =
        let pkg_name = pd.p_pkg_name in
        let () = cachedbg "getting source of package %S without cache"
          pkg_name
        in
        let s_extract = pd.p_source.s_extract
        in
            (* let () = assert_dir dest in *)
            let local_path =
              match s_download with
              | `Local path ->
                  let () = cachedbg "package %S is local, path %S"
                    pkg_name path
                  in
                  path
              | `Remote (_kind, dlfunc) ->
                  let () = cachedbg "package %S is remote, downloading"
                    pkg_name
                  in
                  let path = dlfunc ~dl_dest:dest in
                  let () = cachedbg "package %S downloaded to %S"
                    pkg_name path in
                  path
            in
            let () = cachedbg "extracting %S to %S" local_path dest
            in
            let extract_res = s_extract ~path:local_path ~dest in
            let () =
              match s_download with
              | `Remote (rkind, _) ->
                  begin
                  match rkind with
                  | `File ->
                      let () = cachedbg "package %S was remote file, \
                                         cleaning local \
                                         downloaded file %S"
                        pkg_name local_path
                      in
                      Sys.remove local_path
                  | `Dir | `Repo ->
                      if extract_res = local_path
                      then
                        let () = cachedbg "package %S was remote repo, but \
                                           extracted \
                                           to required dir %S, not cleaning"
                          pkg_name extract_res
                        in
                        ()
                      else
                        let () = cachedbg "package %S was remote repo, \
                                           extracted \
                                           to \
                                           temporary dir %S, so cleaning it"
                                   pkg_name local_path
                        in
                        Reb_sys.rm_rf local_path
                  end
              | `Local _local_name ->
                  let () = cachedbg "package %S was local, not cleaning"
                    pkg_name
                  in
                  ()
            in
              extract_res


      let get_sources pd ~dest =
        let pkg_name = pd.p_pkg_name in
        let () = cachedbg "getting sources of %S" pkg_name in
        match pd.p_source.s_download with
        | `No -> failwith "no sources for package %S" pkg_name
        | (`Local _ | `Remote _) as s_download ->
            let no_cache () = get_sources_no_cache pd ~dest ~s_download in
            match s_download with
            | `Local _ -> no_cache ()
            | `Remote (rkind, dlfunc) ->
                let cache_dir_opt =
                  (match rkind with
                   | `File -> !!cache_dir_files
                   | `Repo -> !!cache_dir_repos
                  )
                in
                  (match cache_dir_opt with
                   | None -> no_cache ()
                   | Some cachedir ->
                       get_sources_cache pd ~dest ~rkind ~dlfunc ~cachedir
                  )

    end


  module Build_state = struct

    type pkg_build_state =
      | No
      | Sources of string (* path to sources work copy *)
      | Installed of string (* too; but sources are dirty *)

    type build_state = (pkgdesc * pkg_build_state) list

  end  (* module Build_state *)
  open Build_state


  let bs = ref []

  let bs_get_state pd =
    try List.assq pd !bs with Not_found -> No

  let bs_set_state pd s =
    bs := (pd, s) :: List.remove_assq pd !bs

  let bs_is_installed pd =
    match bs_get_state pd with
    | No | Sources _ -> false
    | Installed _ -> true

  let bs_sources pd =
   try
    match bs_get_state pd with
    | Installed _ -> failwith
        "bs_sources shouldn't be queried when package is installed"
    | Sources s -> s
    | No ->
        let src_dir = buildconf_work_src </> pd.p_pkg_work_dir in
        ( assure_dir buildconf_work_src
        ; assure_empty_dir src_dir
        ; let res = Cache.get_sources pd ~dest:src_dir in
          let () = bs_set_state pd (Sources res) in
          res
        )
   with
   | e -> failchain e "error getting sources of package %S" pd.p_pkg_name

  let pkgdesc_requires = ref []

  let get_requires pd =
    if List.mem_assq pd !pkgdesc_requires
    then
      let () = depdbg "get_requires of %S: already computed" pd.p_pkg_name in
      List.assq pd !pkgdesc_requires
    else
      let v =
        match pd.p_requires with
        | Reqs_static lst ->
            let () = depdbg "get_requires of %S: static"
              pd.p_pkg_name in
            lst
        | Reqs_dynamic f ->
            let s = bs_sources pd in
            with_chdir s
              (fun () ->
                 try
                   let () = depdbg "get_requires of %S: dyn: computing now"
                     pd.p_pkg_name in
                   f ()
                 with
                 | e -> failchain e
                    "error getting build depends of package %S"
                    pd.p_pkg_name
              )
      in
      ( pkgdesc_requires := (pd, v) :: !pkgdesc_requires
      ; v
      )

  let with_pkg_sources pd f =
    let src_dir = bs_sources pd in
    with_chdir src_dir
      (fun () -> f src_dir)

  let pkg_is_installed pd p =
    with_id
      (fun () -> pd.p_is_installed p)

  let pkg_install pd =
    with_pkg_sources pd
      (fun src_dir ->
         ( (try
              let () = dbg "installing %S from directory %S"
                pd.p_pkg_name src_dir
              in
              pd.p_install ()
            with
            | e -> failchain e "Error installing %S from directory %S"
                    pd.p_pkg_name src_dir
           )
         ; bs_set_state pd (Installed src_dir)
         )
      )

  let pkg_uninstall pd =
    match bs_get_state pd with
    | Installed _ -> failwith
        "rebildol doesn't support 'install;uninstall' now"
    | No | Sources _ ->
        with_pkg_sources pd
          (fun src_dir ->
             ( (try
                  let () = dbg "uninstalling %S from directory %S"
                    pd.p_pkg_name src_dir
                  in
                  pd.p_uninstall ()
                with
                | e -> failchain e "Error uninstalling %S from directory %S"
                        pd.p_pkg_name src_dir
               )
             )
          )


  type deps_node =
    { pd : pkgdesc
    ; extdeps : pkg list
    ; intdeps : pkg list
    }

  let lazyfix : ('a Lazy.t -> 'a) -> 'a = fun f ->
    let rec lazy_self = lazy (f lazy_self) in
    !!lazy_self


  let get_cycle stack curp =
    let cy = ref [curp]
    and found = ref false in
    ( Stack.iter
        (fun p' ->
           if !found
           then ()
           else
             ( cy := p' :: !cy
             ; found := (curp = p')
             )
        )
        stack
    ; if !found
      then List.rev !cy
      else []
    )

  let deps_graph_lazynodes =
    let stack = Stack.create () in
    let withstack p f =
      ( Stack.push p stack
      ; let r = f () in
        let popped = Stack.pop stack in
        let () = assert (p = popped) in
        r
      )
    in
    let dumpstack () =
      let l = ref [] in
      let () = Stack.iter (fun a -> l := a :: !l) stack in
      sprintf "stack:[%s]" (String.concat " ; " (List.rev_map Pkg.dump !l))
    in  
  lazyfix
    (fun self ->
        List.map
          (fun (p, pd) ->
              let () = depdbg "mapping %S" (Pkg.dump p) in
              ( p
              , lazy
                  (withstack p (fun () ->
                     let () = depdbg "forcing dn %S %s"
                       (Pkg.dump p) (dumpstack ()) in
                     let deps = get_requires pd in
                     let () = depdbg "got deps of %S: [%s]"
                        (Pkg.dump p)
                        (String.concat " ; " (List.map Pkg.dump deps)) in
                     let self = !!self in
                     let () = depdbg "b" in
                     let (intdeps, extdeps) = List.partition
                       (fun d -> List.mem_assoc d self) deps
                     in
                     let () = depdbg "forcing -- deps %S" (Pkg.dump p) in
                     let () =
                       List.iter  (* just for cycles *)
                         (fun intdep ->
                            let () = depdbg "c forcing %s->%s %s"
                              (Pkg.dump p) (Pkg.dump intdep) (dumpstack ()) in
                            let cycle = get_cycle stack intdep in
                            if cycle <> []
                            then failwith "found cycle in dependencies: [%s]"
                              (String.concat "; " (List.map Pkg.dump cycle))
                            else
                              let () =
                                ignore (Lazy.force (List.assoc intdep self))
                              in
                              let () = depdbg "d" in
                              ()
                         )
                         intdeps
                     in
                       { pd = pd
                       ; extdeps = extdeps
                       ; intdeps = intdeps
                       }
                  ))
              )
          )
          !pkgdescs
    )

  let () = depdbg "ln"

  let deps_graph =
    List.map
      (fun (p, lazynode) ->
         let () = depdbg "ln %s" (Pkg.dump p) in
         let r =
           (p, Lazy.force lazynode)
         in
         let () = depdbg "ln %s done" (Pkg.dump p) in
         r
      )
      deps_graph_lazynodes

  let () = depdbg "dg"

  let extdeps_found = Hashtbl.create 7
  (* key = p, value = is found*)

  let deps_not_found =
    ( List.iter
        (fun (p, dn) ->
           List.iter
             (fun extd ->
                if Hashtbl.mem extdeps_found extd
                then ()
                else
                  Hashtbl.replace extdeps_found extd
                    ((Findlib.have_pkg (Pkg.name extd)), p)
             )
             dn.extdeps
        )
        deps_graph
    ; Hashtbl.fold
        (fun extd (found, reqby) acc ->
           if not found then (extd, reqby) :: acc else acc
        )
        extdeps_found
        []
    )


  let r =
    match deps_not_found with
    | (_ :: _) as lst ->
        failwith
          "rebuild_all: can't find packages either in specified \
           package descriptions or in venvs, build will fail.\n\
           Here is the list:\n\
           %s\n\
           (required by, respectively, %s)"
           (String.concat " "
             (List.map (fun (p, _reqby) -> Pkg.dump p) lst))
           (String.concat " "
             (List.map (fun (_p, reqby) -> Pkg.dump reqby) lst))
    | [] ->
      (* no need to uninstall, since the whole buildconf_prefix is removed.
      let () =
        List.iter
          (fun (p, _dn) ->
             let () = dbg "trying to uninstall %S" (Pkg.dump p) in
             let pd = pkgdesc p in
             if pkg_is_installed pd p
             then
               (let () = dbg "uninstalling %S" (Pkg.dump p) in
                pkg_uninstall pd
               )
             else
               let () = dbg "not installed" in
               ()
          )
          deps_graph
      in
      *)
      let () =
        List.iter
          (let rec install_with_deps p =
             let pd = pkgdesc p in
             if bs_is_installed pd
             then ()
             else
               let intdeps = (List.assoc p deps_graph).intdeps in
               ( List.iter install_with_deps intdeps
               ; pkg_install pd
               )
           in
           fun (p, _) ->
             install_with_deps p
          )
          deps_graph
      in
        assert (List.for_all (fun (_p, pd) -> bs_is_installed pd) !pkgdescs)


end


let me = Sys.argv.(0)

let main_exn () =
  match List.tl (Array.to_list Sys.argv) with
  | [] | ("-help" | "--help") :: _ -> printf "\
 %s it's an auxilliary program generated and runned by rebuildol.  \
 Don't use it directly.\n\
"
    me

  | "rebuild" :: buildconf_prefix :: buildconf_work_src :: [] ->
       let module Q = Do_rebuild
         (struct
            let buildconf_prefix = buildconf_prefix
            let buildconf_work_src = buildconf_work_src
          end) in
       let () = ignore Q.r in
         ()

  | lst -> failwith "bad command line: [%s]" (String.concat "; " lst)


let main () =
  try
    main_exn ()
  with
  | e ->
      let msg =
        match e with
        | Failure e -> e
        | e -> Printexc.to_string e
      in
        ( eprintf "%s: %s\n%!" me msg; exit 1 )