Source

rebildol / src / pre_template.ml

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 installation_instructions = (unit -> unit)
type uninstallation_instructions = (unit -> unit)
type source = Src of
  ( dest:string ->
    string (* where the sources really are (may be subdir of [dest]) *)
  )


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 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 =
           if target = ""
           then [| Reb_sys.make_exe |]
           else [| Reb_sys.make_exe ; target |]
         in
         if 0 = Reb_sys.run ~show:true argv
         then ()
         else failwith "%s: failed to build target %S" funcname target
      )
      targets
  in
    Printf.printf "%s: done\n%!" funcname


let ( >> ) 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 -> (unit -> unit) -> (unit -> unit) -> (unit -> unit)
  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 *) -> installation_instructions
    val make : string list (* targets *) -> installation_instructions
    val none : installation_instructions
    val run : string list -> installation_instructions
  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 targets = (make_gen "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

  end


module Uninstall
 :
  sig
    val make : string list -> uninstallation_instructions
    val none : uninstallation_instructions
    val ocamlfind_remove : string list -> uninstallation_instructions
  end
 =
  struct
    let none () = ()
    let make targets = (make_gen "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

module Source
 :
  sig
    val none : source
    val hg : string -> source
    val local_tar_gz : string -> source
    val local_tar_bz2 : string -> source
    val local_dir : string -> source
    val remote_tar_gz : string -> source
    val remote_tar_bz2 : string -> source
  end
 =
  struct

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

    let none = Src (fun ~dest ->
      ( ignore dest
      ; failwith "Source.none: no source specified"
      )
    )

    let hg repo =
      Src
        (fun ~dest ->
           let argv = [| "hg" ; "clone" ; repo ; dest |] in
           if 0 = Reb_sys.run ~show:true argv
           then dest
           else failwith "can't clone mercurial repository with command %s"
                  (Reb_sys.dump_argv argv)
        )

    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 ~keys ~funcname infn =
        (fun ~dest ->
           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" ; keys ; infn_abs |]
                      then ()
                      else failwith "error from 'tar %s'" keys
                   )
               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 infn = local_tar_archive
      ~keys:"-xzf"
      ~funcname
      infn

    let local_tar_gz infn =
      Src (do_local_tar_gz ~funcname:"Source.local_tar_gz" infn)

    let do_local_tar_bz2 ~funcname infn = local_tar_archive
      ~keys:"-xjf"
      ~funcname
      infn

    let local_tar_bz2 infn = Src
      (do_local_tar_bz2 ~funcname:"Source.local_tar_bz2" infn)

    let local_dir dir =
      Src
        (fun ~dest ->
           match Reb_sys.run ~show:true [| "cp"; "-R"; dir; dest |] with
           | 0 -> get_one_dir dest
           | _ -> failwith "Source.local_dir: can't copy directory %S to %S"
                    dir 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 (Lazy.force downloader) ~uri ~outfn
      with
      | e -> failchain e
          "%s: error downloading %S to %S"
          funcname uri outfn

    let remote_archive ~unpack ~uri ~funcname =
      Src
        (fun ~dest ->
           Reb_sys.with_temp_file
             ~leave_on_fail:true
             "reb_downloaded_archive" ""
             (fun outfn ->
                ( download ~uri ~funcname ~outfn
                ; unpack ~funcname outfn ~dest
                )
             )
        )

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

    let remote_tar_bz2 uri =
      remote_archive
        ~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 : installation_instructions
    val uninstall : uninstallation_instructions
    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.