GPS Exchange Format library/CLI in OCaml
anil.recoil.org
1(** GPX XML writer with complete spec coverage *)
2
3(** Result binding operators *)
4let (let*) = Result.bind
5
6(** Helper to write XML elements *)
7let output_element_start writer name attrs =
8 try
9 Xmlm.output writer (`El_start ((("", name), attrs)));
10 Ok ()
11 with exn ->
12 Error (Error.xml_error (Printexc.to_string exn))
13
14let output_element_end writer =
15 try
16 Xmlm.output writer `El_end;
17 Ok ()
18 with exn ->
19 Error (Error.xml_error (Printexc.to_string exn))
20
21let output_data writer text =
22 try
23 Xmlm.output writer (`Data text);
24 Ok ()
25 with exn ->
26 Error (Error.xml_error (Printexc.to_string exn))
27
28let output_text_element writer name text =
29 let attrs = [] in
30 let* () = output_element_start writer name attrs in
31 let* () = output_data writer text in
32 output_element_end writer
33
34let output_optional_text_element writer name = function
35 | Some text -> output_text_element writer name text
36 | None -> Ok ()
37
38let output_optional_float_element writer name = function
39 | Some value -> output_text_element writer name (Printf.sprintf "%.6f" value)
40 | None -> Ok ()
41
42let output_optional_degrees_element writer name = function
43 | Some degrees -> output_text_element writer name (Printf.sprintf "%.6f" (Coordinate.degrees_to_float degrees))
44 | None -> Ok ()
45
46let output_optional_int_element writer name = function
47 | Some value -> output_text_element writer name (string_of_int value)
48 | None -> Ok ()
49
50let output_optional_time_element writer name = function
51 | Some time -> output_text_element writer name (Ptime.to_rfc3339 time)
52 | None -> Ok ()
53
54let output_optional_fix_element writer name = function
55 | Some fix_type -> output_text_element writer name (Waypoint.fix_type_to_string fix_type)
56 | None -> Ok ()
57
58(** Write link elements *)
59let output_link writer link =
60 let href = Link.href link in
61 let attrs = [(("", "href"), href)] in
62 let* () = output_element_start writer "link" attrs in
63 let* () = output_optional_text_element writer "text" (Link.text link) in
64 let* () = output_optional_text_element writer "type" (Link.type_ link) in
65 output_element_end writer
66
67let output_links writer links =
68 let rec write_links = function
69 | [] -> Ok ()
70 | link :: rest ->
71 let* () = output_link writer link in
72 write_links rest
73 in
74 write_links links
75
76(** Write person (author) element *)
77let output_person writer person =
78 let* () = output_element_start writer "author" [] in
79 let* () = output_optional_text_element writer "name" (Link.person_name person) in
80 let* () = match Link.person_email person with
81 | Some email ->
82 (* Parse email into id and domain *)
83 (match String.index_opt email '@' with
84 | Some at_pos ->
85 let id = String.sub email 0 at_pos in
86 let domain = String.sub email (at_pos + 1) (String.length email - at_pos - 1) in
87 let attrs = [(("", "id"), id); (("", "domain"), domain)] in
88 let* () = output_element_start writer "email" attrs in
89 output_element_end writer
90 | None ->
91 (* Invalid email format, skip *)
92 Ok ())
93 | None -> Ok ()
94 in
95 let* () = match Link.person_link person with
96 | Some link -> output_link writer link
97 | None -> Ok ()
98 in
99 output_element_end writer
100
101(** Write copyright element *)
102let output_copyright writer copyright =
103 let author = Link.copyright_author copyright in
104 let attrs = [(("", "author"), author)] in
105 let* () = output_element_start writer "copyright" attrs in
106 let* () = output_optional_int_element writer "year" (Link.copyright_year copyright) in
107 let* () = output_optional_text_element writer "license" (Link.copyright_license copyright) in
108 output_element_end writer
109
110(** Write bounds element *)
111let output_bounds writer bounds =
112 let (minlat, minlon, maxlat, maxlon) = Metadata.Bounds.bounds bounds in
113 let attrs = [
114 (("", "minlat"), Printf.sprintf "%.6f" (Coordinate.latitude_to_float minlat));
115 (("", "minlon"), Printf.sprintf "%.6f" (Coordinate.longitude_to_float minlon));
116 (("", "maxlat"), Printf.sprintf "%.6f" (Coordinate.latitude_to_float maxlat));
117 (("", "maxlon"), Printf.sprintf "%.6f" (Coordinate.longitude_to_float maxlon));
118 ] in
119 let* () = output_element_start writer "bounds" attrs in
120 output_element_end writer
121
122(** Write extensions element *)
123let output_extensions writer extensions =
124 if extensions = [] then Ok ()
125 else
126 let* () = output_element_start writer "extensions" [] in
127 (* For now, skip writing extension content - would need full extension serialization *)
128 output_element_end writer
129
130(** Write metadata element *)
131let output_metadata writer metadata =
132 let* () = output_element_start writer "metadata" [] in
133 let* () = output_optional_text_element writer "name" (Metadata.name metadata) in
134 let* () = output_optional_text_element writer "desc" (Metadata.description metadata) in
135 let* () = match Metadata.author metadata with
136 | Some author -> output_person writer author
137 | None -> Ok ()
138 in
139 let* () = match Metadata.copyright metadata with
140 | Some copyright -> output_copyright writer copyright
141 | None -> Ok ()
142 in
143 let* () = output_links writer (Metadata.links metadata) in
144 let* () = output_optional_time_element writer "time" (Metadata.time metadata) in
145 let* () = output_optional_text_element writer "keywords" (Metadata.keywords metadata) in
146 let* () = match Metadata.bounds_opt metadata with
147 | Some bounds -> output_bounds writer bounds
148 | None -> Ok ()
149 in
150 let* () = output_extensions writer (Metadata.extensions metadata) in
151 output_element_end writer
152
153(** Write waypoint elements (used for wpt, rtept, trkpt) *)
154let output_waypoint_data writer waypoint =
155 let* () = output_optional_float_element writer "ele" (Waypoint.elevation waypoint) in
156 let* () = output_optional_time_element writer "time" (Waypoint.time waypoint) in
157 let* () = output_optional_degrees_element writer "magvar" (Waypoint.magvar waypoint) in
158 let* () = output_optional_float_element writer "geoidheight" (Waypoint.geoidheight waypoint) in
159 let* () = output_optional_text_element writer "name" (Waypoint.name waypoint) in
160 let* () = output_optional_text_element writer "cmt" (Waypoint.comment waypoint) in
161 let* () = output_optional_text_element writer "desc" (Waypoint.description waypoint) in
162 let* () = output_optional_text_element writer "src" (Waypoint.source waypoint) in
163 let* () = output_links writer (Waypoint.links waypoint) in
164 let* () = output_optional_text_element writer "sym" (Waypoint.symbol waypoint) in
165 let* () = output_optional_text_element writer "type" (Waypoint.type_ waypoint) in
166 let* () = output_optional_fix_element writer "fix" (Waypoint.fix waypoint) in
167 let* () = output_optional_int_element writer "sat" (Waypoint.sat waypoint) in
168 let* () = output_optional_float_element writer "hdop" (Waypoint.hdop waypoint) in
169 let* () = output_optional_float_element writer "vdop" (Waypoint.vdop waypoint) in
170 let* () = output_optional_float_element writer "pdop" (Waypoint.pdop waypoint) in
171 let* () = output_optional_float_element writer "ageofdgpsdata" (Waypoint.ageofdgpsdata waypoint) in
172 let* () = output_optional_int_element writer "dgpsid" (Waypoint.dgpsid waypoint) in
173 output_extensions writer (Waypoint.extensions waypoint)
174
175(** Write waypoints *)
176let output_waypoints writer waypoints =
177 let rec write_waypoints = function
178 | [] -> Ok ()
179 | wpt :: rest ->
180 let lat = Coordinate.latitude_to_float (Waypoint.lat wpt) in
181 let lon = Coordinate.longitude_to_float (Waypoint.lon wpt) in
182 let attrs = [
183 (("", "lat"), Printf.sprintf "%.6f" lat);
184 (("", "lon"), Printf.sprintf "%.6f" lon);
185 ] in
186 let* () = output_element_start writer "wpt" attrs in
187 let* () = output_waypoint_data writer wpt in
188 let* () = output_element_end writer in
189 write_waypoints rest
190 in
191 write_waypoints waypoints
192
193(** Write route points *)
194let output_route_points writer points element_name =
195 let rec write_points = function
196 | [] -> Ok ()
197 | pt :: rest ->
198 let lat = Coordinate.latitude_to_float (Waypoint.lat pt) in
199 let lon = Coordinate.longitude_to_float (Waypoint.lon pt) in
200 let attrs = [
201 (("", "lat"), Printf.sprintf "%.6f" lat);
202 (("", "lon"), Printf.sprintf "%.6f" lon);
203 ] in
204 let* () = output_element_start writer element_name attrs in
205 let* () = output_waypoint_data writer pt in
206 let* () = output_element_end writer in
207 write_points rest
208 in
209 write_points points
210
211(** Write routes *)
212let output_routes writer routes =
213 let rec write_routes = function
214 | [] -> Ok ()
215 | route :: rest ->
216 let* () = output_element_start writer "rte" [] in
217 let* () = output_optional_text_element writer "name" (Route.name route) in
218 let* () = output_optional_text_element writer "cmt" (Route.comment route) in
219 let* () = output_optional_text_element writer "desc" (Route.description route) in
220 let* () = output_optional_text_element writer "src" (Route.source route) in
221 let* () = output_links writer (Route.links route) in
222 let* () = output_optional_int_element writer "number" (Route.number route) in
223 let* () = output_optional_text_element writer "type" (Route.type_ route) in
224 let* () = output_extensions writer (Route.extensions route) in
225 let* () = output_route_points writer (Route.points route) "rtept" in
226 let* () = output_element_end writer in
227 write_routes rest
228 in
229 write_routes routes
230
231(** Write track segments *)
232let output_track_segments writer segments =
233 let rec write_segments = function
234 | [] -> Ok ()
235 | seg :: rest ->
236 let* () = output_element_start writer "trkseg" [] in
237 let* () = output_route_points writer (Track.Segment.points seg) "trkpt" in
238 let* () = output_extensions writer (Track.Segment.extensions seg) in
239 let* () = output_element_end writer in
240 write_segments rest
241 in
242 write_segments segments
243
244(** Write tracks *)
245let output_tracks writer tracks =
246 let rec write_tracks = function
247 | [] -> Ok ()
248 | track :: rest ->
249 let* () = output_element_start writer "trk" [] in
250 let* () = output_optional_text_element writer "name" (Track.name track) in
251 let* () = output_optional_text_element writer "cmt" (Track.comment track) in
252 let* () = output_optional_text_element writer "desc" (Track.description track) in
253 let* () = output_optional_text_element writer "src" (Track.source track) in
254 let* () = output_links writer (Track.links track) in
255 let* () = output_optional_int_element writer "number" (Track.number track) in
256 let* () = output_optional_text_element writer "type" (Track.type_ track) in
257 let* () = output_extensions writer (Track.extensions track) in
258 let* () = output_track_segments writer (Track.segments track) in
259 let* () = output_element_end writer in
260 write_tracks rest
261 in
262 write_tracks tracks
263
264(** Write a complete GPX document *)
265let write ?(validate=false) output gpx =
266 let writer = Xmlm.make_output output in
267
268 let result =
269 try
270 (* Write XML declaration and GPX root element *)
271 let version = Doc.version gpx in
272 let creator = Doc.creator gpx in
273 let attrs = [
274 (("", "version"), version);
275 (("", "creator"), creator);
276 (("", "xsi:schemaLocation"), "http://www.topografix.com/GPX/1/1 http://www.topografix.com/GPX/1/1/gpx.xsd");
277 (("xmlns", "xsi"), "http://www.w3.org/2001/XMLSchema-instance");
278 (("", "xmlns"), "http://www.topografix.com/GPX/1/1")
279 ] in
280
281 let* () = output_element_start writer "gpx" attrs in
282
283 (* Write metadata if present *)
284 let* () = match Doc.metadata gpx with
285 | Some metadata -> output_metadata writer metadata
286 | None -> Ok ()
287 in
288
289 (* Write waypoints *)
290 let* () = output_waypoints writer (Doc.waypoints gpx) in
291
292 (* Write routes *)
293 let* () = output_routes writer (Doc.routes gpx) in
294
295 (* Write tracks *)
296 let* () = output_tracks writer (Doc.tracks gpx) in
297
298 (* Write root-level extensions *)
299 let* () = output_extensions writer (Doc.extensions gpx) in
300
301 output_element_end writer
302
303 with
304 | Xmlm.Error ((line, col), error) ->
305 Error (Error.xml_error (Printf.sprintf "XML error at line %d, column %d: %s"
306 line col (Xmlm.error_message error)))
307 | exn ->
308 Error (Error.xml_error (Printexc.to_string exn))
309 in
310
311 match result, validate with
312 | Ok (), true ->
313 let validation = Validate.validate_gpx gpx in
314 if validation.is_valid then
315 Ok ()
316 else
317 let error_msgs = List.filter (fun issue -> issue.Validate.level = `Error) validation.issues
318 |> List.map (fun issue -> issue.Validate.message)
319 |> String.concat "; " in
320 Error (Error.validation_error error_msgs)
321 | result, false -> result
322 | Error _ as result, true -> result (* Pass through write errors even when validating *)
323
324(** Write GPX to string *)
325let write_string ?(validate=false) gpx =
326 let buffer = Buffer.create 1024 in
327 let dest = `Buffer buffer in
328 let* () = write ~validate dest gpx in
329 Ok (Buffer.contents buffer)