Source file execution_trace.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
open Core_kernel
module Outcome = struct
type t = [
| `Succeeded
| `Missing_output
| `Error_exit_code of int
| `Plugin_failure of string
| `Scheduler_error of string
]
let is_success = function
| `Succeeded -> true
| `Plugin_failure _ | `Missing_output
| `Error_exit_code _ | `Scheduler_error _ -> false
end
module Run_details = struct
type t =
| Input of { id : string ; path : string ; pass : bool }
| Select of { id : string ; dir_path : string ; sel : string list ; pass : bool }
| Shell of {
id : string ;
descr : string ;
outcome : Outcome.t ;
cmd : string ;
file_dumps : Shell_command.file_dump list ;
cache : string option ;
stdout : string ;
stderr : string ;
}
| Plugin of {
id : string ;
descr : string ;
outcome : Outcome.t ;
}
| Container_image_fetch of {
id : string ;
outcome : (unit, [ `Singularity_failed_pull of int * string ]) result
}
let id = function
| Input { id ; _ }
| Select { id ; _}
| Shell { id ; _ }
| Plugin { id ; _ }
| Container_image_fetch { id ; _ } -> id
let name = function
| Input { id ; path ; _ } -> sprintf "input(%s, %s)" id path
| Select { dir_path ; sel ; _ } ->
sprintf "select(%s, %s)" dir_path (Path.to_string sel)
| Shell { id ; descr ; _ } -> sprintf "shell(%s,%s)" descr id
| Plugin { id ; descr ; _ } -> sprintf "plugin(%s,%s)" descr id
| Container_image_fetch { id ; _ } -> sprintf "container_image_fetch(%s)" id
let succeeded = function
| Input { pass ; _ }
| Select { pass ; _ } -> pass
| Container_image_fetch { outcome = Ok (); _ } -> true
| Container_image_fetch _ -> false
| Plugin { outcome ; _ }
| Shell { outcome ; _ } -> Outcome.is_success outcome
let error_short_descr_of_outcome = function
| `Missing_output -> "Missing output"
| `Error_exit_code i ->
sprintf "Ended with exit code %d" i
| `Succeeded ->
let msg = "Execution_trace.error_short_descr: not an error result" in
raise (Invalid_argument msg)
| `Plugin_failure msg -> sprintf "Plugin failure: %s" msg
| `Scheduler_error msg -> sprintf "Scheduler failure: %s" msg
let error_short_descr = function
| Input { path ; _ } -> sprintf "Input %s doesn't exist" path
| Select { dir_path ; sel ; _ } ->
sprintf "Path %s doesn't exist in %s" (Path.to_string sel) dir_path
| Container_image_fetch _ -> sprintf "Container image could not be fetched"
| Shell x -> error_short_descr_of_outcome x.outcome
| Plugin o -> error_short_descr_of_outcome o.outcome
let error_long_descr x db buf id = match x with
| Input _ | Select _ -> ()
| Plugin _ -> ()
| Shell x ->
(
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "| Submitted script |\n" ;
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "%s\n" x.cmd
) ;
List.iter x.file_dumps ~f:(fun (Shell_command.File_dump { path ; text }) ->
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "|> Dumped file: %s\n" path ;
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "%s\n" text ;
) ;
bprintf buf "#\n" ;
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "| STDOUT |\n" ;
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "%s\n" (In_channel.read_all (Db.stdout db id)) ;
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "| STDERR |\n" ;
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "%s\n" (In_channel.read_all (Db.stderr db id))
| Container_image_fetch x ->
match x.outcome with
| Ok () -> assert false
| Error (`Singularity_failed_pull (_, url)) ->
(
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "| Image URL |\n" ;
bprintf buf "+------------------------------------------------------------------------------+\n" ;
bprintf buf "%s\n" url
)
end
type time = float
type t =
| Run of { ready : time ;
start : time ;
_end_ : time ;
details : Run_details.t }
| Done_already of { id : string }
| Canceled of {
id : string ;
missing_deps : t list ;
}
| Allocation_error of {
id : string ;
msg : string ;
}
module S = struct
module Elt = struct type nonrec t = t let compare = Poly.compare end
include Caml.Set.Make(Elt)
end
let is_errored = function
| Run { details ; _ } -> not (Run_details.succeeded details)
| Allocation_error _
| Canceled _ -> true
| Done_already _ -> false
let gather_failures traces =
List.fold traces ~init:S.empty ~f:(fun acc t ->
match t with
| Done_already _ -> acc
| Run { details ; _ } ->
if Run_details.succeeded details then
acc
else
S.add t acc
| Canceled { missing_deps ; _ } ->
List.fold ~f:(Fn.flip S.add) ~init:acc missing_deps
| Allocation_error _ -> S.add t acc
)
|> S.elements
let error_title buf title short_desc =
bprintf buf "################################################################################\n" ;
bprintf buf "# #\n" ;
bprintf buf "# %s\n" title ;
bprintf buf "# \n" ;
bprintf buf "#------------------------------------------------------------------------------#\n" ;
bprintf buf "# \n" ;
bprintf buf "# %s\n" short_desc ;
bprintf buf "# #\n" ;
bprintf buf "################################################################################\n" ;
bprintf buf "###\n" ;
bprintf buf "##\n" ;
bprintf buf "#\n"
let error_report trace db buf =
match trace with
| Run { details ; _ } ->
if not (Run_details.succeeded details) then
let title = sprintf "Task %s failed\n" (Run_details.name details) in
let short_descr = Run_details.error_short_descr details in
error_title buf title short_descr ;
Run_details.error_long_descr details db buf (Run_details.id details)
| Allocation_error { id ; msg } ->
let title = sprintf "Task %s failed\n" id in
let short_descr = sprintf "Allocation error: %s\n" msg in
error_title buf title short_descr
| (Done_already _ | Canceled _) -> ()
let all_ok xs = not (List.exists ~f:is_errored xs)
module Set = S