1(* Msp.sml -- prelude for ML Server Pages 2 sestoft@dina.kvl.dk 2000-11-06 version 0.8 3 *) 4 5(* Efficiently concatenable word sequences *) 6 7datatype wseq = 8 Empty (* The empty sequence *) 9 | Nl (* Newline *) 10 | $ of string (* A string *) 11 | $$ of string list (* A sequence of strings *) 12 | && of wseq * wseq; (* Concatenation of sequences *) 13 14infix && 15 16fun prmap f [] = Empty 17 | prmap f (x1::xr) = 18 let fun loop y1 [] = f y1 19 | loop y1 (y2::yr) = f y1 && loop y2 yr 20 in loop x1 xr end 21 22fun prsep sep f [] = Empty 23 | prsep sep f (x1::xr) = 24 let fun loop y1 [] = f y1 25 | loop y1 (y2::yr) = f y1 && sep && loop y2 yr 26 in loop x1 xr end 27 28fun flatten Empty acc = acc 29 | flatten Nl acc = "\n" :: acc 30 | flatten ($ s) acc = s :: acc 31 | flatten ($$ ss) acc = List.@(ss, acc) 32 | flatten (s1 && s2) acc = flatten s1 (flatten s2 acc) 33val flatten = fn seq => String.concat(flatten seq []); 34 35fun printseq Empty = () 36 | printseq Nl = TextIO.print "\n" 37 | printseq ($ s) = TextIO.print s 38 | printseq ($$ ss) = List.app TextIO.print ss 39 | printseq (s1 && s2) = (printseq s1; printseq s2); 40 41fun vec2list vec = Vector.foldr op:: [] vec 42 43(* CGI parameter access shorthands *) 44 45exception ParamMissing of string 46exception NotInt of string * string 47 48fun % fnm = 49 case Mosmlcgi.cgi_field_string fnm of 50 NONE => raise ParamMissing "fnm" 51 | SOME v => v 52 53fun %? fnm = Option.isSome(Mosmlcgi.cgi_field_string fnm) 54 55fun %# fnm = 56 case Mosmlcgi.cgi_field_string fnm of 57 NONE => raise ParamMissing fnm 58 | SOME v => (case Int.fromString v of 59 NONE => raise NotInt(fnm, v) 60 | SOME i => i) 61 62fun %%(fnm, dflt) = Option.getOpt(Mosmlcgi.cgi_field_string fnm, dflt) 63 64fun %%#(fnm, dflt) = 65 Option.getOpt(Option.mapPartial Int.fromString 66 (Mosmlcgi.cgi_field_string fnm), dflt) 67 68(* HTML generic marks *) 69 70fun mark0 tag = $$["<", tag, ">"] 71fun mark0a attr tag = $$["<", tag, " ", attr, ">"] 72fun mark1 tag seq = $$["<", tag, ">"] && seq && $$["</", tag, ">"] 73fun mark1a tag attr seq = 74 $$["<", tag, " ", attr, ">"] && seq && $$["</", tag, ">"] 75fun comment seq = $"<!--" && seq && $"-->" 76 77(* HTML documents and headers *) 78 79fun html seq = $"<HTML>" && seq && $"</HTML>" 80fun head seq = $"<HEAD>" && seq && $"</HEAD>" 81fun title seq = $"<TITLE>" && seq && $"</TITLE>" 82fun body seq = $"<BODY>" && seq && $"</BODY>" 83fun bodya attr seq = $$["<BODY ", attr, ">"] && seq && $"</BODY>" 84fun htmldoc tit bod = html (head (title tit) && body bod) 85 86(* HTML headings and vertical format *) 87 88fun h1 seq = $"<H1>" && seq && $"</H1>" 89fun h2 seq = $"<H2>" && seq && $"</H2>" 90fun h3 seq = $"<H3>" && seq && $"</H3>" 91fun h4 seq = $"<H4>" && seq && $"</H4>" 92fun h5 seq = $"<H5>" && seq && $"</H5>" 93fun h6 seq = $"<H6>" && seq && $"</H6>" 94 95fun p seq = $"<P>" && seq && $"</P>" 96fun pa attr seq = $$["<P ", attr, ">"] && seq && $"</P>" 97fun divi seq = $"<DIV>" && seq && $"</DIV>" 98fun divia attr seq = $$["<DIV ", attr, ">"] && seq && $"</DIV>" 99fun blockquote seq = $"<BLOCKQUOTE>" && seq && $"</BLOCKQUOTE>" 100fun blockquotea attr seq = 101 $$["<BLOCKQUOTE ", attr, ">"] && seq && $"</BLOCKQUOTE>" 102fun center seq = $"<CENTER>" && seq && $"</CENTER>" 103fun address seq = $"<ADDRESS>" && seq && $"</ADDRESS>" 104fun pre seq = $"<PRE>" && seq && $"</PRE>" 105 106val br = $"<BR>" 107fun bra attr = $$["<BR ", attr, ">"] 108val hr = $"<HR>" 109fun hra attr = $$["<HR ", attr, ">"] 110 111(* HTML anchors and hyperlinks *) 112 113fun ahref link seq = $$["<A HREF=\"", link, "\">"] && seq && $"</A>" 114fun ahrefa link attr seq = 115 $$["<A HREF=\"", link, "\" ", attr, ">"] && seq && $"</A>" 116fun aname name seq = $$["<A NAME=\"", name, "\">"] && seq && $"</A>" 117 118(* HTML text formats and style *) 119 120fun em seq = $"<EM>" && seq && $"</EM>" 121fun strong seq = $"<STRONG>" && seq && $"</STRONG>" 122fun tt seq = $"<TT>" && seq && $"</TT>" 123fun sub seq = $"<SUB>" && seq && $"</SUB>" 124fun sup seq = $"<SUP>" && seq && $"</SUP>" 125fun fonta attr seq = $$["<FONT ", attr, ">"] && seq && $"</FONT>" 126 127(* HTML lists *) 128 129fun ul seq = $"<UL>" && seq && $"</UL>" 130fun ula attr seq = $$["<UL ", attr, ">"] && seq && $"</UL>" 131fun ol seq = $"<OL>" && seq && $"</OL>" 132fun ola attr seq = $$["<OL ", attr, ">"] && seq && $"</OL>" 133fun li seq = $"<LI>" && seq && $"</LI>" 134 135fun dl seq = $"<DL>" && seq && $"</DL>" 136fun dla attr seq = $$["<DL ", attr, ">"] && seq && $"</DL>" 137fun dt seq = $"<DT>" && seq && $"</DT>" 138fun dd seq = $"<DD>" && seq && $"</DD>" 139 140(* HTML tables *) 141 142fun tr seq = $"<TR>" && seq && $"</TR>" 143fun tra attr seq = $$["<TR ", attr, ">"] && seq && $"</TR>" 144fun td seq = $"<TD>" && seq && $"</TD>" 145fun tda attr seq = $$["<TD ", attr, ">"] && seq && $"</TD>" 146fun th seq = $"<TH>" && seq && $"</TH>" 147fun tha attr seq = $$["<TH ", attr, ">"] && seq && $"</TH>" 148fun table seq = $"<TABLE>" && seq && $"</TABLE>" 149fun tablea attr seq = $$["<TABLE ", attr, ">"] && seq && $"</TABLE>" 150fun caption seq = $"<CAPTION>" && seq && $"</CAPTION>" 151fun captiona attr seq = $$["<CAPTION ", attr, ">"] && seq && $"</CAPTION>" 152 153(* HTML images and image maps *) 154 155fun img src = $$["<IMG SRC=\"", src, "\">"] 156fun imga src attr = $$["<IMG SRC=\"", src, "\" ", attr, ">"] 157fun map nam seq = $$["<MAP NAME=\"", nam, "\">"] && seq && $"</MAP>" 158fun mapa nam attr seq = 159 $$["<MAP NAME=\"", nam, "\" ", attr, ">"] && seq && $"</MAP>" 160fun area { shape, href, coords, alt } = 161 $$["<AREA SHAPE=\"", shape, "\" COORDS=\"", coords, "\" "] 162 && (case href of NONE => $"NOHREF" | SOME r => $$["HREF=\"", r, "\" "]) 163 && (case alt of NONE => Empty | SOME a => $$["ALT=\"", a, "\""]) 164 165(* HTML forms etc *) 166 167fun form action seq = $$["<FORM ACTION=\"", action, "\">"] && seq && $"</FORM>" 168fun forma action attr seq = 169 $$["<FORM ACTION=\"", action, "\" ", attr, ">"] && seq && $"</FORM>" 170fun input typ = $$["<INPUT TYPE=", typ, ">"] 171fun inputa typ attr = $$["<INPUT TYPE=", typ, " ", attr, ">"] 172fun intext name attr = $$["<INPUT TYPE=TEXT NAME=\"", name, "\" ", attr, ">"] 173fun inpassword name attr = 174 $$["<INPUT TYPE=PASSWORD NAME=\"", name, "\" ", attr, ">"] 175fun incheckbox {name, value} attr = 176 $$["<INPUT TYPE=CHECKBOX VALUE=\"", value, "\" NAME=\"", name, 177 "\" ", attr, ">"] 178fun inradio {name, value} attr = 179 $$["<INPUT TYPE=RADIO VALUE=\"", value, "\" NAME=\"", name, 180 "\" ", attr, ">"] 181fun inreset value attr = 182 $$["<INPUT TYPE=RESET VALUE=\"", value, "\" ", attr, ">"] 183fun insubmit value attr = 184 $$["<INPUT TYPE=SUBMIT VALUE=\"", value, "\" ", attr, ">"] 185fun inhidden {name, value} = 186 $$["<INPUT TYPE=HIDDEN NAME=\"", name, "\" VALUE=\"", value, "\">"] 187fun textarea name seq = 188 $$["<TEXTAREA NAME=\"", name, "\">"] && seq && $"</TEXTAREA>" 189fun textareaa name attr seq = 190 $$["<TEXTAREA NAME=\"", name, "\" ", attr, ">"] 191 && seq && $"</TEXTAREA>" 192fun select name attr seq = 193 $$["<SELECT NAME=\"", name, "\" ", attr, ">"] && seq && $"</SELECT>" 194fun option value = $$["<OPTION VALUE=\"", value, "\">"] 195 196(* HTML frames and framesets *) 197 198fun frameset attr seq = $$["<FRAMESET ", attr, ">"] && seq && $"</FRAMESET>" 199fun frame { src, name } = $$["<FRAME SRC=\"", src, "\" NAME=\"", name, "\">"] 200fun framea { src, name } attr = 201 $$["<FRAME SRC=\"", src, "\" NAME=\"", name, "\" ", attr, ">"] 202 203(* HTML encoding *) 204 205fun urlencode s : string = 206 let fun encode #" " = "+" 207 | encode #"-" = "-" 208 | encode #"_" = "_" 209 | encode #"." = "." 210 | encode c = 211 if Char.isAlphaNum c then String.str c 212 else "%" ^ StringCvt.padLeft #"0" 2 213 (Int.fmt StringCvt.HEX (Char.ord c)) 214 in String.translate encode s end 215 216(* Maybe this should create a wseq instead, to avoid creating a long 217 string by concatenation *) 218 219fun htmlencode s : string = 220 let fun encode #"<" = "<" 221 | encode #">" = ">" 222 | encode #"&" = "&" 223 | encode c = String.str c 224 in String.translate encode s end 225