├── .merlin ├── LICENSE ├── Makefile ├── README.md ├── _tags ├── client.ml ├── common.ml ├── example ├── build │ ├── Makefile │ ├── builder.sh │ ├── client.ml │ ├── common.ml │ ├── heart.ml │ ├── heart.mli │ ├── manual.sh │ ├── ocamp.ml │ ├── server.ml │ └── utils.ml └── fib │ ├── Makefile │ └── fib.sh ├── heart.ml ├── heart.mli ├── ocamp.ml ├── server.ml └── utils.ml /.merlin: -------------------------------------------------------------------------------- 1 | B _build 2 | PKG lwt.unix cmdliner 3 | #sha.sha1 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | CC0 1.0 Universal 2 | 3 | Statement of Purpose 4 | 5 | The laws of most jurisdictions throughout the world automatically confer 6 | exclusive Copyright and Related Rights (defined below) upon the creator and 7 | subsequent owner(s) (each and all, an "owner") of an original work of 8 | authorship and/or a database (each, a "Work"). 9 | 10 | Certain owners wish to permanently relinquish those rights to a Work for the 11 | purpose of contributing to a commons of creative, cultural and scientific 12 | works ("Commons") that the public can reliably and without fear of later 13 | claims of infringement build upon, modify, incorporate in other works, reuse 14 | and redistribute as freely as possible in any form whatsoever and for any 15 | purposes, including without limitation commercial purposes. These owners may 16 | contribute to the Commons to promote the ideal of a free culture and the 17 | further production of creative, cultural and scientific works, or to gain 18 | reputation or greater distribution for their Work in part through the use and 19 | efforts of others. 20 | 21 | For these and/or other purposes and motivations, and without any expectation 22 | of additional consideration or compensation, the person associating CC0 with a 23 | Work (the "Affirmer"), to the extent that he or she is an owner of Copyright 24 | and Related Rights in the Work, voluntarily elects to apply CC0 to the Work 25 | and publicly distribute the Work under its terms, with knowledge of his or her 26 | Copyright and Related Rights in the Work and the meaning and intended legal 27 | effect of CC0 on those rights. 28 | 29 | 1. Copyright and Related Rights. A Work made available under CC0 may be 30 | protected by copyright and related or neighboring rights ("Copyright and 31 | Related Rights"). Copyright and Related Rights include, but are not limited 32 | to, the following: 33 | 34 | i. the right to reproduce, adapt, distribute, perform, display, communicate, 35 | and translate a Work; 36 | 37 | ii. moral rights retained by the original author(s) and/or performer(s); 38 | 39 | iii. publicity and privacy rights pertaining to a person's image or likeness 40 | depicted in a Work; 41 | 42 | iv. rights protecting against unfair competition in regards to a Work, 43 | subject to the limitations in paragraph 4(a), below; 44 | 45 | v. rights protecting the extraction, dissemination, use and reuse of data in 46 | a Work; 47 | 48 | vi. database rights (such as those arising under Directive 96/9/EC of the 49 | European Parliament and of the Council of 11 March 1996 on the legal 50 | protection of databases, and under any national implementation thereof, 51 | including any amended or successor version of such directive); and 52 | 53 | vii. other similar, equivalent or corresponding rights throughout the world 54 | based on applicable law or treaty, and any national implementations thereof. 55 | 56 | 2. Waiver. To the greatest extent permitted by, but not in contravention of, 57 | applicable law, Affirmer hereby overtly, fully, permanently, irrevocably and 58 | unconditionally waives, abandons, and surrenders all of Affirmer's Copyright 59 | and Related Rights and associated claims and causes of action, whether now 60 | known or unknown (including existing as well as future claims and causes of 61 | action), in the Work (i) in all territories worldwide, (ii) for the maximum 62 | duration provided by applicable law or treaty (including future time 63 | extensions), (iii) in any current or future medium and for any number of 64 | copies, and (iv) for any purpose whatsoever, including without limitation 65 | commercial, advertising or promotional purposes (the "Waiver"). Affirmer makes 66 | the Waiver for the benefit of each member of the public at large and to the 67 | detriment of Affirmer's heirs and successors, fully intending that such Waiver 68 | shall not be subject to revocation, rescission, cancellation, termination, or 69 | any other legal or equitable action to disrupt the quiet enjoyment of the Work 70 | by the public as contemplated by Affirmer's express Statement of Purpose. 71 | 72 | 3. Public License Fallback. Should any part of the Waiver for any reason be 73 | judged legally invalid or ineffective under applicable law, then the Waiver 74 | shall be preserved to the maximum extent permitted taking into account 75 | Affirmer's express Statement of Purpose. In addition, to the extent the Waiver 76 | is so judged Affirmer hereby grants to each affected person a royalty-free, 77 | non transferable, non sublicensable, non exclusive, irrevocable and 78 | unconditional license to exercise Affirmer's Copyright and Related Rights in 79 | the Work (i) in all territories worldwide, (ii) for the maximum duration 80 | provided by applicable law or treaty (including future time extensions), (iii) 81 | in any current or future medium and for any number of copies, and (iv) for any 82 | purpose whatsoever, including without limitation commercial, advertising or 83 | promotional purposes (the "License"). The License shall be deemed effective as 84 | of the date CC0 was applied by Affirmer to the Work. Should any part of the 85 | License for any reason be judged legally invalid or ineffective under 86 | applicable law, such partial invalidity or ineffectiveness shall not 87 | invalidate the remainder of the License, and in such case Affirmer hereby 88 | affirms that he or she will not (i) exercise any of his or her remaining 89 | Copyright and Related Rights in the Work or (ii) assert any associated claims 90 | and causes of action with respect to the Work, in either case contrary to 91 | Affirmer's express Statement of Purpose. 92 | 93 | 4. Limitations and Disclaimers. 94 | 95 | a. No trademark or patent rights held by Affirmer are waived, abandoned, 96 | surrendered, licensed or otherwise affected by this document. 97 | 98 | b. Affirmer offers the Work as-is and makes no representations or warranties 99 | of any kind concerning the Work, express, implied, statutory or otherwise, 100 | including without limitation warranties of title, merchantability, fitness 101 | for a particular purpose, non infringement, or the absence of latent or 102 | other defects, accuracy, or the present or absence of errors, whether or not 103 | discoverable, all to the greatest extent permissible under applicable law. 104 | 105 | c. Affirmer disclaims responsibility for clearing rights of other persons 106 | that may apply to the Work or any use thereof, including without limitation 107 | any person's Copyright and Related Rights in the Work. Further, Affirmer 108 | disclaims responsibility for obtaining any necessary consents, permissions 109 | or other rights required for any use of the Work. 110 | 111 | d. Affirmer understands and acknowledges that Creative Commons is not a 112 | party to this document and has no duty or obligation with respect to this 113 | CC0 or use of the Work. 114 | 115 | For more information, please see 116 | 117 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ocamlbuild -use-ocamlfind ocamp.native 3 | ln -sf ocamp.native ocamp 4 | 5 | clean: 6 | ocamlbuild -use-ocamlfind -clean 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | OCamp extends unix shells with constructions to express memoization, sharing of computations and reactive programming. 2 | Licensed under CC0. 3 | 4 | # OCamp subcommands 5 | 6 | ## The default operation is to start a command 7 | 8 | Just wrap a unix command with "ocamp" to enable the extension: 9 | 10 | $ ocamp bash 11 | 12 | This will spawn a new bash session where the following subcommands are enabled. 13 | 14 | ## hipp 15 | 16 | $ ocamp hipp 17 | 18 | Will memoize the output and exit status of ``. 19 | Later calls to the same `` won't lead to actual execution, but just to a duplication of its previous output. 20 | Concurrent calls to `` will just share the same process, the beginning of the output being replayed to later callers. 21 | 22 | The identity of a command is defined by its arguments and working directory. 23 | 24 | ## stir 25 | 26 | $ ocamp stir 27 | 28 | Indicate potential changes in the output if `` was rerun. 29 | Later calls to `hipp` will recompute `` as if it was not yet memoized. 30 | 31 | ## (un)follow 32 | 33 | $ ocamp follow 34 | 35 | First, `` is memoized if it was not the case yet. 36 | Then changes to dependencies of `` will trigger a reevaluation. 37 | Use `stir` to notify a change. 38 | 39 | (to follow is an hipp/stir reaction). 40 | 41 | ## pull 42 | 43 | $ ocamp pull 44 | 45 | Closely related to `hipp`, but instead of marking dependency on the output of ``, the dependency applies to the "effects" of ``. 46 | 47 | Thus, if `stir` is used: 48 | - all pullers will be reevaluated. 49 | - hippers will be reevaluated only if the output is different. 50 | 51 | ## Summary 52 | 53 | $ ocamp fire - setup a new session alive until exits 54 | pull - mark dependency on effects of 55 | hipp - mark dependency on output of 56 | stir - notify that might have been updated 57 | follow - eval , and reactively recompute it 58 | whenever one of its dependencies change. 59 | unfollow - stop recomputing when dependencies 60 | change 61 | 62 | hipp and pull provide memoization. 63 | stir and follow bring a flavor of reactive programming. 64 | 65 | # Examples 66 | 67 | ## Fibonacci 68 | 69 | $ cat fib.sh 70 | #!/bin/sh 71 | ARG="$1" 72 | if [ "$ARG" -le 1 ]; then 73 | echo "$ARG" 74 | else 75 | A=`ocamp hipp ./fib.sh $((ARG-1))` 76 | B=`ocamp hipp ./fib.sh $((ARG-2))` 77 | echo $((A+B)) 78 | fi 79 | 80 | $ time ocamp fire ./fib.sh 50 81 | 12586269025 82 | real 0m0.391s 83 | user 0m0.153s 84 | sys 0m0.060s 85 | 86 | ## Build-system 87 | 88 | `ocamp` provides simple primitives to construct and manage a dependency graph. 89 | 90 | This might be a saner foundation to base a build-system on than make(1): 91 | - the command focus on one specific problem 92 | - no dsl is involved; rules can be plain unix commands, including a shell, rather than a make-flavored simulation of shell 93 | - nothing is provided for resolving goals; indeed this is better left to tools specifically built for goal-search. 94 | 95 | A quick'n'dirty script building ocamp itself is provided as an example. 96 | 97 | # Future 98 | 99 | The current release is a proof-of-concept and should be considered alpha quality. 100 | 101 | Semantics: 102 | - subcommands should probably be executed in client environment 103 | - `stir` should probably not trigger execution in current context 104 | 105 | Features: 106 | - Find a way to make the graph persistent (all data is kept in memory atm) 107 | - Provide an interface to debug and/or observe graph construction. 108 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: package(lwt,cmdliner,lwt.unix) 2 | -------------------------------------------------------------------------------- /client.ml: -------------------------------------------------------------------------------- 1 | (* 2 | OCamp by Frédéric Bour 3 | To the extent possible under law, the person who associated CC0 with 4 | OCamp has waived all copyright and related or neighboring rights to OCamp. 5 | 6 | You should have received a copy of the CC0 legalcode along with this 7 | work. If not, see . 8 | 9 | Website: https://github.com/def-lkb/ocamp 10 | 11 | Version 0.1, April 2015 12 | *) 13 | open Utils 14 | open Common 15 | 16 | module Make ( ) = struct 17 | 18 | open Command 19 | 20 | let make_query ?(env=[]) action request = 21 | let key = 22 | try Sys.getenv env_key 23 | with Not_found -> 24 | invalid_arg ("Client.make_command: no " ^ env_key ^ " in environment") 25 | in 26 | { key; cwd = Sys.getcwd (); action; request; vars = env } 27 | 28 | let connect_server () = 29 | let path = 30 | try Sys.getenv env_socket 31 | with Not_found -> 32 | invalid_arg ("Client.connect_server: no " ^ env_socket ^ " in environment") 33 | in 34 | let socket = Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in 35 | Lwt.catch 36 | (fun () -> 37 | Lwt_unix.connect socket (Lwt_unix.ADDR_UNIX path) >>= fun () -> 38 | let io_vector s = 39 | { Lwt_unix. iov_buffer = s; iov_offset = 0; iov_length = String.length s } in 40 | let io_vectors = List.map io_vector [signature;"i";"o";"e"] in 41 | let fds = [Unix.stdin; Unix.stdout; Unix.stderr] in 42 | Lwt_unix.send_msg ~socket ~io_vectors ~fds >>= fun _wrote -> (* FIXME *) 43 | Lwt.return socket) 44 | (fun exn -> Lwt_unix.close socket >>= fun () -> Lwt.fail exn) 45 | 46 | let execute_command (query : Command.query) = 47 | Lwt.catch (fun () -> 48 | connect_server () >>= fun socket -> 49 | let input = Lwt_io.of_fd ~close:Lwt.return ~mode:Lwt_io.input socket in 50 | let output = Lwt_io.of_fd ~close:Lwt.return ~mode:Lwt_io.output socket in 51 | Lwt_io.write_value output query >>= fun () -> 52 | Lwt_io.flush output >>= fun () -> 53 | Lwt_io.read_value input >>= fun (status : Unix.process_status) -> 54 | Lwt.join [Lwt_io.close input; Lwt_io.close output] >>= fun () -> 55 | Lwt_unix.close socket >>= fun () -> 56 | Lwt.return (Some status) 57 | ) 58 | (function 59 | | Unix.Unix_error (Unix.ENOENT, "connect", "") -> 60 | prerr_endline "--- cannot connect to server"; 61 | Lwt.return_none 62 | | End_of_file -> 63 | prerr_endline "--- build error, server closed connection"; 64 | Lwt.return_none 65 | | exn -> Lwt.fail exn) 66 | 67 | 68 | let main ?env action command = 69 | let query = make_query ?env action command in 70 | let status = Lwt_main.run (execute_command query) in 71 | exit (match status with 72 | | None -> (-1) 73 | | Some (Unix.WEXITED n) -> 74 | if n <> 0 then 75 | Printf.eprintf "--- %S exited with code %d\n%!" (Command.to_string command) n; 76 | n 77 | | Some (Unix.WSIGNALED n) -> (-1) 78 | | Some (Unix.WSTOPPED n) -> (-1)) 79 | end 80 | 81 | let main ?env action command = 82 | let module M = Make () in 83 | M.main ?env action command 84 | 85 | (* Command line interface *) 86 | open Cmdliner 87 | 88 | let command_pull = 89 | let run input arguments = 90 | let exec_dir = Path.canonicalize "." in 91 | let exec_args = Array.of_list arguments in 92 | main `Pull {Command. exec_dir; exec_args} 93 | in 94 | let arguments = Arg.(non_empty & pos_all string [] & info [] ~docv:"ARGS") in 95 | let doc = "Execute a command and memoize its result" in 96 | let man = [ 97 | `S "DESCRIPTION"; 98 | `P "$(tname) will execute the command represented by the rest of the arguments."; 99 | `P "This command might get executed again later, if the result changes the target will be recomputed."; 100 | ] in 101 | Term.(pure run $ pure None $ arguments), 102 | Term.info "pull" ~version:"0.0.1" ~doc ~man 103 | 104 | let command_hipp = 105 | let run input arguments = 106 | let exec_dir = Path.canonicalize "." in 107 | let exec_args = Array.of_list arguments in 108 | main `Hipp {Command. exec_dir; exec_args} 109 | in 110 | let arguments = Arg.(non_empty & pos_all string [] & info [] ~docv:"ARGS") in 111 | let doc = "Execute a command and memoize its result" in 112 | let man = [ 113 | `S "DESCRIPTION"; 114 | `P "$(tname) will execute the command represented by the rest of the arguments."; 115 | `P "This command might get executed again later, if the result changes the target will be recomputed."; 116 | ] in 117 | Term.(pure run $ pure None $ arguments), 118 | Term.info "hipp" ~version:"0.0.1" ~doc ~man 119 | 120 | let command_stir = 121 | let run input arguments = 122 | let exec_dir = Path.canonicalize "." in 123 | let exec_args = Array.of_list arguments in 124 | main `Stir {Command. exec_dir; exec_args} 125 | in 126 | let arguments = Arg.(non_empty & pos_all string [] & info [] ~docv:"ARGS") in 127 | let doc = "Execute a command and memoize its result" in 128 | let man = [ 129 | `S "DESCRIPTION"; 130 | `P "$(tname) will execute the command represented by the rest of the arguments."; 131 | `P "This command might get executed again later, if the result changes the target will be recomputed."; 132 | ] in 133 | Term.(pure run $ pure None $ arguments), 134 | Term.info "stir" ~version:"0.0.1" ~doc ~man 135 | 136 | let command_is_valid = 137 | let run input arguments = 138 | let exec_dir = Path.canonicalize "." in 139 | let exec_args = Array.of_list arguments in 140 | main `Validate {Command. exec_dir; exec_args} 141 | in 142 | let arguments = Arg.(non_empty & pos_all string [] & info [] ~docv:"ARGS") in 143 | let doc = "Execute a command and memoize its result" in 144 | let man = [ 145 | `S "DESCRIPTION"; 146 | `P "$(tname) will execute the command represented by the rest of the arguments."; 147 | `P "This command might get executed again later, if the result changes the target will be recomputed."; 148 | ] in 149 | Term.(pure run $ pure None $ arguments), 150 | Term.info "is-valid" ~version:"0.0.1" ~doc ~man 151 | 152 | let command_follow = 153 | let run input arguments = 154 | let exec_dir = Path.canonicalize "." in 155 | let exec_args = Array.of_list arguments in 156 | main `Follow {Command. exec_dir; exec_args} 157 | in 158 | let arguments = Arg.(non_empty & pos_all string [] & info [] ~docv:"ARGS") in 159 | let doc = "Execute a command and memoize its result" in 160 | let man = [ 161 | `S "DESCRIPTION"; 162 | `P "$(tname) will execute the command represented by the rest of the arguments."; 163 | `P "This command might get executed again later, if the result changes the target will be recomputed."; 164 | ] in 165 | Term.(pure run $ pure None $ arguments), 166 | Term.info "follow" ~version:"0.0.1" ~doc ~man 167 | 168 | let command_unfollow = 169 | let run input arguments = 170 | let exec_dir = Path.canonicalize "." in 171 | let exec_args = Array.of_list arguments in 172 | main `Unfollow {Command. exec_dir; exec_args} 173 | in 174 | let arguments = Arg.(non_empty & pos_all string [] & info [] ~docv:"ARGS") in 175 | let doc = "Execute a command and memoize its result" in 176 | let man = [ 177 | `S "DESCRIPTION"; 178 | `P "$(tname) will execute the command represented by the rest of the arguments."; 179 | `P "This command might get executed again later, if the result changes the target will be recomputed."; 180 | ] in 181 | Term.(pure run $ pure None $ arguments), 182 | Term.info "unfollow" ~version:"0.0.1" ~doc ~man 183 | 184 | let commands = [command_pull; command_hipp; command_stir; 185 | command_is_valid; command_follow; command_unfollow] 186 | 187 | let main () = 188 | match Term.eval_choice command_hipp commands with 189 | | `Error _ -> exit 1 | _ -> exit 0 190 | -------------------------------------------------------------------------------- /common.ml: -------------------------------------------------------------------------------- 1 | (* 2 | OCamp by Frédéric Bour 3 | To the extent possible under law, the person who associated CC0 with 4 | OCamp has waived all copyright and related or neighboring rights to OCamp. 5 | 6 | You should have received a copy of the CC0 legalcode along with this 7 | work. If not, see . 8 | 9 | Website: https://github.com/def-lkb/ocamp 10 | 11 | Version 0.1, April 2015 12 | *) 13 | open Utils 14 | 15 | (* Shared constants *) 16 | 17 | let signature = "OCAMP001" 18 | let signature_length = String.length signature 19 | let env_socket = "OCAMP_PATH" 20 | let env_key = "OCAMP_KEY" 21 | let env_binary = "ocamp" 22 | let socket_name = ".ocamp." 23 | 24 | (* Simple engine using unix and shell as backend *) 25 | 26 | module Command = struct 27 | type action = [`Hipp|`Pull|`Stir|`Validate|`Follow|`Unfollow] 28 | 29 | type t = { 30 | exec_dir: string; 31 | exec_args: string array 32 | } 33 | (*let dummy = { exec_dir = ""; exec_args = [||] }*) 34 | 35 | let compare (a : t) b = compare a b 36 | let hash (a : t) = Hashtbl.hash a 37 | let equal (a : t) b = a = b 38 | 39 | let to_string t = 40 | let is_special = function 41 | | '\'' | '"' | ' ' | '$' -> true 42 | | _ -> false 43 | in 44 | let is_special s = 45 | try 46 | for i = 0 to String.length s - 1 do 47 | if is_special s.[i] then 48 | raise Not_found 49 | done; 50 | false 51 | with Not_found -> true 52 | in 53 | let args = Array.map 54 | (fun s -> if is_special s then "\"" ^ String.escaped s ^ "\"" else s) 55 | t.exec_args 56 | in 57 | "[" ^ t.exec_dir ^ "] " ^ (String.concat " " (Array.to_list args)) 58 | 59 | type query = { 60 | key : string; 61 | cwd : string; 62 | vars : string list; 63 | action : action; 64 | request : t; 65 | } 66 | 67 | type env = { 68 | stdin : Lwt_unix.file_descr option ref; 69 | stdout : Lwt_unix.file_descr option ref; 70 | stderr : Lwt_unix.file_descr option ref; 71 | } 72 | 73 | type command = { 74 | query: query; 75 | env: env; 76 | socket: Lwt_unix.file_descr; 77 | input: Lwt_io.input_channel; 78 | output: Lwt_io.output_channel; 79 | } 80 | 81 | let unexpected_error fn exn = 82 | prerr_endline ("Unexpected error in " ^ fn); 83 | prerr_endline (Printexc.to_string exn) 84 | 85 | let try_close fd = 86 | try Lwt_unix.close fd 87 | with exn -> 88 | unexpected_error "Command.try_close" exn; 89 | Lwt.return_unit 90 | let close_fd r = match !r with 91 | | None -> Lwt.return_unit 92 | | Some fd -> r := None; try_close fd 93 | 94 | let close_command {env; socket; input} = 95 | Lwt.join [close_fd env.stdin; close_fd env.stdout; close_fd env.stderr] 96 | >>= fun () -> 97 | Lwt_io.close input >>= fun () -> 98 | Lwt.catch 99 | (fun () -> Lwt_unix.close socket) 100 | (fun exn -> 101 | unexpected_error "Command.close_command" exn; 102 | Lwt.return_unit) 103 | 104 | let connect_client socket = 105 | let io_vector n = 106 | let iov_buffer = String.make n '_' in 107 | { Lwt_unix. iov_buffer; iov_offset = 0; iov_length = n } in 108 | let header = io_vector signature_length in 109 | let fd_desc = [io_vector 1; io_vector 1; io_vector 1] in 110 | let io_vectors = header :: fd_desc in 111 | let sz = List.fold_left (fun s v -> s + v.Lwt_unix.iov_length) 0 io_vectors in 112 | Lwt_unix.recv_msg ~socket ~io_vectors >>= fun (sz',fds) -> 113 | let fds = List.map Lwt_unix.of_unix_file_descr fds in 114 | let fail exn = 115 | Lwt_list.iter_p try_close fds >>= fun () -> 116 | Lwt.fail exn in 117 | (if sz = sz' then Lwt.return_unit else 118 | fail (Invalid_argument 119 | (Printf.sprintf "Command.connect_client: expecting %d bytes, got %d" sz sz'))) 120 | >>= fun () -> 121 | (if header.Lwt_unix.iov_buffer = signature then Lwt.return_unit else 122 | fail (Invalid_argument "Command.connect_client: Protocol mismatch")) 123 | >>= fun () -> 124 | let acc = List.map (fun v -> v.Lwt_unix.iov_buffer) fd_desc, fds in 125 | let pop s = function 126 | | (" " :: iovs),fds -> 127 | Lwt.return (None, (iovs, fds)) 128 | | (s' :: iovs),(fd :: fds) when s = s' -> 129 | Lwt.return (Some fd, (iovs, fds)) 130 | | _ -> fail (Invalid_argument "Command.connect_client: invalid file descriptors") 131 | in 132 | pop "i" acc >>= fun (stdin , acc) -> 133 | pop "o" acc >>= fun (stdout, acc) -> 134 | pop "e" acc >>= fun (stderr, acc) -> 135 | let env = { stdin = ref stdin; stdout = ref stdout; stderr = ref stderr } in 136 | let input = Lwt_io.of_fd ~close:Lwt.return ~mode:Lwt_io.input socket in 137 | let output = Lwt_io.of_fd ~close:Lwt.return ~mode:Lwt_io.output socket in 138 | Lwt.catch (fun () -> 139 | Lwt_io.read_value input >|= fun query -> {query; env; input; output; socket}) 140 | (fun exn -> 141 | Lwt.join [Lwt_io.close input; Lwt_io.close output] 142 | >>= fun () -> fail exn) 143 | 144 | end 145 | 146 | module CommandMap = Map.Make (Command) 147 | module CommandSet = Set.Make (Command) 148 | module CommandHash = Hashtbl.Make (Command) 149 | 150 | (** Record the output of a process (stdout and exit status) to replay it later 151 | or concurrently *) 152 | module Result = struct 153 | 154 | type t = { 155 | command: Command.t; 156 | heart: Heart.t; 157 | mutable chunks: chunks Lwt.t; 158 | exit_status: status Lwt.t; 159 | } 160 | 161 | and chunks = 162 | | Chunk of string * chunks Lwt.t 163 | | Close of status Lwt.t 164 | 165 | and status = dependency list * Unix.process_status 166 | 167 | and dependency = 168 | | Pull of Heart.t * Command.t 169 | | Hipp of t 170 | 171 | let rec pack buffer = function 172 | | Chunk (s, next) -> 173 | Buffer.add_string buffer s; 174 | if Buffer.length buffer >= 4096 then 175 | let s = Buffer.contents buffer in 176 | Buffer.clear buffer; 177 | Lwt.return (Chunk (s, next >>= pack buffer)) 178 | else 179 | next >>= pack buffer 180 | | Close status -> 181 | let s = Buffer.contents buffer in 182 | if s = "" then 183 | Lwt.return (Close status) 184 | else 185 | Lwt.return (Chunk (s, Lwt.return (Close status))) 186 | 187 | let pack chunks = pack (Buffer.create 4096) chunks 188 | 189 | let fresh command heart = 190 | let chunks, chunksu = Lwt.wait () in 191 | let rec exit_status = function 192 | | Chunk (_,next) -> next >>= exit_status 193 | | Close status -> status in 194 | let exit_status = chunks >>= exit_status in 195 | let result = { command; heart; chunks; exit_status } in 196 | result, (fun ?(packed=true) chunks -> 197 | let pack () = 198 | result.exit_status >|= fun _ -> 199 | chunks >|= fun chunks -> 200 | result.chunks <- pack chunks in 201 | if packed then Lwt.async pack; 202 | chunks >>= fun chunks -> 203 | Lwt.wakeup_later chunksu chunks; 204 | result.exit_status) 205 | 206 | let equal_status t1 t2 = 207 | t1 >>= fun (_deps1,s1) -> t2 >|= fun (_deps2,s2) -> 208 | (s1 : Unix.process_status) = s2 209 | 210 | let equal_prefix p1 s1 p2 s2 = 211 | let l1 = String.length s1 - p1 and l2 = String.length s2 - p2 in 212 | try 213 | for i = 0 to min l1 l2 - 1 do 214 | if s1.[i] <> s2.[i] then 215 | raise Not_found 216 | done; 217 | if l1 = l2 218 | then `Equal 219 | else if l2 < l1 220 | then `S1 (p1 + l2) 221 | else `S2 (p2 + l1) 222 | with Not_found -> `Diff 223 | 224 | let rec equal_chunks p1 t1 p2 t2 = match t1, t2 with 225 | | Close t1, Close t2 -> equal_status t1 t2 226 | | Chunk ("",t1'), t2 -> 227 | t1' >>= fun t1 -> equal_chunks 0 t1 p2 t2 228 | | t1, Chunk ("",t2') -> 229 | t2' >>= fun t2 -> equal_chunks p1 t1 0 t2 230 | | Chunk (s1,t1'), Chunk (s2,t2') -> 231 | begin match equal_prefix p1 s1 p2 s2 with 232 | | `Equal -> 233 | t1' >>= fun t1 -> t2' >>= fun t2 -> 234 | equal_chunks 0 t1 0 t2 235 | | `S1 p1 -> 236 | t2' >>= fun t2 -> equal_chunks p1 t1 0 t2 237 | | `S2 p2 -> 238 | t1' >>= fun t1 -> equal_chunks 0 t1 p2 t2 239 | | `Diff -> Lwt.return_false 240 | end 241 | | _ -> Lwt.return_false 242 | 243 | let equal t1 t2 = 244 | t1.chunks >>= fun t1 -> 245 | t2.chunks >>= fun t2 -> 246 | equal_chunks 0 t1 0 t2 247 | 248 | let of_status status (f : ?packed:bool -> chunks Lwt.t -> status Lwt.t) = 249 | f ~packed:false (Lwt.return (Close status)) 250 | 251 | let none = of_status (Lwt.return ([], Unix.WEXITED 255)) 252 | let ok = of_status (Lwt.return ([], Unix.WEXITED 0)) 253 | 254 | let copy_chunks deps chunks (f : ?packed:bool -> chunks Lwt.t -> status Lwt.t) = 255 | let rec aux = function 256 | | Close status -> 257 | Lwt.return (Close (Lwt.map (fun (_,status) -> deps, status) status)) 258 | | Chunk (s,chunks) -> 259 | chunks >>= fun chunks -> 260 | Lwt.return (Chunk (s, aux chunks)) 261 | in 262 | f ~packed:false (aux chunks) 263 | 264 | let of_process deps p (f : ?packed:bool -> chunks Lwt.t -> status Lwt.t) = 265 | let buffer = Bytes.to_string (Bytes.create 1024) in 266 | let rec aux () = 267 | Lwt_io.read_into p#stdout buffer 0 1024 >>= fun got -> 268 | if got = 0 then 269 | Lwt.return (Close (Lwt.map (fun status -> List.rev !deps, status) 270 | p#close)) 271 | else 272 | Lwt.return (Chunk (String.sub buffer 0 got, aux ())) in 273 | f ~packed:true (aux ()) 274 | 275 | let chunks t = t.chunks 276 | let exit_status t = t.exit_status 277 | 278 | let rec dump_chunks output = function 279 | | Chunk ("",next) -> next >>= dump_chunks output 280 | | Chunk (s,next) -> 281 | write_string s output >>= fun () -> 282 | next >>= dump_chunks output 283 | | Close exit_status -> Lwt.return exit_status 284 | 285 | let dump_to output {chunks} = chunks >>= dump_chunks output 286 | end 287 | 288 | (* We need to keep some context associated with unix processes. 289 | To carry this information through user scripts, we use an environment 290 | variable. 291 | The Builder structure gives a unique string key to arbitrary ocaml values, 292 | and allows to retrieve the value of a key while the associated lwt process 293 | is alive. *) 294 | module Builder : sig 295 | type 'a t 296 | type key = string 297 | 298 | val create : unit -> 'a t 299 | val with_key : 'a t -> key -> ('a option -> 'b Lwt.t) -> 'b Lwt.t 300 | val with_value : 'a t -> 'a -> ?on_release:('a -> unit Lwt.t) -> (key -> 'b Lwt.t) -> 'b Lwt.t 301 | end = struct 302 | type key = string 303 | type 'a cell = 'a * int ref * ('a -> unit Lwt.t) option 304 | type 'a t = (string, 'a cell) Hashtbl.t 305 | 306 | let create () : 'a t = Hashtbl.create 7 307 | 308 | let fresh_key = 309 | let counter = ref 0 in 310 | fun () -> incr counter; string_of_int !counter 311 | 312 | let get builder key = 313 | try Some (Hashtbl.find builder key) 314 | with Not_found -> None 315 | 316 | let decr_cell builder (a,counter,release_action) key () = 317 | decr counter; 318 | if !counter = 0 then 319 | begin 320 | Hashtbl.remove builder key; 321 | match release_action with 322 | | None -> () 323 | | Some f -> Lwt.async (fun () -> f a) 324 | end; 325 | Lwt.return_unit 326 | 327 | let with_key builder key f = 328 | match get builder key with 329 | | Some (t, counter, _ as cell) -> 330 | incr counter; 331 | Lwt.finalize 332 | (fun () -> f (Some t)) 333 | (decr_cell builder cell key) 334 | | None -> f None 335 | 336 | let with_value builder value ?on_release f = 337 | let key = fresh_key () in 338 | let cell = (value, ref 1, on_release) in 339 | Hashtbl.add builder key cell; 340 | Lwt.finalize 341 | (fun () -> f key) 342 | (decr_cell builder cell key) 343 | end 344 | 345 | -------------------------------------------------------------------------------- /example/build/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ln -sf ../../*.ml{,i} ./ 3 | ../../ocamp sh ./builder.sh build 4 | 5 | clean: 6 | rm -rf *.o *.cm[aoix] *.cmxa 7 | 8 | distclean: clean 9 | rm -rf *.byte *.native 10 | 11 | .PHONY: all clean distclean 12 | -------------------------------------------------------------------------------- /example/build/builder.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ### Configuration 4 | PACKAGES=lwt.unix,cmdliner 5 | 6 | OCAMLC=ocamlc.opt 7 | OCAMLOPT=ocamlopt.opt 8 | 9 | SOURCES="utils.ml heart.mli heart.ml common.ml client.ml server.ml ocamp.ml" 10 | MAIN=ocamp 11 | 12 | ### RULES 13 | SELF="$0" 14 | 15 | packages() { 16 | echo "$PACKAGES" 17 | } 18 | 19 | flags() { 20 | OCAMLFIND_COMMANDS='ocamlc=echo,ocamlopt=echo' ocamlfind "$@" 21 | } 22 | 23 | ocamlc_c_flags() { 24 | flags c -package `packages` 25 | } 26 | 27 | ocamlc_ld_flags() { 28 | flags c -package `packages` -linkpkg 29 | } 30 | 31 | ocamlopt_c_flags() { 32 | flags opt -package `packages` 33 | } 34 | 35 | ocamlopt_ld_flags() { 36 | flags opt -package `packages` -linkpkg 37 | } 38 | 39 | builder() { 40 | while [[ "$1" == *"="* ]]; do 41 | eval export "$1" 42 | shift 1 43 | done 44 | exec $ocamp hipp sh "$SELF" "$@" 45 | } 46 | 47 | stir_file() { 48 | $ocamp stir md5sum "$1" 49 | } 50 | 51 | cmi() { 52 | TARGET="$1" 53 | TARGET="${TARGET%.*}" 54 | echo >&2 CMI "'$TARGET'" 55 | if [ -f "${TARGET}.mli" ]; then 56 | $OCAMLC `builder ocamlc_c_flags` -c "${TARGET}.mli" 57 | echo "CMI" 58 | elif [ -f "${TARGET}.ml" ]; then 59 | if [ "x$PREFER" = "xCMX" ]; then 60 | $OCAMLOPT `builder ocamlopt_c_flags` -c "${TARGET}.ml" 61 | echo >&2 CMX_CMI "'$TARGET'" 62 | echo "CMX" 63 | else 64 | $OCAMLC `builder ocamlc_c_flags` -c "${TARGET}.ml" 65 | echo >&2 CMO_CMI "'$TARGET'" 66 | echo "CMO" 67 | fi 68 | else 69 | exit 1 70 | fi 71 | } 72 | 73 | cmo() { 74 | TARGET="$1" 75 | TARGET=${TARGET%.*} 76 | echo >&2 CMO "'$TARGET'" 77 | CMO_OR_CMX=`builder PREFER=CMO cmi "${TARGET}"` 78 | if [ "$CMO_OR_CMX" != "CMO" ]; then 79 | $OCAMLC `builder ocamlc_c_flags` -c "${TARGET}.ml" 80 | fi 81 | } 82 | 83 | cmx() { 84 | TARGET="$1" 85 | TARGET=${TARGET%.*} 86 | echo >&2 CMX "'$TARGET'" 87 | CMO_OR_CMX=`builder PREFER=CMX cmi "${TARGET}"` 88 | if [ "$CMO_OR_CMX" != "CMX" ]; then 89 | $OCAMLOPT `builder ocamlopt_c_flags` -c "${TARGET}.ml" 90 | fi 91 | } 92 | 93 | byte() { 94 | TARGET="$1" 95 | TARGET=${TARGET%.*} 96 | (builder build "${TARGET}.cmo") 97 | echo >&2 BYTE "'$TARGET'" 98 | $OCAMLC `builder ocamlc_ld_flags` -o "${TARGET}.byte" `link_depend cmo` 99 | } 100 | 101 | native() { 102 | TARGET="$1" 103 | TARGET=${TARGET%.*} 104 | (builder build "${TARGET}.cmx") 105 | echo >&2 NATIVE "'$TARGET'" 106 | $OCAMLOPT `builder ocamlopt_ld_flags` -o "${TARGET}.native" `link_depend cmx` 107 | } 108 | 109 | depend() { 110 | if [ -z "$1" ]; then 111 | ocamldep $SOURCES 112 | else 113 | builder depend | grep "^$1" | cut -d: -f2 114 | fi 115 | } 116 | 117 | link_depend() { 118 | # $1 = cmx or cmo 119 | builder depend | while read name colon deps; do 120 | for dep in $deps; do 121 | echo "$dep $name"; 122 | done; 123 | done | tsort | grep '.$1\$' 124 | } 125 | 126 | build() { 127 | echo >&2 BUILD "$@" 128 | TARGET="$1" 129 | if [ -z "$TARGET" ]; then 130 | TARGET=${MAIN}.byte 131 | fi 132 | DEPS=`builder depend "$TARGET"` 133 | for DEP in $DEPS; do 134 | builder build "$DEP" >/dev/null & 135 | done 136 | for DEP in $DEPS; do 137 | ( builder build "$DEP" ) 138 | done 139 | if [[ "$TARGET" == *".cmi" ]]; then 140 | builder cmi "$TARGET" >/dev/null 141 | elif [[ "$TARGET" == *".cmo" ]]; then 142 | builder cmo "$TARGET" >/dev/null 143 | elif [[ "$TARGET" == *".cmx" ]]; then 144 | builder cmx "$TARGET" >/dev/null 145 | elif [[ "$TARGET" == *".byte" ]]; then 146 | builder byte "$TARGET" >/dev/null 147 | elif [[ "$TARGET" == *".native" ]]; then 148 | builder native "$TARGET" >/dev/null 149 | fi 150 | } 151 | 152 | eval "$@" 153 | -------------------------------------------------------------------------------- /example/build/client.ml: -------------------------------------------------------------------------------- 1 | ../../client.ml -------------------------------------------------------------------------------- /example/build/common.ml: -------------------------------------------------------------------------------- 1 | ../../common.ml -------------------------------------------------------------------------------- /example/build/heart.ml: -------------------------------------------------------------------------------- 1 | ../../heart.ml -------------------------------------------------------------------------------- /example/build/heart.mli: -------------------------------------------------------------------------------- 1 | ../../heart.mli -------------------------------------------------------------------------------- /example/build/manual.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | build_ml() { 4 | ocamlfind opt -package lwt.unix,cmdliner -c "$1" 5 | } 6 | 7 | link_ml() { 8 | OUT="$1" 9 | shift 1 10 | ocamlfind opt -package lwt.unix,cmdliner -linkpkg -o "$1" "$@" 11 | } 12 | 13 | build_ml utils.ml 14 | build_ml heart.mli 15 | build_ml heart.ml 16 | build_ml common.ml 17 | build_ml client.ml 18 | build_ml server.ml 19 | build_ml ocamp.ml 20 | link_ml ocamp utils.cmx heart.cmx common.cmx client.cmx server.cmx ocamp.cmx 21 | -------------------------------------------------------------------------------- /example/build/ocamp.ml: -------------------------------------------------------------------------------- 1 | ../../ocamp.ml -------------------------------------------------------------------------------- /example/build/server.ml: -------------------------------------------------------------------------------- 1 | ../../server.ml -------------------------------------------------------------------------------- /example/build/utils.ml: -------------------------------------------------------------------------------- 1 | ../../utils.ml -------------------------------------------------------------------------------- /example/fib/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ../../ocamp ./fib.sh 50 3 | -------------------------------------------------------------------------------- /example/fib/fib.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ARG="$1" 3 | echo "fib $ARG" >&2 4 | if [ "$ARG" -le 1 ]; then 5 | echo "$ARG" 6 | else 7 | A=`$ocamp pull ./fib.sh $((ARG-1))` 8 | B=`$ocamp pull ./fib.sh $((ARG-2))` 9 | echo $((A+B)) 10 | fi 11 | -------------------------------------------------------------------------------- /heart.ml: -------------------------------------------------------------------------------- 1 | (* 2 | OCamp by Frédéric Bour 3 | To the extent possible under law, the person who associated CC0 with 4 | OCamp has waived all copyright and related or neighboring rights to OCamp. 5 | 6 | You should have received a copy of the CC0 legalcode along with this 7 | work. If not, see . 8 | 9 | Website: https://github.com/def-lkb/ocamp 10 | 11 | Version 0.1, April 2015 12 | 13 | -- 14 | 15 | The concept of 'Heart' is inspired from Jenga, 16 | https://github.com/janestreet/jenga 17 | *) 18 | type t = { mutable deps: t list; mutable broken: bool } 19 | 20 | let fresh () = { deps = []; broken = false } 21 | 22 | let is_broken t = t.broken 23 | 24 | let rec break t = 25 | let deps = t.deps in 26 | t.deps <- []; t.broken <- true; 27 | List.iter break deps 28 | 29 | let rec register_dep g = function 30 | | [] -> () 31 | | t :: ts -> 32 | t.deps <- g :: t.deps; 33 | register_dep g ts 34 | 35 | let fragilize g ts = 36 | if not (is_broken g) then begin 37 | if List.exists is_broken ts then 38 | break g 39 | else 40 | register_dep g ts 41 | end 42 | 43 | let broken = { deps = []; broken = true } 44 | 45 | let join ts = 46 | if List.exists is_broken ts then 47 | broken 48 | else 49 | let g = fresh () in 50 | register_dep g ts; 51 | g 52 | 53 | -------------------------------------------------------------------------------- /heart.mli: -------------------------------------------------------------------------------- 1 | (* 2 | OCamp by Frédéric Bour 3 | To the extent possible under law, the person who associated CC0 with 4 | OCamp has waived all copyright and related or neighboring rights to OCamp. 5 | 6 | You should have received a copy of the CC0 legalcode along with this 7 | work. If not, see . 8 | 9 | Website: https://github.com/def-lkb/ocamp 10 | 11 | Version 0.1, April 2015 12 | 13 | -- 14 | 15 | The concept of 'Heart' is inspired from Jenga, 16 | https://github.com/janestreet/jenga 17 | *) 18 | type t 19 | 20 | val fresh : unit -> t 21 | 22 | val is_broken : t -> bool 23 | 24 | val break : t -> unit 25 | val fragilize : t -> t list -> unit 26 | 27 | val broken : t 28 | val join : t list -> t 29 | -------------------------------------------------------------------------------- /ocamp.ml: -------------------------------------------------------------------------------- 1 | (* 2 | OCamp by Frédéric Bour 3 | To the extent possible under law, the person who associated CC0 with 4 | OCamp has waived all copyright and related or neighboring rights to OCamp. 5 | 6 | You should have received a copy of the CC0 legalcode along with this 7 | work. If not, see . 8 | 9 | Website: https://github.com/def-lkb/ocamp 10 | 11 | Version 0.1, April 2015 12 | *) 13 | open Utils 14 | 15 | let main () = 16 | let is_client = 17 | try ignore (Sys.getenv Common.env_socket : string); true 18 | with Not_found -> false 19 | in 20 | if is_client then 21 | Client.main () 22 | else 23 | Server.main () 24 | 25 | let () = main () 26 | -------------------------------------------------------------------------------- /server.ml: -------------------------------------------------------------------------------- 1 | (* 2 | OCamp by Frédéric Bour 3 | To the extent possible under law, the person who associated CC0 with 4 | OCamp has waived all copyright and related or neighboring rights to OCamp. 5 | 6 | You should have received a copy of the CC0 legalcode along with this 7 | work. If not, see . 8 | 9 | Website: https://github.com/def-lkb/ocamp 10 | 11 | Version 0.1, April 2015 12 | *) 13 | open Utils 14 | open Common 15 | 16 | module Make (P : sig 17 | val cache : Result.t CommandMap.t 18 | end) = 19 | struct 20 | 21 | type builder = Command.action -> Command.t -> Result.t 22 | 23 | let builders : builder Builder.t = 24 | Builder.create () 25 | 26 | (* Server loop, waiting for clients on unix socket *) 27 | module Runner = struct 28 | let server_path = 29 | Path.canonicalize (socket_name ^ string_of_int (Unix.getpid ())) 30 | let () = at_exit (fun () -> Unix.unlink server_path) 31 | 32 | let server_socket = Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 33 | 34 | let () = 35 | Lwt_unix.set_close_on_exec server_socket; 36 | begin 37 | try Unix.unlink server_path 38 | with _ -> () 39 | end; 40 | Lwt_unix.bind server_socket (Lwt_unix.ADDR_UNIX server_path); 41 | Lwt_unix.listen server_socket 0; 42 | Unix.putenv env_socket server_path 43 | 44 | let handle_client (fd,_addr) = 45 | let open Command in 46 | Lwt.catch (fun () -> connect_client fd) 47 | (fun exn -> Lwt_unix.close fd >>= fun () -> Lwt.fail exn) 48 | >>= fun command -> 49 | let finish () = 50 | Lwt_io.flush command.output >>= fun () -> 51 | close_command command 52 | in 53 | Lwt.finalize 54 | begin fun () -> 55 | Builder.with_key builders command.query.key @@ function 56 | | None -> 57 | write_string (env_key ^ " is not valid") !(command.env.stderr) 58 | | Some builder -> 59 | let query = command.query in 60 | let result = builder query.action query.request in 61 | Result.dump_to !(command.env.stdout) result >>= fun status -> 62 | close_fd command.env.stdout >>= fun () -> 63 | status >>= fun (_,status) -> 64 | Lwt_io.write_value command.output (status : Unix.process_status) 65 | end 66 | finish 67 | 68 | let () = 69 | let rec loop () = 70 | Lwt_unix.accept server_socket >>= fun client -> 71 | Lwt.async (fun () -> handle_client client); 72 | loop () in 73 | Lwt.async loop 74 | end 75 | 76 | module Backend = struct 77 | type command = Command.t 78 | let compare_command = Command.compare 79 | let print_command = Command.to_string 80 | 81 | type result = Result.t 82 | 83 | (* Result cache *) 84 | let cache : Result.t CommandMap.t ref = 85 | ref CommandMap.empty 86 | 87 | let followed : CommandSet.t ref = ref CommandSet.empty 88 | 89 | let update_cache command result = 90 | cache := CommandMap.add command result !cache 91 | 92 | let do_execute builder result resultf build_deps command = 93 | Lwt.ignore_result 94 | begin 95 | Builder.with_value builders builder @@ fun key -> 96 | let vars = Array.of_list [env_key ^ "=" ^ key] in 97 | let env = Array.append vars (Unix.environment ()) in 98 | (* Lwt_process doesn't allow specifying working directory ?! *) 99 | Unix.chdir command.Command.exec_dir; 100 | let process = Lwt_process.open_process_in ~env 101 | (command.Command.exec_args.(0), command.Command.exec_args) in 102 | (* Wait for command to finish *) 103 | Result.of_process build_deps process resultf; 104 | end; 105 | result 106 | 107 | let dont_record _ _ = () 108 | 109 | let record build_heart build_deps 110 | action ({Result. heart; command} as result) 111 | = 112 | match action with 113 | | `Hipp -> 114 | Heart.fragilize build_heart [heart]; 115 | build_deps := Result.Hipp result :: !build_deps 116 | | `Pull -> 117 | Heart.fragilize build_heart [heart]; 118 | build_deps := Result.Pull (heart, command) :: !build_deps 119 | | `Stir | `Validate -> () 120 | 121 | let fresh_result command heart = 122 | let result = Result.fresh command heart in 123 | update_cache command (fst result); 124 | result 125 | 126 | let rec rebuild record_dep command = 127 | let build_deps = ref [] in 128 | let build_heart = Heart.fresh () in 129 | let builder = build (record build_heart build_deps) in 130 | let result, resultf = fresh_result command build_heart in 131 | record_dep result; 132 | do_execute builder result resultf build_deps command 133 | 134 | and build record_dep action command = 135 | match action with 136 | | `Validate -> 137 | let result, resultf = Result.fresh command Heart.broken in 138 | let status = match CommandMap.find command !cache with 139 | | result' -> 140 | Lwt.ignore_result 141 | begin 142 | result'.Result.exit_status >|= fun (deps,_) -> 143 | List.iter (function 144 | | Result.Pull (_,cmd) -> 145 | print_endline ("pull " ^ print_command cmd); 146 | | Result.Hipp result -> 147 | print_endline ("hipp " ^ print_command result.Result.command) 148 | ) deps 149 | end; 150 | if Heart.is_broken result'.Result.heart then 1 else 0 151 | | exception Not_found -> 1 152 | in 153 | Lwt.ignore_result 154 | (Result.of_status (Lwt.return ([], Unix.WEXITED status)) resultf); 155 | result 156 | | (`Unfollow | `Follow) as action -> 157 | let status = 158 | if (CommandSet.mem command !followed) <> (action = `Follow) then 159 | 0 160 | else 161 | 1 162 | in 163 | followed := 164 | (match action with 165 | | `Unfollow -> CommandSet.remove 166 | | `Follow -> CommandSet.add) command !followed; 167 | let result, resultf = Result.fresh command Heart.broken in 168 | Lwt.ignore_result 169 | (Result.of_status (Lwt.return ([], Unix.WEXITED status)) resultf); 170 | result 171 | | (`Hipp | `Pull | `Stir) as action -> 172 | let record_dep = record_dep action in 173 | begin match CommandMap.find command !cache with 174 | | result when action = `Stir -> 175 | Heart.break result.Result.heart; 176 | rebuild record_dep command 177 | | result when not (Heart.is_broken result.Result.heart) -> result 178 | | result -> refresh record_dep command result 179 | | exception Not_found -> rebuild record_dep command 180 | end 181 | 182 | and refresh record_dep command result_old = 183 | let build_heart = Heart.fresh () in 184 | let result, resultf = fresh_result command build_heart in 185 | record_dep result; 186 | Lwt.ignore_result 187 | begin 188 | result_old.Result.exit_status >>= fun (deps,status) -> 189 | (* Do we need to rebuild? *) 190 | let rebuild_me () = 191 | let build_deps = ref [] in 192 | let builder = build (record build_heart build_deps) in 193 | do_execute builder result resultf build_deps command 194 | in 195 | (* First find a broken pull deps *) 196 | let is_broken = 197 | List.exists (function 198 | | Result.Pull (heart,_) -> Heart.is_broken heart 199 | | Result.Hipp _ -> false) 200 | deps 201 | in 202 | if is_broken then 203 | Lwt.return (rebuild_me ()) 204 | else 205 | (* Then refresh hipp deps *) 206 | let rec refresh_hipps acc = function 207 | | Result.Hipp dep_result_old :: xs 208 | when Heart.is_broken dep_result_old.Result.heart -> 209 | let dep_result_new = 210 | build dont_record `Hipp dep_result_old.Result.command in 211 | Result.equal dep_result_old dep_result_new >>= fun is_equal -> 212 | if is_equal then 213 | refresh_hipps (Result.Hipp dep_result_new :: acc) xs 214 | else 215 | Lwt.return (rebuild_me ()) 216 | | x :: xs -> refresh_hipps (x :: acc) xs 217 | | [] -> 218 | List.iter (fun dep -> 219 | let dep_result = match dep with 220 | | Result.Hipp r -> r 221 | | Result.Pull (_,c) -> 222 | try CommandMap.find command !cache 223 | with Not_found -> assert false 224 | in 225 | Heart.fragilize build_heart [dep_result.Result.heart]) 226 | acc; 227 | result_old.Result.chunks >>= fun chunks -> 228 | Result.copy_chunks (List.rev acc) chunks resultf >|= fun _ -> 229 | result 230 | in 231 | refresh_hipps [] deps 232 | end; 233 | result 234 | 235 | let entry command = 236 | Builder.with_value builders (build dont_record) @@ fun key -> 237 | let vars = Array.of_list [env_key ^ "=" ^ key] in 238 | let env = Array.append vars (Unix.environment ()) in 239 | Unix.chdir command.Command.exec_dir; 240 | let process = Lwt_process.open_process_none ~env 241 | (command.Command.exec_args.(0), command.Command.exec_args) in 242 | process#status 243 | 244 | end 245 | 246 | let join a = a >>= fun x -> x 247 | 248 | let main command = 249 | let binary = Path.canonicalize Sys.executable_name in 250 | Unix.putenv env_binary binary; 251 | let result = Backend.entry command in 252 | let rec follow_jobs () = 253 | let refresh command = 254 | let need_rebuild = match CommandMap.find command !Backend.cache with 255 | | result -> Heart.is_broken result.Result.heart 256 | | exception Not_found -> true 257 | in 258 | if need_rebuild then 259 | ignore (Backend.build Backend.dont_record `Pull command); 260 | in 261 | CommandSet.iter refresh !Backend.followed; 262 | if Lwt.is_sleeping result then 263 | Lwt_unix.sleep 1.0 >>= follow_jobs 264 | else Lwt.return_unit 265 | in 266 | Lwt.async follow_jobs; 267 | result >>= fun status -> 268 | begin match status with 269 | | Unix.WEXITED n -> 270 | prerr_endline ("-- exited with status " ^ string_of_int n) 271 | | Unix.WSIGNALED n -> 272 | prerr_endline ("-- killed by signal " ^ string_of_int n) 273 | | Unix.WSTOPPED n -> 274 | prerr_endline ("-- stopped by signal " ^ string_of_int n) 275 | end; 276 | Lwt.return status 277 | end 278 | 279 | (* Command line interface *) 280 | open Cmdliner 281 | 282 | let rec command_fire cache input arguments = 283 | let exec_dir = Path.canonicalize "." in 284 | let exec_args = Array.of_list arguments in 285 | let module M = Make (struct let cache = cache end) in 286 | match Lwt_main.run (M.main {Command. exec_dir; exec_args}) with 287 | (*| _, Unix.WEXITED 0 -> 288 | ignore (read_line ()); 289 | command_exec cache input arguments*) 290 | | Unix.WEXITED n -> exit n 291 | | _ -> exit (-1) 292 | 293 | let command_fire input arguments = command_fire CommandMap.empty input arguments 294 | 295 | let command_fire = 296 | let arguments = Arg.(non_empty & pos_all string [] & info [] ~docv:"ARGS") in 297 | let doc = "Execute a command and memoize its result" in 298 | let man = [ 299 | `S "DESCRIPTION"; 300 | `P "$(tname) will execute the command represented by the rest of the arguments."; 301 | `P "This command might get executed again later, if the result changes the target will be recomputed."; 302 | ] in 303 | Term.(pure command_fire $ pure None $ arguments), 304 | Term.info "fire" ~version:"0.0.1" ~doc ~man 305 | 306 | let commands = [command_fire] 307 | 308 | let main () = 309 | match Term.eval command_fire with 310 | | `Error _ -> exit 1 311 | | _ -> exit 0 312 | -------------------------------------------------------------------------------- /utils.ml: -------------------------------------------------------------------------------- 1 | (* 2 | OCamp by Frédéric Bour 3 | To the extent possible under law, the person who associated CC0 with 4 | OCamp has waived all copyright and related or neighboring rights to OCamp. 5 | 6 | You should have received a copy of the CC0 legalcode along with this 7 | work. If not, see . 8 | 9 | Website: https://github.com/def-lkb/ocamp 10 | 11 | Version 0.1, April 2015 12 | *) 13 | let (>>=) = Lwt.(>>=) 14 | let (>|=) = Lwt.(>|=) 15 | 16 | (* Write complete string *) 17 | let rec write_string s i l fd = 18 | if l <= 0 then Lwt.return_unit 19 | else begin 20 | Lwt_unix.write fd s i l >>= fun wrote -> 21 | write_string s i (l - wrote) fd 22 | end 23 | 24 | let write_string s = function 25 | | None -> Lwt.return_unit 26 | | Some fd -> write_string s 0 (String.length s) fd 27 | 28 | (* Manipulate file system paths *) 29 | module Path = struct 30 | (** [split path] turns [path] into a pair of a directory and a filename *) 31 | let split path = Filename.dirname path, Filename.basename path 32 | 33 | (** [split_all path acc] turns [path] into a list of 34 | components prepended to [acc] *) 35 | let rec split_all path acc = 36 | match split path with 37 | | dir, _ when dir = path -> dir :: acc 38 | | dir, base -> split_all dir (base :: acc) 39 | 40 | (** [flatten parts] turns a list of filesystem components into one path 41 | flatten [] = "" 42 | flatten ["usr";"share"] = "usr/share" 43 | *) 44 | let flatten = function 45 | | [] -> "" 46 | | root :: subs -> List.fold_left Filename.concat root subs 47 | 48 | (** [canonicalize ?cwd path] turns [path] into an absolute directory, 49 | resolving relative paths from ?cwd or Sys.getcwd() *) 50 | let canonicalize ?cwd path = 51 | let parts = 52 | match split_all path [] with 53 | | dot :: rest when dot = Filename.current_dir_name -> 54 | split_all (match cwd with None -> Sys.getcwd () | Some c -> c) rest 55 | | parts -> parts in 56 | let goup path = function 57 | | dir when dir = Filename.parent_dir_name -> 58 | (match path with _ :: t -> t | [] -> []) 59 | | dir when dir = Filename.current_dir_name -> 60 | path 61 | | dir -> dir :: path in 62 | flatten (List.rev (List.fold_left goup [] parts)) 63 | 64 | let mtime filename = 65 | Lwt.catch 66 | (fun () -> Lwt.map (fun st -> st.Lwt_unix.st_mtime) 67 | (Lwt_unix.stat filename)) 68 | (fun _exn -> Lwt.return nan) 69 | end 70 | --------------------------------------------------------------------------------