patrick.sirref.org
1(** GPX validation utilities *)
2
3open Types
4
5(** Validation error messages *)
6type validation_issue = {
7 level : [`Error | `Warning];
8 message : string;
9 location : string option;
10}
11
12type validation_result = {
13 issues : validation_issue list;
14 is_valid : bool;
15}
16
17let make_error ?location message = {
18 level = `Error;
19 message;
20 location;
21}
22
23let make_warning ?location message = {
24 level = `Warning;
25 message;
26 location;
27}
28
29(** Validate waypoint data *)
30let validate_waypoint_data wpt location =
31 let issues = ref [] in
32
33 (* Check for negative satellite count *)
34 (match wpt.sat with
35 | Some sat when sat < 0 ->
36 issues := make_warning ~location ("Negative satellite count: " ^ string_of_int sat) :: !issues
37 | _ -> ());
38
39 (* Check for unreasonable precision values *)
40 let check_precision name value =
41 match value with
42 | Some v when v < 0.0 ->
43 issues := make_warning ~location (Printf.sprintf "Negative %s value: %.2f" name v) :: !issues
44 | Some v when v > 1000.0 ->
45 issues := make_warning ~location (Printf.sprintf "Very large %s value: %.2f" name v) :: !issues
46 | _ -> ()
47 in
48
49 check_precision "hdop" wpt.hdop;
50 check_precision "vdop" wpt.vdop;
51 check_precision "pdop" wpt.pdop;
52
53 (* Check elevation reasonableness *)
54 (match wpt.ele with
55 | Some ele when ele < -15000.0 ->
56 issues := make_warning ~location (Printf.sprintf "Very low elevation: %.2f m" ele) :: !issues
57 | Some ele when ele > 15000.0 ->
58 issues := make_warning ~location (Printf.sprintf "Very high elevation: %.2f m" ele) :: !issues
59 | _ -> ());
60
61 (* Check DGPS age *)
62 (match wpt.ageofdgpsdata with
63 | Some age when age < 0.0 ->
64 issues := make_error ~location "Negative DGPS age" :: !issues
65 | _ -> ());
66
67 !issues
68
69(** Validate bounds *)
70let validate_bounds bounds =
71 let issues = ref [] in
72 let location = "bounds" in
73
74 if latitude_to_float bounds.minlat >= latitude_to_float bounds.maxlat then
75 issues := make_error ~location "minlat must be less than maxlat" :: !issues;
76
77 if longitude_to_float bounds.minlon >= longitude_to_float bounds.maxlon then
78 issues := make_error ~location "minlon must be less than maxlon" :: !issues;
79
80 !issues
81
82(** Validate metadata *)
83let validate_metadata metadata =
84 let issues = ref [] in
85
86 (* Validate bounds if present *)
87 (match metadata.bounds with
88 | Some bounds -> issues := validate_bounds bounds @ !issues
89 | None -> ());
90
91 (* Check for reasonable copyright year *)
92 (match metadata.copyright with
93 | Some copyright ->
94 (match copyright.year with
95 | Some year when year < 1900 || year > 2100 ->
96 issues := make_warning ~location:"metadata.copyright"
97 (Printf.sprintf "Unusual copyright year: %d" year) :: !issues
98 | _ -> ())
99 | None -> ());
100
101 !issues
102
103(** Validate route *)
104let validate_route route =
105 let issues = ref [] in
106 let location = "route" in
107
108 (* Check for empty route *)
109 if route.rtepts = [] then
110 issues := make_warning ~location "Route has no points" :: !issues;
111
112 (* Validate route points *)
113 List.iteri (fun i rtept ->
114 let point_location = Printf.sprintf "route.rtept[%d]" i in
115 issues := validate_waypoint_data rtept point_location @ !issues
116 ) route.rtepts;
117
118 !issues
119
120(** Validate track segment *)
121let validate_track_segment trkseg seg_idx =
122 let issues = ref [] in
123 let location = Printf.sprintf "track.trkseg[%d]" seg_idx in
124
125 (* Check for empty segment *)
126 if trkseg.trkpts = [] then
127 issues := make_warning ~location "Track segment has no points" :: !issues;
128
129 (* Validate track points *)
130 List.iteri (fun i trkpt ->
131 let point_location = Printf.sprintf "%s.trkpt[%d]" location i in
132 issues := validate_waypoint_data trkpt point_location @ !issues
133 ) trkseg.trkpts;
134
135 (* Check for time ordering if timestamps are present *)
136 let rec check_time_order prev_time = function
137 | [] -> ()
138 | trkpt :: rest ->
139 (match (prev_time, trkpt.time) with
140 | (Some prev, Some curr) when Ptime.compare prev curr > 0 ->
141 issues := make_warning ~location "Track points not in chronological order" :: !issues
142 | _ -> ());
143 check_time_order trkpt.time rest
144 in
145 check_time_order None trkseg.trkpts;
146
147 !issues
148
149(** Validate track *)
150let validate_track track =
151 let issues = ref [] in
152 let location = "track" in
153
154 (* Check for empty track *)
155 if track.trksegs = [] then
156 issues := make_warning ~location "Track has no segments" :: !issues;
157
158 (* Validate track segments *)
159 List.iteri (fun i trkseg ->
160 issues := validate_track_segment trkseg i @ !issues
161 ) track.trksegs;
162
163 !issues
164
165(** Validate complete GPX document *)
166let validate_gpx gpx =
167 let issues = ref [] in
168
169 (* Check GPX version *)
170 if gpx.version <> "1.0" && gpx.version <> "1.1" then
171 issues := make_error ~location:"gpx"
172 (Printf.sprintf "Unsupported GPX version: %s (supported: 1.0, 1.1)" gpx.version) :: !issues
173 else if gpx.version = "1.0" then
174 issues := make_warning ~location:"gpx"
175 "GPX 1.0 detected - consider upgrading to GPX 1.1 for better compatibility" :: !issues;
176
177 (* Check for empty creator *)
178 if String.trim gpx.creator = "" then
179 issues := make_error ~location:"gpx" "Creator cannot be empty" :: !issues;
180
181 (* Validate metadata *)
182 (match gpx.metadata with
183 | Some metadata -> issues := validate_metadata metadata @ !issues
184 | None -> ());
185
186 (* Validate waypoints *)
187 List.iteri (fun i wpt ->
188 let location = Printf.sprintf "waypoint[%d]" i in
189 issues := validate_waypoint_data wpt location @ !issues
190 ) gpx.waypoints;
191
192 (* Validate routes *)
193 List.iteri (fun _i route ->
194 issues := validate_route route @ !issues
195 ) gpx.routes;
196
197 (* Validate tracks *)
198 List.iteri (fun _i track ->
199 issues := validate_track track @ !issues
200 ) gpx.tracks;
201
202 (* Check for completely empty GPX *)
203 if gpx.waypoints = [] && gpx.routes = [] && gpx.tracks = [] then
204 issues := make_warning ~location:"gpx" "GPX document contains no geographic data" :: !issues;
205
206 let all_issues = !issues in
207 let has_errors = List.exists (fun issue -> issue.level = `Error) all_issues in
208
209 { issues = all_issues; is_valid = not has_errors }
210
211(** Quick validation - returns true if document is valid *)
212let is_valid gpx =
213 let result = validate_gpx gpx in
214 result.is_valid
215
216(** Get only error messages *)
217let get_errors gpx =
218 let result = validate_gpx gpx in
219 List.filter (fun issue -> issue.level = `Error) result.issues
220
221(** Get only warning messages *)
222let get_warnings gpx =
223 let result = validate_gpx gpx in
224 List.filter (fun issue -> issue.level = `Warning) result.issues
225
226(** Format validation issue for display *)
227let format_issue issue =
228 let level_str = match issue.level with
229 | `Error -> "ERROR"
230 | `Warning -> "WARNING"
231 in
232 let location_str = match issue.location with
233 | Some loc -> " at " ^ loc
234 | None -> ""
235 in
236 Printf.sprintf "%s%s: %s" level_str location_str issue.message