Source file shell_command.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
open Core
open Bistro_internals
type file_dump = File_dump of {
text : string ;
path : string ;
}
type symbolic_file_dump = Symbolic_file_dump of {
contents : Execution_env.insert Template.t ;
in_docker_container : bool ;
}
type t = Command of {
text : string ;
file_dumps : file_dump list ;
env : Execution_env.t ;
uses_docker : bool ;
}
let text (Command cmd) = cmd.text
let file_dumps (Command cmd) = cmd.file_dumps
let rec file_dumps_of_tokens in_docker toks =
List.map toks ~f:(file_dumps_of_token in_docker)
|> List.concat
|> List.dedup_and_sort ~compare:Caml.compare
and file_dumps_of_token in_docker_container =
let open Template in
function
| NP
| DEST
| TMP
| S _
| D _
| MEM -> []
| F contents ->
Symbolic_file_dump {
contents = contents ;
in_docker_container ;
} :: file_dumps_of_tokens in_docker_container contents
|> List.dedup_and_sort ~compare:Caml.compare
let rec file_dumps_of_command in_docker =
let open Command in
function
| Simple_command toks -> file_dumps_of_tokens in_docker toks
| And_list xs
| Or_list xs
| Pipe_list xs ->
List.map xs ~f:(file_dumps_of_command in_docker)
|> List.concat
|> List.dedup_and_sort ~compare:Caml.compare
| Within_container (_, cmd) -> file_dumps_of_command true cmd
let string_of_token (env : Execution_env.t) =
let open Template in
function
| S s -> s
| D (Execution_env.Path p) -> env.dep p
| D (Execution_env.Path_list { elts ; quote ; sep }) ->
let quote =
Option.value_map quote ~default:Fn.id ~f:(fun c p -> sprintf "%c%s%c" c p c)
in
List.map elts ~f:env.dep
|> List.map ~f:quote
|> String.concat ~sep
| D (String s) -> s
| F toks -> env.file_dump toks
| DEST -> env.dest
| TMP -> env.tmp
| NP -> string_of_int env.np
| MEM -> string_of_int env.mem
let string_of_tokens env xs =
List.map ~f:(string_of_token env) xs
|> String.concat
let par x = "(" ^ x ^ ")"
let deps_mount ~env deps =
let open Execution_env in
let mounts = List.map deps ~f:(Execution_env.container_mount env.db) in
let host_paths, container_paths =
List.map mounts ~f:Execution_env.(fun m -> m.mount_host_location, m.mount_container_location)
|> List.dedup_and_sort ~compare:Caml.compare
|> List.unzip
in
Docker.mount_options ~host_paths ~container_paths
let file_dumps_mount env dck_env file_dumps =
let open Execution_env in
let f env (Symbolic_file_dump { contents = fd ; _ }) =
env.file_dump fd
in
Docker.mount_options
~host_paths:(List.map file_dumps ~f:(f env))
~container_paths:(List.map file_dumps ~f:(f dck_env))
let tmp_mount env dck_env =
let open Execution_env in
Docker.mount_options
~host_paths:[env.tmp]
~container_paths:[dck_env.tmp]
let dest_mount env dck_env =
let open Execution_env in
Docker.mount_options
~host_paths:Filename.[ dirname env.dest ]
~container_paths:Filename.[ dirname dck_env.dest ]
let command_path_deps cmd =
Command.deps cmd
|> List.filter_map ~f:(function
| Execution_env.Path p -> Some [ p ]
| Path_list l -> Some l.elts
| String _ -> None
)
|> List.concat
let rec string_of_command env =
let open Command in
function
| Simple_command tokens -> string_of_tokens env tokens
| And_list xs -> par (string_of_command_aux env " && " xs)
| Or_list xs -> par (string_of_command_aux env " || " xs)
| Pipe_list xs -> par (string_of_command_aux env " | " xs)
| Within_container (img, cmd) ->
match Execution_env.choose_container env.Execution_env.allowed_containers img with
| `Plain ->
string_of_command env cmd
| `Docker_container image ->
let dck_env = Execution_env.dockerize env in
sprintf
"docker run --log-driver=none --rm %s %s %s %s -i %s bash -c '%s'"
(deps_mount ~env (command_path_deps cmd))
(file_dumps_mount env dck_env (file_dumps_of_command true cmd))
(tmp_mount env dck_env)
(dest_mount env dck_env)
(Docker.image_url image)
(string_of_command dck_env cmd)
| `Singularity_container img ->
let env = Execution_env.singularize env in
sprintf
"singularity exec %s bash -c '%s'"
(Db.singularity_image env.Execution_env.db img)
(string_of_command env cmd)
and string_of_command_aux env sep xs =
List.map xs ~f:(string_of_command env)
|> String.concat ~sep
let rec command_uses_docker env = function
| Command.Simple_command _ -> false
| And_list xs
| Or_list xs
| Pipe_list xs -> command_uses_docker_aux env xs
| Within_container (img, _) ->
match Execution_env.choose_container env.Execution_env.allowed_containers img with
| `Plain -> false
| `Docker_container _ -> true
| `Singularity_container _ -> false
and command_uses_docker_aux env xs =
List.exists xs ~f:(command_uses_docker env)
let compile_file_dump env (Symbolic_file_dump { contents ; in_docker_container }) =
let exec_env =
if in_docker_container && Execution_env.allows_docker env
then Execution_env.dockerize env
else env
in
let path = env.file_dump contents in
let text = string_of_tokens exec_env contents in
File_dump { path ; text }
let make env cmd =
Command {
text = string_of_command env cmd ;
file_dumps =
file_dumps_of_command false cmd
|> List.map ~f:(compile_file_dump env) ;
env ;
uses_docker = command_uses_docker env cmd ;
}
let write_file_dumps xs =
let f (File_dump { text ; path }) =
Lwt_io.(with_file ~mode:output path (fun oc -> write oc text))
in
Lwt_list.iter_p f xs
let run (Command cmd) =
let open Lwt in
let script_file = Filename.temp_file "guizmin" ".sh" in
Misc.remove_if_exists cmd.env.tmp_dir >>= fun () ->
Unix.mkdir_p cmd.env.tmp ;
write_file_dumps cmd.file_dumps >>= fun () ->
Lwt_io.(with_file
~mode:output script_file
(fun oc -> write oc cmd.text)) >>= fun () ->
Misc.redirection cmd.env.stdout >>= fun stdout ->
Misc.redirection cmd.env.stderr >>= fun stderr ->
Lwt_process.exec ~stdout ~stderr ("", [| "sh" ; script_file |])
>>= fun status ->
Lwt_unix.unlink script_file >>= fun () ->
let exit_code = Caml.Unix.(
match status with
| WEXITED code
| WSIGNALED code
| WSTOPPED code -> code
)
in
let dest_exists = Sys.file_exists cmd.env.dest = `Yes in
(
if Execution_env.allows_docker cmd.env && cmd.uses_docker then (
Misc.docker_chown ~path:cmd.env.tmp_dir ~uid:cmd.env.uid >>= fun () ->
if dest_exists then Misc.docker_chown ~path:cmd.env.dest ~uid:cmd.env.uid
else Lwt.return ()
)
else Lwt.return ()
) >>= fun () ->
Lwt.return (exit_code, dest_exists)