Source

rebildol / src / pre_template.ml

  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
open Common

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

module Pkg
 :
  sig
    type pkg = private string  (* to be able to include version or like *)
    val of_string : string -> pkg
    val name : pkg -> string
    val dump : pkg -> string
  end
 =
  struct
    type pkg = string
    let check_name = String.iter
      (function
       | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9'
       | '.' | '-' | '_' -> ()
       | c ->
           failwith "error checking well-formedness of package name: \
                     character %C is not allowed.  (if it is really \
                     allowed, please fix rebildol's src/pre_template.ml)"
             c
      )
    let of_string s = (check_name s; s)
    let name s = s
    let dump = name
  end


type pkg = Pkg.pkg
type requires =
  | Reqs_static of pkg list
  | Reqs_dynamic of (unit -> pkg list)
type action = (unit -> unit)
type downloadfunc = (dl_dest:string (* directory *) -> string (* exact path *))
type md5hex = string
type digest = md5hex
type remote_file_info =
  { rf_base_name : string
  ; rf_digest : digest option
  }
type remote_repo_info =
  { rr_pull : unit -> bool
      (* executed in cachedir, returns true when pulling was successfu;
         (or wasn't needed), false if repo is wrong
       *)
  }
type source =
  { s_download :
      [ `No
      | `Local of string
      | `Remote of [ `File of remote_file_info
                   | `Repo of remote_repo_info
                   ]
                 * downloadfunc
      ]
  ; s_extract : ( path:string (* exact path *) ->
                  dest:string (* somewhere in work dir *) ->
                  string (* extracted to *)
                )
  }


module Provides
 =
  struct
    let one (n : string) = [n]
    let list (l : string list) = l
  end

module Requires
 :
  sig
    val none : requires
    val list : string list -> requires
    val see_oasis : requires
  end
 =
  struct

    (* will be executed in the root of the project *)

    let pkgs_of_strings = List.map Pkg.of_string

    let list (x : string list) =
      Reqs_static (pkgs_of_strings x)

    let none = list []

    let see_oasis =
      Reqs_dynamic
        (fun () ->
           try
             pkgs_of_strings
               (Oasis.get_build_deps ())
           with
           | e -> failchain e "Requires.see_oasis"
        )

  end


module Is_installed
 =
  struct
    let findlib_pkg (p : pkg) =
      Findlib.have_pkg (Pkg.name p)
  end


let make_gen ~opts funcname targets =
  let check_target =
    String.iter
      (function
       | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9'
       | '.' | '-' | '_' -> ()
       | c ->
           failwith "error checking well-formedness of 'make' target: \
                     character %C is not allowed.  (if it is really \
                     allowed, please fix rebildol's src/pre_template.ml)"
             c
      )
in
let () = List.iter check_target targets in
fun () ->
  let () =
    List.iter
      (fun target ->
         let () = Printf.printf "%s: building target %S\n%!" funcname
           target
         in
         let argv =
           Array.of_list
             ( [Reb_sys.make_exe]
             @ opts
             @ (if target = "" then [] else [target])
             )
         in
         if 0 = Reb_sys.run ~show:true argv
         then ()
         else failwith "%s: failed to build target %S with command %s"
                funcname target (Reb_sys.dump_argv argv)
      )
      targets
  in
    Printf.printf "%s: done\n%!" funcname


let ( ( >> ) : action -> action -> action) = fun act1 act2 ->
  fun () -> let () = act1 () in (act2 () : unit)


module Cond
 :
  sig
    type cond
    val of_bool : bool -> cond
    val is_file : string -> cond
    val if_ : cond -> action -> action -> action
  end
 =
  struct
    type cond = unit -> bool
    let of_bool b () = b
    let is_file n = fun () ->
      Sys.file_exists n && not (Sys.is_directory n)
    let if_ cond th el =
      fun () ->
        if cond () then th () else el ()
  end


module Install
 :
  sig
    val configure : string list (* args *) -> action
    val make : ?opts:string list -> string list (* targets *)
               -> action
    val none : action
    val run : string list -> action
    val patch : ?p:int -> string -> action
  end
 =
  struct
    open Unix

    let none () = ()

    let stat_opt n =
      try Some (Unix.stat n)
      with
      | Unix_error (ENOENT, "stat", _) -> None

    let configure args =
      (fun () ->
         let fn = "./configure" in
         match stat_opt fn with
         | None -> failwith "Install.configure: file %S not found" fn
         | Some st ->
             let argv =
               if st.st_perm land 0o111 <> 0
               then fn :: args
               else "/bin/sh" :: fn :: args
             in
               match Reb_sys.run ~show:true (Array.of_list argv) with
               | 0 -> ()
               | c -> failwith "Install.configure: failed with code %i" c
      )

    let make ?(opts=[]) targets = (make_gen ~opts "Install.make" targets)

    let run argv =
      let argv = Array.of_list argv in
      fun () ->
        match Reb_sys.run ~show:true argv with
        | 0 -> ()
        | c -> failwith "Install.run: command %s exited with code %i"
                 (Reb_sys.dump_argv argv) c

    let patch ?(p=1) patchfn = fun () ->
      try
        let pfd = openfile patchfn [O_RDONLY] 0 in
        let finally () = close pfd in
        let c = Reb_sys.run_gen ~stdin:pfd ~show:true
          [| "patch" ; Printf.sprintf "-p%i" p |] in
        let () =
          match c with
          | 0 -> ()
          | c -> ( finally ()
                 ; failwith "\"patch\" command exited with code %i" c
                 )
        in
        finally ()
      with
      | e -> failchain e "Install.patch: error applying patch -p%i %S in \
                          directory %S"
               p patchfn (Sys.getcwd ())

  end


module Uninstall
 :
  sig
    val make : ?opts:string list -> string list -> action
    val none : action
    val ocamlfind_remove : string list -> action
  end
 =
  struct
    let none () = ()
    let make ?(opts=[]) targets = (make_gen ~opts "Uninstall.make" targets)
    let ocamlfind_remove lst () =
      List.iter
        (fun p ->
           let argv = [| "ocamlfind"; "remove"; p |] in
           if 0 = Reb_sys.run ~show:true argv
           then ()
           else failwith "Uninstall.ocamlfind_remove failed (command: %s)"
             (Reb_sys.dump_argv argv)
        )
        lst
  end


type rev_spec = [ `Tip | `Branch of string | `Rev of string ]

module Source
 :
  sig
    val none : source

    val hg : ?rev:rev_spec -> string -> source

    val local_tar_gz : string -> source
    val local_tar_bz2 : string -> source
    val local_dir : string -> source
    val remote_tar_gz : ?md5:string -> string -> source
    val remote_tar_bz2 : ?md5:string -> string -> source
  end
 =
  struct

    (* source values are applied when ~dest directory exists and it is empty *)


    let none =
      { s_download = `No
      ; s_extract =
          (fun ~path ~dest ->
             ( ignore path
             ; ignore dest
             ; failwith "Source.none: extract: no source specified"
             )
          )
      }


    let is_local n = not (has_substring n "://")

    let last_component_of_uri u =
      let (_pre, post) = split_by_last ( (=) '/' ) u in
      if post = ""
      then
        failwith "can't determine last component of uri %S" u
      else
        post


    let hg ?(rev=`Tip) repo =
      let rev_txt =
        match rev with
        | `Tip -> "tip"
        | `Branch n -> Printf.sprintf "branch %S" n
        | `Rev n -> Printf.sprintf "revision %S" n
      in
      let clone ~workcopy ~src ~dest =
           let argv = Array.of_list
             ( [ "hg" ; "clone" ]
             @ (match rev with
                | `Tip -> []
                | `Branch n -> [ "-b" ; n ]
                | `Rev n -> [ "-r" ; n ]
               )
             @ (if workcopy
                then []
                else [ "--noupdate" ]
               )
             @ [ src ; dest ]
             )
           in
           if 0 = Reb_sys.run ~show:true argv
           then
             let () = dbg "hg ident after cloning: %s"
               (try
                  List.hd
                    (Reb_sys.lines_of_process
                       (Printf.sprintf "hg -R %s ident"
                          (Filename.quote dest)
                       )
                    )
                with
                | _ -> "can't get ident"
               )
             in
               dest
           else
             failwith "can't clone mercurial repository with command %s"
               (Reb_sys.dump_argv argv)
      in
      { s_download =
         (if is_local repo
          then
            `Local repo
          else
            `Remote
              ( (`Repo
                   { rr_pull =
                       (fun () ->
                          0 = Reb_sys.run ~show:true
                            (Array.of_list
                               ( [ "hg" ; "pull" ]
                               @ (match rev with
                                  | `Tip -> []
                                  | `Rev n -> [ "-r" ; n ]
                                  | `Branch n -> [ "-b" ; n ]
                                 )
                               )
                            )
                       )
                   }
                )
              ,
                (fun ~dl_dest ->
                   let () = dbg "Source.hg: download: cloning %S (%S) \
                                 to %S without workcopy"
                     repo rev_txt dl_dest
                   in
                   clone ~src:repo ~dest:dl_dest ~workcopy:false
                )
              )
         )
      ; s_extract =
          (fun ~path ~dest ->
             if path = dest
             then
               Reb_sys.with_chdir dest
                 (fun () ->
                    ( dbg "Source.hg: extract: updating to %S \
                           inplace (pwd = %S)"
                          rev_txt (Sys.getcwd ())
                    ; Reb_sys.run_ok ~show:true [| "hg" ; "update" |]
                    ; dest
                    )
                 )
             else
               ( dbg "Source.hg: extract: fair cloning %S (%S) to %S"
                   path rev_txt dest
               ; clone ~src:path ~dest ~workcopy:true
               )
          )
      }

    let get_one_dir dest =
      match Sys.readdir dest with
      | [| x |] ->
          let fullpath = dest </> x in
          if Sys.is_directory fullpath
          then fullpath
          else failwith "'destination directory' should contain one directory"
      | arr -> failwith "'destination directory' has %i directory entries, \
                         but expected only one directory"
                        (Array.length arr)

    let local_tar_archive ~tar_extr_arg ~funcname ~path =
        (fun ~dest ->
           let infn = path in
           try
             if Sys.readdir dest <> [| |]
             then failwith "destination directory is not empty"
             else
               let infn_abs = Reb_sys.path_abs infn in
               let () =
                 Reb_sys.with_chdir dest
                   (fun () ->
                      if 0 = Reb_sys.run ~show:true
                        [| "tar" ; tar_extr_arg ; infn_abs |]
                      then ()
                      else failwith "error from 'tar %s'" tar_extr_arg
                   )
               in
               get_one_dir dest
           with
           | e -> failchain e
               "%s: error unpacking %S to directory %S"
               funcname infn dest
        )

    let do_local_tar_gz ~funcname = local_tar_archive
      ~tar_extr_arg:"-xzf"
      ~funcname

    let local_tar_gz infn =
      { s_download = `Local infn
      ; s_extract =
          do_local_tar_gz ~funcname:"Source.local_tar_gz"
      }

    let do_local_tar_bz2 ~funcname = local_tar_archive
      ~tar_extr_arg:"-xjf"
      ~funcname

    let local_tar_bz2 infn =
      { s_download = `Local infn
      ; s_extract =
          do_local_tar_bz2 ~funcname:"Source.local_tar_bz2"
      }

    let local_dir dir =
      { s_download = `Local dir
      ; s_extract =
          (fun ~path ~dest ->
             match Reb_sys.run ~show:true [| "cp"; "-R"; path; dest |] with
             | 0 -> get_one_dir dest
             | _ -> failwith
                "Source.local_dir: can't copy directory %S to %S"
                path dest
          )
      }

    let downloader = lazy
      (if Reb_sys.has_command [| "wget" ; "--version" |]
       then fun ~uri ~outfn ->
         Reb_sys.run_ok ~show:true [| "wget" ; uri ; "-O" ; outfn |]
       else if Reb_sys.has_command [| "curl" ; "--version" |]
       then fun ~uri ~outfn ->
         Reb_sys.run_ok ~show:true [| "curl" ; uri ; "-o" ; outfn |]
       else
         failwith "can't find wget or curl to download file"
      )

    let download ~uri ~funcname ~outfn =
      try
        !!downloader ~uri ~outfn
      with
      | e -> failchain e
          "%s: error downloading %S to %S"
          funcname uri outfn

    let remote_archive ?digest ~unpack ~uri ~funcname =
      let base_name = last_component_of_uri uri in
      { s_download = `Remote (`File
          { rf_base_name = base_name ; rf_digest = digest },
          (fun ~dl_dest ->
             let outfn = dl_dest </> base_name in
             ( download ~uri ~funcname ~outfn
             ; outfn
             )
          ))
      ; s_extract =
          (fun ~path ~dest ->
             unpack ~funcname ~path ~dest
          )
      }

    let remote_tar_gz ?md5 uri =
      remote_archive ?digest:md5
         ~unpack:do_local_tar_gz
         ~funcname:"Source.remote_tar_gz"
         ~uri

    let remote_tar_bz2 ?md5 uri =
      remote_archive ?digest:md5
        ~unpack:do_local_tar_bz2
        ~funcname:"Source.remote_tar_bz2"
        ~uri

  end

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

module type CONTEXT
 =
  sig
    val var : string -> string
  end


module type PKGDESC =
  sig
    val pkg_name : string
    val provides_pkgs : pkg list
    val requires : requires
    val is_installed : pkg (* one of [provides] *) -> bool
    val install : action
    val uninstall : action
    val source : source
  end


module type PKGDESC_ABS = functor (Context : CONTEXT) -> PKGDESC

module type PKGDESC_PROC = functor (Pkg : PKGDESC) -> sig val r : unit end
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.