/pliant/protocol/http/cache.pli
1	module "/pliant/language/unsafe.pli"
2	module "/pliant/language/context.pli"
3	module "/pliant/admin/file.pli"
4	module "/pliant/graphic/image/prototype.pli"
5	module "/pliant/graphic/filter/io.pli"
6	module "/pliant/protocol/http/server.pli"
7	module "/pliant/language/data/id.pli"
8	module "/pliant/util/crypto/random.pli"
9	module "/pliant/util/encoding/base64.pli"
10	module "/pliant/language/data/cache.pli"
11	module "/pliant/language/compiler/type/inherit.pli"
12
13	module "/pliant/language/stream.pli"
14
15	constant force_to_disk true
16
17
18	gvar Sem disk_sem
19	gvar Int disk_current_count := 0
20	gvar Int disk_assigned_count := 1024
21	gvar Intn disk_current_size := 0
22	gvar Intn disk_assigned_size := 64*2^20
23
24	function disk_setup count size
25	arg Int count ; arg Intn size
26	disk_sem request
27	disk_assigned_count := count
28	disk_assigned_size := size
29	disk_sem release
30
31	function disk_shrink
32	disk_sem request
33	var CBool overflow := disk_current_count>disk_assigned_count or disk_current_size>disk_assigned_size
34	disk_sem release
35	if overflow
36	cache_shrink 0 cache_class_costy # FIXME: not very smart
37
38	export disk_setup
39
40
41	type ImageCache
42	inherit CachePrototype
43	field Link:ImagePrototype image ; field Str format options
44	field Str file ; field CBool temp
45	field Sem sem
46
47	CachePrototype maybe ImageCache
48
49	method ca drop
50	arg_rw ImageCache ca
51	if ca:temp
52	var Intn fsize := (file_query ca:file standard) size
53	file_delete ca:file
54	disk_sem request ; disk_current_count -= 1 ; disk_current_size -= fsize ; disk_sem release
55
56	if force_to_disk
57
58	type ImageForceToDisk
59	inherit CachePrototype
60	field Str id
61
62	CachePrototype maybe ImageForceToDisk
63
64	method f drop
65	arg_rw ImageForceToDisk f
66	var Link:ImageCache ca
67	if (cache_search "/pliant/image/"+f:id ((addressof Link:ImageCache ca) map Link:CachePrototype))
68	ca:sem request
69	if (exists ca:image)
70	disk_shrink
71	ca file := file_temporary ; ca temp := true
72	ca:image save ca:file "filter [dq]."+ca:format+"[dq] "+ca:options
73	var Intn fsize := (file_query ca:file standard) size
74	disk_sem request ; disk_current_count += 1 ; disk_current_size += fsize ; disk_sem release
75	ca image :> null map ImagePrototype
76	ca:sem release
77
78
79	function image_cache_record image id0 format options -> url
80	oarg_rw ImagePrototype image ; arg Str id0 format options url
81	var Str id := id0
82	if id=""
83	id := generate_id+"_"+(replace (base64_alt_encode random_string:16) "." "")
84	var Link:ImageCache ca
85	if (cache_open "/pliant/image/"+id ImageCache ((addressof Link:ImageCache ca) map Link:CachePrototype))
86	ca format := format ; ca options := options
87	var CBool lazy := not (options option "no_lazy")
88	if lazy
89	ca image :> image
90	if force_to_disk
91	var Link:ImageForceToDisk f
92	if (cache_open "/pliant/image2/"+id ImageForceToDisk ((addressof Link:ImageForceToDisk f) map Link:CachePrototype))
93	f id := id
94	cache_setup ((addressof Link:ImageForceToDisk f) map Link:CachePrototype) cache_class_cheap
95	cache_ready ((addressof Link:ImageForceToDisk f) map Link:CachePrototype)
96	else
97	disk_shrink
98	ca file := file_temporary ; ca temp := true
99	image save ca:file "filter [dq]."+format+"[dq] "+options
100	var Intn fsize := (file_query ca:file standard) size
101	disk_sem request ; disk_current_count += 1 ; disk_current_size += fsize ; disk_sem release
102	cache_ready ((addressof Link:ImageCache ca) map Link:CachePrototype)
103	url := "/common/"+string:pliant_release_number+"/image/"+id+"."+format
104
105	function image_cache_record file id0 format options -> url
106	arg Str file id0 format options url
107	var Str id := id0
108	if id=""
109	id := generate_id+"_"+(replace (base64_alt_encode random_string:16) "." "")
110	var Link:ImageCache ca
111	if (cache_open "/pliant/image/"+id ImageCache ((addressof Link:ImageCache ca) map Link:CachePrototype))
112	ca format := format ; ca options := options
113	ca file := file ; ca temp := false
114	cache_ready ((addressof Link:ImageCache ca) map Link:CachePrototype)
115	url := "/common/"+string:pliant_release_number+"/image/"+id+"."+format
116
117
118	method page image_cache_send id -> status
119	arg_rw HtmlPage page ; arg Str id ; arg ExtendedStatus status
120	var Pointer:HttpRequest request :> page http_request
121	var Link:ImageCache ca
122	if (cache_search "/pliant/image/"+id ((addressof Link:ImageCache ca) map Link:CachePrototype))
123	ca:sem rd_request
124	if (exists ca:image)
125	page reset_http_answer
126	request send_header "mime [dq]image/"+ca:format+"[dq] static"
127	status := ca:image save request:answer_stream "filter [dq]."+ca:format+"[dq] "+ca:options
128	request send_footer
129	else
130	page reset_http_answer
131	status := request send_static_file ca:file "mime [dq]image/"+ca:format+"[dq] "+ca:options
132	ca:sem rd_release
133	else
134	status := failure "no such image in the cache" # DO NOT CHANGE
135
136	export image_cache_record '. image_cache_send'
137
138