patrick.sirref.org
1(** GPX streaming writer using xmlm *)
2
3open Types
4
5(** Result binding operators *)
6let (let*) = Result.bind
7
8(** Writer state for streaming *)
9type writer_state = {
10 output : Xmlm.output;
11}
12
13(** Create a new writer state *)
14let make_writer output = { output }
15
16(** Utility functions *)
17
18let convert_attributes attrs =
19 List.map (fun (name, value) -> (("", name), value)) attrs
20
21let output_signal writer signal =
22 try
23 Xmlm.output writer.output signal;
24 Ok ()
25 with
26 | Xmlm.Error ((line, col), error) ->
27 Error (Xml_error (Printf.sprintf "XML error at line %d, column %d: %s"
28 line col (Xmlm.error_message error)))
29 | exn ->
30 Error (Invalid_xml (Printexc.to_string exn))
31
32let output_element_start writer name attrs =
33 output_signal writer (`El_start (("", name), attrs))
34
35let output_element_end writer =
36 output_signal writer `El_end
37
38let output_data writer text =
39 if text <> "" then
40 output_signal writer (`Data text)
41 else
42 Ok ()
43
44let output_text_element writer name text =
45 let* () = output_element_start writer name [] in
46 let* () = output_data writer text in
47 output_element_end writer
48
49let output_optional_text_element writer name = function
50 | Some text -> output_text_element writer name text
51 | None -> Ok ()
52
53let output_float_element writer name f =
54 output_text_element writer name (Printf.sprintf "%.6f" f)
55
56let output_optional_float_element writer name = function
57 | Some f -> output_float_element writer name f
58 | None -> Ok ()
59
60let output_int_element writer name i =
61 output_text_element writer name (string_of_int i)
62
63let output_optional_int_element writer name = function
64 | Some i -> output_int_element writer name i
65 | None -> Ok ()
66
67let output_time_element writer name time =
68 output_text_element writer name (Ptime.to_rfc3339 time)
69
70let output_optional_time_element writer name = function
71 | Some time -> output_time_element writer name time
72 | None -> Ok ()
73
74(** Write GPX header and DTD *)
75let write_header writer =
76 let* () = output_signal writer (`Dtd None) in
77 Ok ()
78
79(** Write link element *)
80let write_link writer link =
81 let attrs = [(("" , "href"), link.href)] in
82 let* () = output_element_start writer "link" attrs in
83 let* () = output_optional_text_element writer "text" link.text in
84 let* () = output_optional_text_element writer "type" link.type_ in
85 output_element_end writer
86
87(** Write list of links *)
88let write_links writer links =
89 let rec loop = function
90 | [] -> Ok ()
91 | link :: rest ->
92 let* () = write_link writer link in
93 loop rest
94 in
95 loop links
96
97(** Write extension content *)
98let rec write_extension_content writer = function
99 | Text text -> output_data writer text
100 | Elements extensions -> write_extensions writer extensions
101 | Mixed (text, extensions) ->
102 let* () = output_data writer text in
103 write_extensions writer extensions
104
105(** Write extensions *)
106and write_extensions writer extensions =
107 let rec loop = function
108 | [] -> Ok ()
109 | ext :: rest ->
110 let* () = write_extension writer ext in
111 loop rest
112 in
113 loop extensions
114
115and write_extension writer ext =
116 let name = match ext.namespace with
117 | Some ns -> ns ^ ":" ^ ext.name
118 | None -> ext.name
119 in
120 let* () = output_element_start writer name (convert_attributes ext.attributes) in
121 let* () = write_extension_content writer ext.content in
122 output_element_end writer
123
124(** Write waypoint data (shared by wpt, rtept, trkpt) *)
125let write_waypoint_data writer element_name wpt =
126 let attrs = [
127 (("", "lat"), Printf.sprintf "%.6f" (latitude_to_float wpt.lat));
128 (("", "lon"), Printf.sprintf "%.6f" (longitude_to_float wpt.lon));
129 ] in
130 let* () = output_element_start writer element_name attrs in
131 let* () = output_optional_float_element writer "ele" wpt.ele in
132 let* () = output_optional_time_element writer "time" wpt.time in
133 let* () = (match wpt.magvar with
134 | Some deg -> output_float_element writer "magvar" (degrees_to_float deg)
135 | None -> Ok ()) in
136 let* () = output_optional_float_element writer "geoidheight" wpt.geoidheight in
137 let* () = output_optional_text_element writer "name" wpt.name in
138 let* () = output_optional_text_element writer "cmt" wpt.cmt in
139 let* () = output_optional_text_element writer "desc" wpt.desc in
140 let* () = output_optional_text_element writer "src" wpt.src in
141 let* () = write_links writer wpt.links in
142 let* () = output_optional_text_element writer "sym" wpt.sym in
143 let* () = output_optional_text_element writer "type" wpt.type_ in
144 let* () = (match wpt.fix with
145 | Some fix -> output_text_element writer "fix" (fix_type_to_string fix)
146 | None -> Ok ()) in
147 let* () = output_optional_int_element writer "sat" wpt.sat in
148 let* () = output_optional_float_element writer "hdop" wpt.hdop in
149 let* () = output_optional_float_element writer "vdop" wpt.vdop in
150 let* () = output_optional_float_element writer "pdop" wpt.pdop in
151 let* () = output_optional_float_element writer "ageofdgpsdata" wpt.ageofdgpsdata in
152 let* () = output_optional_int_element writer "dgpsid" wpt.dgpsid in
153 let* () = (if wpt.extensions <> [] then
154 let* () = output_element_start writer "extensions" [] in
155 let* () = write_extensions writer wpt.extensions in
156 output_element_end writer
157 else Ok ()) in
158 output_element_end writer
159
160(** Write waypoint *)
161let write_waypoint writer wpt =
162 write_waypoint_data writer "wpt" wpt
163
164(** Write route point *)
165let write_route_point writer rtept =
166 write_waypoint_data writer "rtept" rtept
167
168(** Write track point *)
169let write_track_point writer trkpt =
170 write_waypoint_data writer "trkpt" trkpt
171
172(** Write person *)
173let write_person writer (p : person) =
174 let* () = output_element_start writer "author" [] in
175 let* () = output_optional_text_element writer "name" p.name in
176 let* () = output_optional_text_element writer "email" p.email in
177 let* () = (match p.link with
178 | Some link -> write_link writer link
179 | None -> Ok ()) in
180 output_element_end writer
181
182(** Write copyright *)
183let write_copyright writer (copyright : copyright) =
184 let attrs = [(("", "author"), copyright.author)] in
185 let* () = output_element_start writer "copyright" attrs in
186 let* () = (match copyright.year with
187 | Some year -> output_int_element writer "year" year
188 | None -> Ok ()) in
189 let* () = output_optional_text_element writer "license" copyright.license in
190 output_element_end writer
191
192(** Write bounds *)
193let write_bounds writer bounds =
194 let attrs = [
195 (("", "minlat"), Printf.sprintf "%.6f" (latitude_to_float bounds.minlat));
196 (("", "minlon"), Printf.sprintf "%.6f" (longitude_to_float bounds.minlon));
197 (("", "maxlat"), Printf.sprintf "%.6f" (latitude_to_float bounds.maxlat));
198 (("", "maxlon"), Printf.sprintf "%.6f" (longitude_to_float bounds.maxlon));
199 ] in
200 let* () = output_element_start writer "bounds" attrs in
201 output_element_end writer
202
203(** Write metadata *)
204let write_metadata writer (metadata : metadata) =
205 let* () = output_element_start writer "metadata" [] in
206 let* () = output_optional_text_element writer "name" metadata.name in
207 let* () = output_optional_text_element writer "desc" metadata.desc in
208 let* () = (match metadata.author with
209 | Some author -> write_person writer author
210 | None -> Ok ()) in
211 let* () = (match metadata.copyright with
212 | Some copyright -> write_copyright writer copyright
213 | None -> Ok ()) in
214 let* () = write_links writer metadata.links in
215 let* () = output_optional_time_element writer "time" metadata.time in
216 let* () = output_optional_text_element writer "keywords" metadata.keywords in
217 let* () = (match metadata.bounds with
218 | Some bounds -> write_bounds writer bounds
219 | None -> Ok ()) in
220 let* () = (if metadata.extensions <> [] then
221 let* () = output_element_start writer "extensions" [] in
222 let* () = write_extensions writer metadata.extensions in
223 output_element_end writer
224 else Ok ()) in
225 output_element_end writer
226
227(** Write route *)
228let write_route writer (route : route) =
229 let* () = output_element_start writer "rte" [] in
230 let* () = output_optional_text_element writer "name" route.name in
231 let* () = output_optional_text_element writer "cmt" route.cmt in
232 let* () = output_optional_text_element writer "desc" route.desc in
233 let* () = output_optional_text_element writer "src" route.src in
234 let* () = write_links writer route.links in
235 let* () = output_optional_int_element writer "number" route.number in
236 let* () = output_optional_text_element writer "type" route.type_ in
237 let* () = (if route.extensions <> [] then
238 let* () = output_element_start writer "extensions" [] in
239 let* () = write_extensions writer route.extensions in
240 output_element_end writer
241 else Ok ()) in
242 let* () =
243 let rec loop = function
244 | [] -> Ok ()
245 | rtept :: rest ->
246 let* () = write_route_point writer rtept in
247 loop rest
248 in
249 loop route.rtepts
250 in
251 output_element_end writer
252
253(** Write track segment *)
254let write_track_segment writer trkseg =
255 let* () = output_element_start writer "trkseg" [] in
256 let* () =
257 let rec loop = function
258 | [] -> Ok ()
259 | trkpt :: rest ->
260 let* () = write_track_point writer trkpt in
261 loop rest
262 in
263 loop trkseg.trkpts
264 in
265 let* () = (if trkseg.extensions <> [] then
266 let* () = output_element_start writer "extensions" [] in
267 let* () = write_extensions writer trkseg.extensions in
268 output_element_end writer
269 else Ok ()) in
270 output_element_end writer
271
272(** Write track *)
273let write_track writer track =
274 let* () = output_element_start writer "trk" [] in
275 let* () = output_optional_text_element writer "name" track.name in
276 let* () = output_optional_text_element writer "cmt" track.cmt in
277 let* () = output_optional_text_element writer "desc" track.desc in
278 let* () = output_optional_text_element writer "src" track.src in
279 let* () = write_links writer track.links in
280 let* () = output_optional_int_element writer "number" track.number in
281 let* () = output_optional_text_element writer "type" track.type_ in
282 let* () = (if track.extensions <> [] then
283 let* () = output_element_start writer "extensions" [] in
284 let* () = write_extensions writer track.extensions in
285 output_element_end writer
286 else Ok ()) in
287 let* () =
288 let rec loop = function
289 | [] -> Ok ()
290 | trkseg :: rest ->
291 let* () = write_track_segment writer trkseg in
292 loop rest
293 in
294 loop track.trksegs
295 in
296 output_element_end writer
297
298(** Write complete GPX document *)
299let write_gpx writer gpx =
300 let* () = write_header writer in
301 let attrs = [
302 (("", "version"), gpx.version);
303 (("", "creator"), gpx.creator);
304 (("", "xmlns"), "http://www.topografix.com/GPX/1/1");
305 (("http://www.w3.org/2000/xmlns/", "xsi"), "http://www.w3.org/2001/XMLSchema-instance");
306 (("http://www.w3.org/2001/XMLSchema-instance", "schemaLocation"), "http://www.topografix.com/GPX/1/1 http://www.topografix.com/GPX/1/1/gpx.xsd");
307 ] in
308 let* () = output_element_start writer "gpx" attrs in
309 let* () = (match gpx.metadata with
310 | Some metadata -> write_metadata writer metadata
311 | None -> Ok ()) in
312 let* () =
313 let rec loop = function
314 | [] -> Ok ()
315 | wpt :: rest ->
316 let* () = write_waypoint writer wpt in
317 loop rest
318 in
319 loop gpx.waypoints
320 in
321 let* () =
322 let rec loop = function
323 | [] -> Ok ()
324 | rte :: rest ->
325 let* () = write_route writer rte in
326 loop rest
327 in
328 loop gpx.routes
329 in
330 let* () =
331 let rec loop = function
332 | [] -> Ok ()
333 | trk :: rest ->
334 let* () = write_track writer trk in
335 loop rest
336 in
337 loop gpx.tracks
338 in
339 let* () = (if gpx.extensions <> [] then
340 let* () = output_element_start writer "extensions" [] in
341 let* () = write_extensions writer gpx.extensions in
342 output_element_end writer
343 else Ok ()) in
344 output_element_end writer
345
346(** Main writing function *)
347let write output gpx =
348 let writer = make_writer output in
349 write_gpx writer gpx
350
351(** Write to string *)
352let write_string gpx =
353 let buffer = Buffer.create 1024 in
354 let output = Xmlm.make_output (`Buffer buffer) in
355 let result = write output gpx in
356 match result with
357 | Ok () -> Ok (Buffer.contents buffer)
358 | Error e -> Error e