EncodeDecode.icl 15.3 KB
Newer Older
1
implementation module EncodeDecode
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
2
3
4
5

// encoding and decoding of information
// (c) 2005 MJP

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
6
import StdArray, StdBool, StdInt, StdList, StdOrdList, StdString, StdTuple, ArgEnv, StdMaybe, Directory
7
import htmlTrivial, htmlFormData
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
8
9
import GenPrint, GenParse
import dynamic_string
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
10
import EstherBackend
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
11

12
derive gParse UpdValue, (,,), (,)
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
derive gPrint UpdValue, (,,), (,)


// form submission department....

// script for transmitting name and value of changed input 

callClean :: !(Script -> ElementEvents) !Mode !String -> [ElementEvents]
callClean  onSomething Edit		_    =  [onSomething (SScript "toclean(this)")]
callClean  onSomething Submit 	myid =  [onSomething (SScript ("toclean2(" <+++ myid <+++ ")"))]
callClean  onSomething _ 		_	 =  []

submitscript :: BodyTag
submitscript 
=	BodyTag 
    [ Script [] (SScript
		(	" function toclean(inp)" +++
			" { document." +++ globalFormName +++ "." +++	updateInpName +++ ".value=inp.name+\"=\"+inp.value;" +++
			   "document." +++ globalFormName +++ ".submit(); }"
		))
	,	Script [] (SScript
		(	" function toclean2(form)" +++
			" { "  +++
				"form.hidden.value=" +++ "document." +++ globalFormName +++ "." +++ globalInpName +++ ".value;" +++
				"form.submit();" +++
			"}" 
		))

	]

// form that contains global state and empty input form for storing updated input
	
globalstateform :: !Value -> BodyTag
globalstateform  globalstate
=	Form 	[ Frm_Name globalFormName 
//			, Frm_Action (MyPhP server)
			, Frm_Method Post
			, Frm_Enctype "multipart/form-data"			// what to do to enable large data ??
			]
			[ Input [ Inp_Name updateInpName
					, Inp_Type Inp_Hidden
					] ""
			, Input [ Inp_Name globalInpName
					, Inp_Type Inp_Hidden
					, Inp_Value globalstate
					] ""
			]		 

globalFormName :: String
globalFormName	=: "CleanForm"

updateInpName :: String
updateInpName	=: "UD"

globalInpName :: String
globalInpName	=: "GS"

selectorInpName :: String
selectorInpName	=: "CS"
	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
73
74
75
76
77
78
// Serializing Html states...

EncodeHtmlStates :: ![HtmlState] -> String
EncodeHtmlStates [] = "$"
EncodeHtmlStates [(id,lifespan,storageformat,state):xsys] 
	= encodeString
79
80
81
82
83
	  (	"(\"" +++ 										// begin mark
		fromLivetime lifespan storageformat +++ 		// character encodes lifetime and kind of encoding
		id +++ 											// id of state 
	  	"\"," +++ 										// delimiter
	  	 state +++ 										// encoded state 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
84
85
	  	")" 
	  )	+++
86
	  "$" +++ 											// end mark
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
87
88
	  EncodeHtmlStates xsys
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
89
90
91
92
	fromLivetime Page 			PlainString		= "N"	// encode Lifespan & StorageFormat in first character
	fromLivetime Session 		PlainString		= "S"
	fromLivetime Persistent 	PlainString		= "P"
	fromLivetime PersistentRO 	PlainString		= "R"
93
	fromLivetime Database	 	PlainString		= "D"
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
94
95
96
97
	fromLivetime Page 			StaticDynamic	= "n"
	fromLivetime Session 		StaticDynamic	= "s"
	fromLivetime Persistent 	StaticDynamic	= "p"
	fromLivetime PersistentRO 	StaticDynamic	= "r"
98
	fromLivetime Database	 	StaticDynamic	= "d"
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
99
100
101

// de-serialize Html State

102
103
DecodeHtmlStates :: !String -> [HtmlState]
DecodeHtmlStates state					= toHtmlState` (mkList state)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
104
where
105
106
107
	toHtmlState` :: ![Char] -> [HtmlState]
	toHtmlState` [] 					= []
	toHtmlState` listofchar				= [mkHtmlState (mkList (decodeChars first)) : toHtmlState` second]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
108
	where
109
110
111
112
113
114
115
116
		(first,second)					= mscan '$' listofchar									// search for end mark

		mkHtmlState :: ![Char] -> HtmlState
		mkHtmlState	elem				= ( mkString (stl fid)									// decode unique identification
										  , lifespan											// decode livetime from character
										  , format												// decode storage format from character
										  , mkString (stl (reverse (stl (reverse formvalue)))) 	// decode state
										  )
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
117
		where
118
119
120
121
122
123
124
125
126
127
128
129
130
			(fid,formvalue)				= mscan '"' (stl (stl elem)) 							// skip '("'
			(lifespan,format)			= case fid of
											['N':_]		= (Page,        PlainString  )
											['n':_]		= (Page,        StaticDynamic)
											['S':_]		= (Session,     PlainString  )
											['s':_] 	= (Session,     StaticDynamic)
											['P':_] 	= (Persistent,  PlainString  )
											['p':_]		= (Persistent,  StaticDynamic)
											['R':_]		= (PersistentRO,PlainString  )
											['r':_] 	= (PersistentRO,StaticDynamic)
											['D':_] 	= (Database,    PlainString  )
											['d':_] 	= (Database,    StaticDynamic)
											_			= (Page,        PlainString  )
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
131
132
133

// reconstruct HtmlState out of the information obtained from browser

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
134
DecodeHtmlStatesAndUpdate :: !ServerKind (Maybe [(String, String)]) -> (![HtmlState],!Triplets)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
135
DecodeHtmlStatesAndUpdate serverkind args
136
137
# (_,triplets,state)				= DecodeArguments serverkind args
= ([states \\states=:(id,_,_,nstate) <- DecodeHtmlStates state | id <> "" || nstate <> ""],triplets) // to be sure that no rubbish is passed on
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
138
139
140
141

// Parse and decode low level information obtained from server 
// In case of using a php script and external server:

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
142
DecodeArguments :: !ServerKind (Maybe [(String, String)]) -> (!String,!Triplets,!String)
143
DecodeArguments External _				= DecodePhpArguments
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
144
where
145
146
147
148

// decode PHP will NOT work any more: either repair or kick it out !

//	DecodePhpArguments :: (!String,!String,!String,!String)					R		// executable, id + update , new , state
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
149
	DecodePhpArguments
150
151
152
	# input 							= [c \\ c <-: GetArgs | not (isControl c) ]	// get rid of communication noise
	# (thisexe,input) 					= mscan '#'         input					// get rid of garbage
	# input								= skipping ['#UD='] input
153
	# (triplet, input)					= mscan '='         input
154
155
156
	# (new,    input)					= mscan ';'         input
	# input								= skipping ['GS=']  input
	# (state, input)					= mscan ';'         input
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
157
	=: case toString update of
158
159
//			"CS"						= (toString thisexe, decodeChars new,    "",           toString state)
//			else						= (toString thisexe, decodeChars triplet, toString new, toString state)
160
			else						= ("clean", []/*[(fromJust (parseString (decodeChars triplet)), toString new)]*/, toString state)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
161
162
163
164
165
166

	GetArgs :: String 
	GetArgs =: foldl (+++) "" [strings \\ strings <-: getCommandLine]

// In case of using the internal server written in Clean:

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
167
168
DecodeArguments Internal (Just args)	
# nargs = length args
169
170
171
172
| nargs == 0 		= ("clean",[],"")
| nargs == 1		= DecodeCleanServerArguments (foldl (+++) "" [name +++ "=" +++ value +++ ";" \\ (name,value) <- args])
# tripargs 			= reverse args													// state hidden in last field, rest are triplets
# (state,tripargs)	= (urlDecode (snd (hd tripargs)),tl tripargs)					// decode state, get triplets highest positions first	
173
# constriplets		= filter (\(name,_) -> name == "CS") tripargs					// select constructor triplets  
174
# nconstriplets		= [(constrip,"") \\ (_,codedtrip) <- constriplets, (Just constrip) <- [parseString (decodeString (urlDecode codedtrip))]] // and decode
175
# valtriplets		= filter (\(name,_) -> name <> "CS") tripargs					// select all other triplets 
176
# nvaltriplets		= [(mytrip,new) \\ (codedtrip,new) <- valtriplets, (Just mytrip) <- [parseString (decodeString (urlDecode codedtrip))]] // and decode
177
= ("clean",reverse nconstriplets ++ nvaltriplets,state)								// order is important, first the structure than the values ...
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
178
where
179
	DecodeCleanServerArguments :: !String -> (!String,!Triplets,!String)			// executable, id + update , new , state
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
180
	DecodeCleanServerArguments args
181
182
183
	# input 							= [c \\ c <-: args | not (isControl c) ]	// get rid of communication noise
	# (thisexe,input) 					= mscan '\"'          input					// get rid of garbage
	# input								= skipping ['UD\"']   input
184
185
	# (triplet, input)					= mscan '='           input					// should give triplet
	# (new,    input)					= mscan '-'           input					// should give triplet value <<< *** Bug for negative integers??? ***
186
187
188
189
	# (_,input)							= mscan '='           input
	# input								= skipping ['\"GS\"'] input
	# (found,index) 					= FindSubstr ['---']  input
	# state								= if found (take index input) ['']
190
191
	= case toString triplet of
			""							= ("clean", [], toString state)
192
193
			"CS"						= ("clean", [(fromJust (parseString (decodeChars new)), "")], toString state)
			else						= ("clean", [(fromJust (parseString (decodeChars triplet)) , toString new)], toString state)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
194

195
// traceHtmlInput utility used to see what kind of rubbish is received from client 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
196

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
197
198
traceHtmlInput :: !ServerKind !(Maybe [(String, String)]) -> BodyTag
traceHtmlInput serverkind args=:(Just input)
199
=	BodyTag	[ Br, B [] "State values received from client when application started:", Br,
200
201
				STable [] [ [B [] "Triplets:",Br]
							, showTriplet triplets
202
						  ,[B [] "Id:", B [] "Lifespan:", B [] "Format:", B [] "Value:"]
203
204
205
206
207
						: [  [Txt id, Txt (showl life), Txt (showf storage), Txt (shows storage state)] 
						  \\ (id,life,storage,state) <- htmlState
						  ]
						]
			, Br
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
208
			, STable [] [[Txt name,Txt value] \\ (name,value) <- input]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
209
210
			]
where
211
	(htmlState,triplets)	= DecodeHtmlStatesAndUpdate serverkind args
212

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
213
	showTriplet triplets	= [STable [] [[Txt (printToString triplet)] \\ triplet <- triplets]]
214
215
216
217
	showl life				= toString life
	showf storage			= case storage of PlainString -> "String";  _ -> "S_Dynamic"
	shows PlainString s		= s
	shows StaticDynamic d	= toStr (string_to_dynamic` d)											// "cannot show dynamic value" 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
218
219
220
221
222
223
224
225
226
227
228
229
230
231

	toStr dyn = ShowValueDynamic dyn <+++ " :: " <+++ ShowTypeDynamic dyn

	string_to_dynamic` :: {#Char} -> Dynamic	// just to make a unique copy as requested by string_to_dynamic
	string_to_dynamic` s	= string_to_dynamic {s` \\ s` <-: s}
	
	strip s = { ns \\ ns <-: s | ns >= '\020' && ns <= '\0200'}
	
	ShowValueDynamic :: Dynamic -> String
	ShowValueDynamic d = strip (foldr (+++) "" (fst (toStringDynamic d)) +++ " ")
	
	ShowTypeDynamic :: Dynamic -> String
	ShowTypeDynamic d = strip (snd (toStringDynamic d) +++ " ")

232

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
233
234
// global names setting depending on kind of server used

235
ThisExe :: !ServerKind -> String
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
236
ThisExe External 
237
# (thisexe,_,_) = DecodeArguments External Nothing 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
238
239
240
= thisexe
ThisExe Internal 
= "clean"
241
242
ThisExe _ 
= "clean"
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
243

244
245
246
MyPhP :: !ServerKind -> String
MyPhP External							= (mkString (takeWhile ((<>) '.') (mkList (ThisExe External)))) +++ ".php"
MyPhP Internal							= "clean"
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
247

248
249
MyDir :: !ServerKind -> String
MyDir serverkind						= mkString (takeWhile ((<>) '.') (mkList (ThisExe serverkind)))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
250
251
252
253
254

// writing and reading of persistent states to a file

writeState :: !String !String !String !*NWorld -> *NWorld 
writeState directory filename serializedstate env
255
256
257
258
259
#(_,env)								= case getFileInfo mydir env of
											((DoesntExist,fileinfo),env)	= createDirectory mydir env
											(_,env)							= (NoDirError,env)
# (ok,file,env)							= fopen (directory +++ "/" +++ filename +++ ".txt") FWriteData env
| not ok	 							= env
260
# file									= fwrites serializedstate file  // DEBUG
261
# (ok,env)								= fclose file env
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
262
263
= env
where
264
265
266
267
268
269
270
271
272
273
274
275
276
	mydir								= RelativePath [PathDown directory]

readState :: !String !String !*NWorld -> (!String,!*NWorld) 
readState directory filename env
#(_,env)								= case getFileInfo mydir env of
											((DoesntExist,fileinfo),env)	= createDirectory mydir env
											(_,env)							= (NoDirError,env)
# (ok,file,env)							= fopen (directory +++ "/" +++ filename +++ ".txt") FReadData env
| not ok 								= ("",env)
# (string,file)							= freads file big
| not ok 								= ("",env)
# (ok,env)								= fclose file env
= (string,env)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
277
where
278
279
	big									= 1000000
	mydir								= RelativePath [PathDown directory]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
280
281
282
283
284
285

// serializing and de-serializing of html states


// low level url encoding decoding of Strings

286
287
encodeString :: !String -> String
encodeString s							= /* see also urlEncode */ string_to_string52 s	// using the whole alphabet 
288
//encodeString s							= urlEncode s
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
289

290
291
decodeString :: !String -> *String
decodeString s							= /* see also urlDecode */ string52_to_string s	// using the whole alphabet
292
293
294
295
296
297
298
299
300
//decodeString s							= urlDecode s

// to encode triplets in htmlpages

encodeTriplet	:: !Triplet -> String				// encoding of triplets
encodeTriplet triplet = encodeInfo triplet

decodeTriplet	:: !String -> Maybe Triplet			// decoding of triplets
decodeTriplet triplet = decodeInfo triplet
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
301
302
303

// utility functions based on low level encoding - decoding

304
305
encodeInfo :: !a -> String | gPrint{|*|} a
encodeInfo inp							= encodeString (printToString inp)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
306

307
308
decodeInfo :: !String -> Maybe a | gParse{|*|} a
decodeInfo str							= parseString (decodeString str)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
309

310
311
decodeChars :: ![Char] -> *String
decodeChars cs							= decodeString (mkString cs)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
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

// compact John van Groningen encoding-decoding to lower and uppercase alpabeth

string_to_string52 :: !String -> *String
string_to_string52 s
# n		=	size s
# n3d2	=	3*(n>>1)
| n bitand 1==0
= fill_string52 0 0 n s (createArray n3d2 '\0')
# a = fill_string52 0 0 (n-1) s (createArray (n3d2+2) '\0')
  i=toInt s.[n-1]
  i1=i/52
  r0=i-i1*52
= {a & [n3d2]=int52_to_alpha_char i1,[n3d2+1]=int52_to_alpha_char r0} 
where
	fill_string52 :: !Int !Int !Int !String !*String -> *String
	fill_string52 si ai l s a
	| si<l
	# i=toInt s.[si]<<8+toInt s.[si+1]
	  i1=i/52
	  i2=i1/52
	  r0=i-i1*52
	  r1=i1-i2*52
	  a={a & [ai]=int52_to_alpha_char i2,[ai+1]=int52_to_alpha_char r1,[ai+2]=int52_to_alpha_char r0}
	= fill_string52 (si+2) (ai+3) l s a
	= a

int52_to_alpha_char i :== toChar (i-(((i-26)>>8) bitand 6)+71)

string52_to_string :: !String -> *String
string52_to_string s
# n		=	size s
# nd3	=	n/3
# r3	=	n-nd3*3
# n2d3	=	nd3<<1
| r3==0	= fill_string 0 0 n s (createArray n2d3 '\0')
| r3==2
# a = fill_string 0 0 (n-2) s (createArray (n2d3+1) '\0')
= {a & [n2d3]=toChar (alpha_to_int52 s.[n-2]*52+alpha_to_int52 s.[n-1])}
where
	fill_string :: !Int !Int !Int !String !*String -> *String
	fill_string si ai l s a
	| si<l
	# i=(alpha_to_int52 s.[si]*52+alpha_to_int52 s.[si+1])*52+alpha_to_int52 s.[si+2]
	# a={a & [ai]=toChar (i>>8),[ai+1]=toChar i}
	= fill_string (si+3) (ai+2) l s a
	= a

alpha_to_int52 c
:== let i=toInt c in i+(((i-97)>>8) bitand 6)-71

// small parsing utility functions

365
366
367
368
mscan :: Char ![Char] -> ([Char],[Char])
mscan c list							= case span ((<>) c) list of			// scan like span but it removes character
											(x,[])	= (x,[])
											(x,y)	= (x,tl y)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
369

370
skipping :: !.[a] !u:[a] -> v:[a] | == a, [u <= v]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
371
skipping [c:cs] list=:[x:xs]
372
373
374
| c == x								= skipping cs xs
| otherwise								= list
skipping any    list					= list
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
375

376
// The following code is not used, but is included as reference code and for debugging purposes.
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
377
378
379

// encoding - decoding to hexadecimal code

380
381
urlEncode :: !String -> String
urlEncode s								= mkString (urlEncode` (mkList s))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
382
where
383
384
	urlEncode` :: ![Char] -> [Char]
	urlEncode` []						= []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
385
	urlEncode` [x:xs] 
386
387
	| isAlphanum x						= [x  : urlEncode` xs]
	| otherwise							= urlEncodeChar x ++ urlEncode` xs
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
388
389
	where
		urlEncodeChar x 
390
		# (c1,c2)						= charToHex x
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
391
392
393
		= ['%', c1 ,c2]
	
		charToHex :: !Char -> (!Char, !Char)
394
		charToHex c						= (toChar (digitToHex (i >> 4)), toChar (digitToHex (i bitand 15)))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
395
		where
396
		        i						= toInt c
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
397
398
		        digitToHex :: !Int -> Int
		        digitToHex d
399
400
		                | d <= 9		= d + toInt '0'
		                | otherwise		= d + toInt 'A' - 10
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
401

402
403
urlDecode :: !String -> *String
urlDecode s								= mkString (urlDecode` (mkList s))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
404
where
405
406
407
	urlDecode` :: ![Char] -> [Char]
	urlDecode` []						= []
	urlDecode` ['%',hex1,hex2:xs]		= [hexToChar(hex1, hex2):urlDecode` xs]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
408
409
	where
		hexToChar :: !(!Char, !Char) -> Char
410
		hexToChar (a, b)				= toChar (hexToDigit (toInt a) << 4 + hexToDigit (toInt b))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
411
412
413
		where
		        hexToDigit :: !Int -> Int
		        hexToDigit i
414
415
416
		                | i<=toInt '9'	= i - toInt '0'
		                | otherwise		= i - toInt 'A' - 10
	urlDecode` [x:xs]				 	= [x:urlDecode` xs]