1. james woodyatt
  2. oni

Source

oni / nx / nx_uri.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
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
(*---------------------------------------------------------------------------*
  $Change$
  Copyright (c) 2003-2010, James H. Woodyatt
  All rights reserved.
  
  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:
  
    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.
    
    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution
  
  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

open Cf_flow.Op
open Cf_llscan.Op
open Cf_clex.Op

let ch_is_up_alpha_ = function 'A'..'Z' -> true | _ -> false
let ch_is_dn_alpha_ = function 'a'..'z' -> true | _ -> false
let ch_is_digit_ = function '0'..'9' -> true | _ -> false
let ch_is_hex_ = function ('0'..'9' | 'A'..'F' | 'a'..'f') -> true | _ -> false

let ch_is_reserved_ = function
    | (';' | '/' | '?' | ':' | '@' | '&' | '=' | '+' | '$' | ',') -> true
    | _ -> false

let ch_is_reserved_no_slash_ = function
    | '/' -> false
    | c -> ch_is_reserved_ c

let ch_is_reserved_in_rel_segment_ = function
    | ('/' | '?' | ':') -> false
    | c -> ch_is_reserved_ c

let ch_is_reserved_in_rel_segment_no_semi_ = function
    | ';' -> false
    | c -> ch_is_reserved_in_rel_segment_ c

let ch_is_reserved_in_pchar_ = function
    | ('/' | '?' | ';') -> false
    | c -> ch_is_reserved_ c

let ch_is_reserved_in_userinfo_ = function
    | ('/' | '?') -> false
    | c -> ch_is_reserved_ c

let ch_is_mark_ = function
    | ('-' | '_' | '.' | '!' | '~' | '*' | '\'' | '(' | ')') -> true
    | _ -> false

let ch_is_unreserved_ = function
    | 'A'..'Z'
    | 'a'..'z'
    | '0'..'9' ->
        true
    | ch ->
        ch_is_mark_ ch

let x_up_alpha_ = !^ch_is_up_alpha_
let x_dn_alpha_ = !^ch_is_dn_alpha_
let x_digit_ = !^ch_is_digit_
let x_hex_ = !^ch_is_hex_
let x_alpha_ = x_up_alpha_ $| x_dn_alpha_
let x_alphanum_ = x_alpha_ $| x_digit_

let x_plus_ = !:'+'
let x_hyphen_ = !:'-'
let x_dot_ = !:'.'
let x_percent_ = !:'%'

let x_escaped_ = x_percent_ $& x_hex_ $& x_hex_
let x_unreserved_ = x_alphanum_ $| !^ch_is_mark_
let x_reserved_ = !^ch_is_reserved_

let x_uric_ = x_reserved_ $| x_unreserved_ $| x_escaped_
let x_uric_no_slash_ =
    !^ch_is_reserved_no_slash_ $| x_unreserved_ $| x_escaped_

let x_pchar_ = !^ch_is_reserved_in_pchar_ $| x_unreserved_ $| x_escaped_

(*
let x_semicolon_ = !:';'
let x_query_ = !:'?'
let x_colon_ = !:':'
let x_at_ = !:'@'
let x_ampersand_ = !:'&'
let x_equal_ = !:'='
let x_dollar_ = !:'$'
let x_comma_ = !:','
let x_bang_ = !:'!'
let x_tilde_ = !:'~'
let x_star_ = !:'*'
let x_tick_ = !:'\''
let x_underscore_ = !:'_'
let x_lparen_ = !:'('
let x_rparen_ = !:')'
*)

let int_of_A_ = (int_of_char 'A') - 10
let int_of_a_ = (int_of_char 'a') - 10
let int_of_0_ = int_of_char '0'

let int_of_hex_char_ c =
    let n0 =
        match c with
        | 'A'..'F' -> int_of_A_
        | 'a'..'f' -> int_of_a_
        | '0'..'9' -> int_of_0_ 
        | _ -> assert (not true); 0
    in
    (int_of_char c) - n0

let hex_char_of_int_ n =
    assert (n >= 0 && n < 16);
    char_of_int (n + (if n > 9 then int_of_a_ else int_of_0_))

let rec w_escape_ =
    let rec loop f c =
        let self = w_escape_ f in
        if (ch_is_unreserved_ c) or (f c) then
            Cf_flow.P (c, self)
        else begin
            let n = int_of_char c in
            let c1 = hex_char_of_int_ (n land 0xF) in
            let z1 = Lazy.lazy_from_val (Cf_flow.P (c1, self)) in
            let c0 = hex_char_of_int_ ((n land 0xF0) lsr 4) in
            let z0 = Lazy.lazy_from_val (Cf_flow.P (c0, z1)) in
            Cf_flow.P ('%', z0)
        end
    in
    fun f ->
        Lazy.lazy_from_val (Cf_flow.Q (loop f))

let rec w_unescape_ =
    let rec loop c =
        let self = w_unescape_ () in
        match c with
        | '%' ->
            Cf_flow.Q begin fun c ->
                let n0 = int_of_hex_char_ c in
                Cf_flow.Q begin fun c ->
                    let n1 = int_of_hex_char_ c in
                    Cf_flow.P (char_of_int (n0 * 16 + n1), self)
                end
            end
        | x ->
            Cf_flow.P (x, self)
    in
    fun () ->
        Lazy.lazy_from_val (Cf_flow.Q loop)

let escape ?(allow = (fun _ -> false)) =
    let w = w_escape_ allow in
    fun s -> Cf_seq.to_string (Cf_flow.commute w (Cf_seq.of_string s))

let unescape s =
    Cf_seq.to_string (Cf_flow.commute (w_unescape_ ()) (Cf_seq.of_string s))

let p_colon_ s = ?.':' s
let p_semicolon_ s = ?.';' s
let p_slash_ s = ?.'/' s
let p_dot_ s = ?.'.' s
let p_at_ s = ?.'@' s

let p_slashslash_ s =
    let m =
        ?.'/' >>= fun _ ->
        ?.'/' >>= fun _ ->
        Cf_llscan.ret ()
    in
    m s

let p_scheme_ = Cf_clex.create begin
    x_alpha_ $& !*(x_alpha_ $| x_digit_ $| x_plus_ $| x_hyphen_ $| x_dot_) $>
    String.lowercase
end

let p_opaque_part_ =
    Cf_clex.create (x_uric_ $& !*x_uric_no_slash_ $> unescape)

let p_uric_string_ =
    Cf_clex.create (!*x_uric_ $> (fun x -> (x : string)))

let p_hostname_ =
    let x_label_suffix_ = !*(x_alphanum_ $| x_hyphen_) $& x_alphanum_ in
    let x_toplabel_ = x_alpha_ $| (x_alpha_ $& x_label_suffix_) in
    let x_domainlabel_ = x_alphanum_ $| (x_alphanum_ $& x_label_suffix_) in
    let x_hostname_ =
        !*(x_domainlabel_ $& x_dot_) $& x_toplabel_ $& !?x_dot_
    in
    Cf_clex.create (x_hostname_ $> String.lowercase)

let p_ipv4_addr_ =
    let x_num = !+ !^ch_is_digit_ in
    let x_ip4_addr = x_num $& x_num $& x_num $& x_num in
    let action lim s =
        let s1 = Cf_seq.limit lim s in
        match Nx_ip4_addr.pton (Cf_seq.to_string s1) with
        | Some addr -> Some (addr, Cf_seq.shift lim s)
        | None -> None
        
    in    
    Cf_clex.create (x_ip4_addr $@ action)

type host =
    | H_hostname of string
    | H_ip4_addr of Nx_ip4_addr.opaque Nx_ip4_addr.t

let p_userinfo_ =
    Cf_clex.create begin
        x_unreserved_ $| x_escaped_ $| !^ch_is_reserved_in_userinfo_ $>
        unescape
    end

type server = {
    srv_user: string option;
    srv_host: host;
    srv_port: int option;
}

type authority =
    | A_server of server option
    | A_reg_name of string

let p_port_ = Cf_clex.create ((!* !^ch_is_digit_) $> int_of_string)

let p_server_ =
    let p_userinfo_at_ =
        p_userinfo_ >>= fun ui ->
        p_at_ >>= fun _ ->
        Cf_llscan.ret ui
    in
    let p_userinfo_opt_ = ?/ p_userinfo_at_ in
    let p_host_ = Cf_llscan.alt [
        (p_ipv4_addr_ >>= fun addr -> Cf_llscan.ret (H_ip4_addr addr));
        (p_hostname_ >>= fun name -> Cf_llscan.ret (H_hostname name));
    ] in
    let p_port_opt_ = ?/ (p_colon_ >>= fun _ -> p_port_) in
    ?/ begin
        p_userinfo_opt_ >>= fun user ->
        p_host_ >>= fun host ->
        p_port_opt_ >>= fun port ->
        Cf_llscan.ret {
            srv_user = user;
            srv_host = host;
            srv_port = port;
        }
    end

let p_reg_name_ =
    Cf_clex.create begin
        !+(x_unreserved_ $| x_escaped_ $| !^ch_is_reserved_in_userinfo_) $>
        unescape
    end

let p_authority_ = Cf_llscan.alt [
    (p_server_ >>= fun srv -> Cf_llscan.ret (A_server srv));
    (p_reg_name_ >>= fun rn -> Cf_llscan.ret (A_reg_name rn));
]

let p_pchar_star_ = Cf_clex.create (!* x_pchar_ $> unescape)

let p_param_ = p_semicolon_ >>= fun _ -> p_pchar_star_

type segment = {
    seg_name: string;
    seg_params: string list;
}

let p_segment_ =
    p_pchar_star_ >>= fun name ->
    ?*p_param_ >>= fun params ->
    Cf_llscan.ret { seg_name = name; seg_params = params }

let p_path_segments_ =
    let p_list_ = p_slash_ >>= fun _ -> p_segment_ in
    p_segment_ >>= fun hd ->
    ?*p_list_ >>= fun tl ->
    Cf_llscan.ret (hd, tl)

let p_abs_path_ = p_slash_ >>= fun _ -> p_path_segments_ 

let p_rel_segment_no_semi_ = Cf_clex.create begin
    let reserved = !^ch_is_reserved_in_rel_segment_no_semi_ in
    !+ (x_unreserved_ $| x_escaped_ $| reserved) $> unescape;
end

let p_rel_segment_nonempty_ =
    p_rel_segment_no_semi_ >>= fun name ->
    ?*p_param_ >>= fun params ->
    Cf_llscan.ret { seg_name = name; seg_params = params }

let p_rel_segment_empty_with_params_ =
    ?+p_param_ >>= fun (param_hd, param_tl) ->
    Cf_llscan.ret { seg_name = ""; seg_params = param_hd :: param_tl }

let p_rel_segment_ = Cf_llscan.alt [
    p_rel_segment_nonempty_;
    p_rel_segment_empty_with_params_;
]

let p_rel_path_ =
    p_rel_segment_ >>= fun rseg ->
    ?/ p_abs_path_ >>= fun absopt ->
    Cf_llscan.ret begin
        match rseg, absopt with
        | { seg_name = ""; seg_params = [] }, Some (hd, tl) -> hd :: tl
        | hd, None -> hd :: []
        | hd, Some (tl1, tlx) -> hd :: tl1 :: tlx
    end

type net_path = {
    net_authority: authority;
    net_path: segment list;
}

let p_net_path_ =
    p_slashslash_ >>= fun _ ->
    p_authority_ >>= fun a ->
    ?/ p_abs_path_ >>= fun p_opt ->
    let p = match p_opt with None -> [] | Some (hd, tl) -> hd :: tl in
    Cf_llscan.ret { net_authority = a; net_path = p }

type net = [ `Net of net_path ]
type abs = [ `Abs of segment * segment list ]
type rel = [ `Rel of segment list ]

type path = [ net | abs | rel ]

let p_query_ = ?/ (?.'?' >>= fun _ -> p_uric_string_)

let p_fragment_ = ?/ begin
    ?.'#' >>= fun _ ->
    p_uric_string_ >>= fun frag ->
    Cf_llscan.ret (unescape frag)
end

type abs_special_hier = {
    abs_hier_path: [ net | abs ];
    abs_hier_query: string option;
}

type abs_special =
    | S_hier of abs_special_hier
    | S_opaque of string

type absolute = {
    abs_scheme: string;
    abs_special: abs_special;
}

let p_hier_part_ =
    let p_path_ = Cf_llscan.alt [
        (p_net_path_ >>= fun p -> Cf_llscan.ret (`Net p));
        (p_abs_path_ >>= fun p -> Cf_llscan.ret (`Abs p));
    ] in
    p_path_ >>= fun path ->
    p_query_ >>= fun query ->
    Cf_llscan.ret { abs_hier_path = path; abs_hier_query = query }

let p_absolute_uri_ =
    let p_abs_special_ = Cf_llscan.alt [
        (p_hier_part_ >>= fun x -> Cf_llscan.ret (S_hier x));
        (p_opaque_part_ >>= fun x -> Cf_llscan.ret (S_opaque x));
    ] in
    p_scheme_ >>= fun scheme ->
    p_colon_ >>= fun _ ->
    p_abs_special_ >>= fun special ->
    Cf_llscan.ret { abs_scheme = scheme; abs_special = special }

type relative = {
    rel_path: [ net | abs | rel ];
    rel_query: string option;
}

let empty_segment_ = { seg_params = []; seg_name = "" }

let p_relative_uri_ =
    let p_path_ = Cf_llscan.alt [
        (p_net_path_ >>= fun x -> Cf_llscan.ret (`Net x));
        (p_abs_path_ >>= fun x -> Cf_llscan.ret (`Abs x));
        (p_rel_path_ >>= fun x -> Cf_llscan.ret (`Rel x));
    ] in
    ?/ p_path_ >>= fun path ->
    p_query_ >>= fun query ->
    let path =
        match path, query with
        | None, Some _ -> `Rel (empty_segment_ :: [])
        | None, None -> `Rel []
        | Some path, _ -> path
    in
    Cf_llscan.ret { rel_path = path; rel_query = query }

type t =
    | A of absolute
    | R of relative

exception Rel_undefined

let normalize_segment_revlist_ =
    let dotdot_ = ".." in
    let rec push_loop acc = function
        | { seg_params = []; seg_name = "." } :: tl ->
            push_loop acc tl
        | { seg_params = []; seg_name = ".." } :: (seg :: tl' as tl) ->
            if seg.seg_params <> [] || seg.seg_name <> dotdot_ then
                push_loop acc tl'
            else
                push_loop (succ acc) tl
        | x ->
            acc, x
    in
    let rec pop_loop acc = function
        | _ :: x when acc > 0 -> pop_loop (pred acc) x
        | x when acc = 0 -> x
        | _ -> raise Rel_undefined
    in
    let rec loop result = function
        | [] -> result
        | x ->
            let n, x = push_loop 0 x in
            match pop_loop n x with
            | [] -> result
            | hd :: tl ->
                loop (hd :: result) tl
    in
    fun x ->
        List.rev (loop [] x)

let refer_relative_to_absolute_path_ base rel =
    let base =
        match base with
        | [] -> []
        | _ :: [] -> base
        | _ :: _ ->
            match List.rev base with
            | [] -> assert (not true); []
            | _ :: x -> x
    in
    let rel =
        match rel with
        | { seg_name = "."; seg_params = [] } :: [] ->
            empty_segment_ :: []
        | { seg_name = ".."; seg_params = [] } as dotdot :: [] ->
            dotdot :: empty_segment_ :: []
        | _ ->
            rel
    in
    let revpath = List.rev_append rel base in
    let revpath = normalize_segment_revlist_ revpath in
    match List.rev revpath with
    | [] -> empty_segment_, []
    | { seg_name = ".." } :: _ -> raise Rel_undefined
    | hd :: tl -> hd, tl

let refer_to_base_abs_path_ ~base:(`Abs abs) ~rel =
    match (rel.rel_path :> path) with
    | `Net net -> `Net net
    | `Abs abs -> `Abs abs
    | `Rel rel ->
        let abs_hd, abs_tl = abs in
        `Abs (refer_relative_to_absolute_path_ (abs_hd :: abs_tl) rel)

let refer_to_base_net_path_ ~base:(`Net net) ~rel =
    match (rel.rel_path :> path) with
    | `Net net -> `Net net
    | `Abs (hd, tl) -> `Net { net with net_path = hd :: tl }
    | `Rel rel ->
        let path_hd, path_tl =
            refer_relative_to_absolute_path_ net.net_path rel
        in
        `Net { net with net_path = path_hd :: path_tl }

let refer_to_base ~base ~rel =
    match base.abs_special with
    | S_opaque _ ->
        invalid_arg "Cf_uri.refer_to_base: base URI is opaque."
    | S_hier abs_hier ->
        let path =
            match abs_hier.abs_hier_path with
            | `Net _ as base -> refer_to_base_net_path_ ~base ~rel
            | `Abs _ as base -> refer_to_base_abs_path_ ~base ~rel
        in
        let hier = { abs_hier_path = path; abs_hier_query = rel.rel_query } in
        { base with abs_special = S_hier hier }

let p_uri_ = Cf_llscan.alt [
    (p_absolute_uri_ >>= fun x -> Cf_llscan.ret (A x));
    (p_relative_uri_ >>= fun x -> Cf_llscan.ret (R x));
]

let message_to_uri =
    let p =
        p_uri_ >>= fun x ->
        Cf_llscan.fin >>= fun _ ->
        Cf_llscan.ret x
    in
    fun m ->
        match p (Cf_message.to_seq m) with
        | None -> invalid_arg "Cf_uri.message_to_uri: syntax error"
        | Some (uri, _) -> uri

let message_to_absolute_uri ~base message =
    match message_to_uri message with
    | R rel -> refer_to_base ~base ~rel
    | A abs -> abs

type reference = {
    ref_uri: t;
    ref_fragment: string option;
}

let p_uri_reference_ =
    p_uri_ >>= fun uri ->
    p_fragment_ >>= fun frag ->
    Cf_llscan.ret { ref_uri = uri; ref_fragment = frag }

let message_to_uri_reference =
    let p =
        p_uri_reference_ >>= fun x ->
        Cf_llscan.fin >>= fun _ ->
        Cf_llscan.ret x
    in
    fun m ->
        match p (Cf_message.to_seq m) with
        | None -> invalid_arg "Cf_uri.message_to_uri_reference: syntax error"
        | Some (uriref, _) -> uriref

let message_to_absolute_uri_reference ~base message =
    let uriref = message_to_uri_reference message in
    match uriref.ref_uri with
    | A _ ->
        uriref
    | R rel->
        let uri =
            match rel.rel_path with
            | `Rel [] when rel.rel_query = None -> base
            | _ -> refer_to_base ~base ~rel
        in
        { uriref with ref_uri = A uri }

let emit_host pp = function
    | H_hostname name -> Format.pp_print_string pp (String.lowercase name)
    | H_ip4_addr addr -> Format.pp_print_string pp (Nx_ip4_addr.ntop addr)

let emit_server =
    let emit_user pp = function
        | None -> ()
        | Some s ->
            Format.pp_print_string pp s;
            Format.pp_print_char pp '@'
    and emit_port pp = function
        | None -> ()
        | Some n ->
            Format.pp_print_int pp n;
            Format.pp_print_char pp ':'
    in
    fun pp srv ->
        emit_user pp srv.srv_user;
        emit_host pp srv.srv_host;
        emit_port pp srv.srv_port

let emit_segment_0_ ~allow =
    let esc_ = escape ~allow in
    let rec loop pp = function
        | [] -> ()
        | hd :: tl ->
            Format.pp_print_char pp ';';
            Format.pp_print_string pp (esc_ hd);
            loop pp tl
    in
    fun pp seg ->
        Format.pp_print_string pp (esc_ seg.seg_name);
        loop pp seg.seg_params    

let emit_segment_ =
    emit_segment_0_ ~allow:ch_is_reserved_in_pchar_

let emit_rel_segment_ =
    emit_segment_0_ ~allow:ch_is_reserved_in_rel_segment_no_semi_

let rec emit_segment_list_ pp = function
    | [] -> ()
    | hd :: tl ->
        Format.pp_print_char pp '/';
        emit_segment_ pp hd;
        emit_segment_list_ pp tl

let emit_authority =
    let esc_ name = escape ~allow:ch_is_reserved_in_userinfo_ name in
    fun pp auth ->
        match auth with
        | A_server None -> ()
        | A_server (Some srv) -> emit_server pp srv
        | A_reg_name name -> Format.pp_print_string pp (esc_ name)

let emit_net_path_ pp net =
    emit_authority pp net.net_authority;
    emit_segment_list_ pp net.net_path

let emit_path pp = function
    | `Net net ->
        Format.pp_print_char pp '/';
        Format.pp_print_char pp '/';
        emit_net_path_ pp net
    | `Abs (hd, tl) ->
        emit_segment_list_  pp (hd :: tl)
    | `Rel x ->
        match x with
        | [] -> ()
        | hd :: tl ->
            emit_rel_segment_ pp hd;
            emit_segment_list_ pp tl

let emit_abs_special_hier_ =
    fun pp abs_hier ->
        emit_path pp abs_hier.abs_hier_path;
        match abs_hier.abs_hier_query with
        | None -> ()
        | Some query ->
            Format.pp_print_char pp '?';
            Format.pp_print_string pp query

let emit_abs_special =
    let slash_ = "%2f" in
    let esc_ s = escape ~allow:ch_is_reserved_ s in
    fun pp abs ->
        match abs with
        | S_hier abs_hier ->
            emit_abs_special_hier_ pp abs_hier
        | S_opaque opaque ->
            let len = String.length opaque in
            if len > 0 then
                if (String.unsafe_get opaque 0) = '/' then begin
                    Format.pp_print_string pp slash_;
                    if len > 1 then
                        let opaque = String.sub opaque 1 (pred len) in
                        Format.pp_print_string pp opaque
                end
                else
                    Format.pp_print_string pp (esc_ opaque)

let emit_absolute_ pp abs =
    Format.pp_print_string pp abs.abs_scheme;
    Format.pp_print_char pp ':';
    emit_abs_special pp abs.abs_special

let emit_relative_ pp rel =
    emit_path pp rel.rel_path;
    match rel.rel_query with
    | None -> ()
    | Some query ->
        Format.pp_print_char pp '?';
        Format.pp_print_string pp query

let emit_uri pp = function
    | A abs -> emit_absolute_ pp abs
    | R rel -> emit_relative_ pp rel

let emit_uri_reference =
    let esc_ fragment = escape ~allow:ch_is_reserved_ fragment in
    fun pp uriref ->
        emit_uri pp uriref.ref_uri;
        match uriref.ref_fragment with
        | None -> ()
        | Some fragment ->
            Format.pp_print_char pp '#';
            Format.pp_print_string pp (esc_ fragment)

let message_of_uri uri =
    let b = Buffer.create 80 in
    let pp = Format.formatter_of_buffer b in
    emit_uri pp uri;
    Format.pp_print_flush pp ();
    let s = Buffer.contents b in
    Cf_message.create s

let message_of_uri_reference uriref =
    let b = Buffer.create 80 in
    let pp = Format.formatter_of_buffer b in
    emit_uri_reference pp uriref;
    Format.pp_print_flush pp ();
    let s = Buffer.contents b in
    Cf_message.create s

(*--- $File$ ---*)