Source file stog_rel_href.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
(** A plugin to change URIs in href attributes to relative ones.
By now it only rewrite URIs of a document to a block of the
same doc URI#id to #id. *)
module XR = Xtmpl.Rewrite
module Xml = Xtmpl.Xml
open Stog.Types
let rec rewrite_href url xml =
match xml with
| XR.D _ | XR.C _ | XR.PI _ -> xml
| XR.E node ->
let atts = Xml.Name_map.mapi
(fun att v ->
match att, v with
(pref,"href"), [XR.D href] ->
let href = href.Xtmpl.Types.text in
begin
let url2 =
try
let href_url = Stog.Url.of_string href in
let url2 =
Stog.Url.with_fragment
(Stog.Url.remove_query href_url)
None
in
Some (Stog.Url.to_string url2)
with
Failure _ -> None
in
match url2 with
None -> v
| Some url2 ->
if String.compare url url2 = 0 then
begin
let len = String.length url in
let len2 = String.length href in
if len2 <= len then
[XR.cdata ""]
else
[XR.cdata (String.sub href len (len2 - len)) ]
end
else
[XR.cdata href]
end
| _ -> v
)
node.XR.atts
in
XR.E { node with XR.atts ; subs = List.map (rewrite_href url) node.XR.subs }
let rewrite_doc stog doc =
let xmls =
match doc.doc_out with
None -> doc.doc_body
| Some b -> b
in
let url = Stog.Url.to_string (Stog.Engine.doc_url stog doc) in
let xmls = List.map (rewrite_href url) xmls in
{ doc with doc_out = Some xmls }
;;
let rewrite =
let f_doc doc_id stog =
let doc = Stog.Types.doc stog doc_id in
let doc = rewrite_doc stog doc in
Stog.Types.set_doc stog doc_id doc
in
let f env stog docs = Stog.Types.Doc_set.fold f_doc docs stog in
Stog.Engine.Fun_stog f
let level_funs = [ "rewrite", rewrite ]
let default_levels =
List.fold_left
(fun map (name, levels) -> Stog.Types.Str_map.add name levels map)
Stog.Types.Str_map.empty
[
"rewrite", [ 400 ] ;
]
let module_name = "rel-href";;
let make_module ?levels () =
let levels = Stog.Html.mk_levels module_name level_funs default_levels ?levels () in
let module M =
struct
type data = unit
let modul = {
Stog.Engine.mod_name = module_name ;
mod_levels = levels ;
mod_data = () ;
}
type cache_data = unit
let cache_load _stog data doc t = data
let cache_store _stog data doc = ()
end
in
(module M : Stog.Engine.Module)
;;
let f stog =
let levels =
try Some (Stog.Types.Str_map.find module_name stog.Stog.Types.stog_levels)
with Not_found -> None
in
make_module ?levels ()
;;
let () = Stog.Engine.register_module module_name f;;