module WASH.CGI.CGIInternals (module WASH.CGI.CGIInternals, getPathInfo)
where
import Prelude hiding (head,div,span)
import qualified Prelude
import qualified List
import Maybe
import Monad
import System
import IO
import WASH.Utility.Auxiliary
import qualified WASH.Utility.Base64 as Base64
import WASH.CGI.BaseCombinators
import WASH.CGI.CookieIO
import WASH.CGI.CGIMonad
import WASH.CGI.CGIOutput
import WASH.CGI.CGITypes
import WASH.CGI.EventHandlers
import WASH.CGI.Fields
import WASH.CGI.Frames
import WASH.CGI.CGIHistory
import qualified WASH.CGI.HTMLWrapper as H hiding (map)
import WASH.CGI.Images
import WASH.Utility.JavaScript
import qualified WASH.Utility.RFC2279 as RFC2279
import qualified WASH.Utility.RFC2397 as RFC2397
import WASH.CGI.RawCGIInternal hiding (CGIEnv (..), getSessionMode)
import qualified WASH.Utility.URLCoding as URLCoding
import WASH.CGI.CGIConfig
makeRef :: (CGIMonad cgi, Monad m)
=> String
-> H.WithHTML x m ()
-> cgi (H.WithHTML y m ())
makeRef fileName elems =
wrapCGI (\cgistate ->
let fileURL = url cgistate ++ '?' : fileName in
return (hlink (URL fileURL) elems, cgistate))
makePopupRef :: (CGIMonad cgi) =>
String
-> String
-> H.HTMLCons x y cgi ()
makePopupRef name fileName elems =
do baseUrl <- H.lift getUrl
let fileURL = baseUrl ++ '?' : fileName
popuplink name (URL fileURL) elems
makeA :: (CGIMonad cgi) => String -> String -> HTMLField cgi x y ()
makeA path name elems =
do url <- H.lift getUrl
let querystring = if null name then "" else '?' : name
pathstring = if null path then "" else '/' : path
fullurl = url ++ pathstring ++ querystring
hlink (URL fullurl) elems
data VALID = VALID
data INVALID = INVALID
data InputField a x =
InputField { ifName :: String
, ifToken :: CGIFieldName
, ifFty :: String
, ifString :: Maybe String
, ifValue :: Maybe a
, ifRaw :: CGIParameters
, ifBound :: Bool
}
concatFields :: (Reason c, Read c)
=> InputField c INVALID -> InputField Text INVALID
-> InputField c INVALID
concatFields ifa ifb =
concatFieldsWith g ifa [ifb]
where g sa [sb] = sa ++ sb
concatFieldsWith :: (Reason c, Read c)
=> (String -> [String] -> String)
-> InputField c INVALID
-> [InputField Text INVALID]
-> InputField c INVALID
concatFieldsWith trans ifa ifbs =
let newString = do stra <- ifString ifa
strbs <- mapM ifString ifbs
return (trans stra strbs)
newValue = do s <- newString
maybeRead s
in
InputField { ifName = ifName ifa
, ifToken = ifToken ifa
, ifFty = ifFty ifa
, ifString = newString
, ifValue = newValue
, ifRaw = ifRaw ifa
, ifBound = ifBound ifa && all ifBound ifbs
}
combineFieldsWith2 f2 if1 if2 =
InputField { ifName = ifName if1
, ifToken = ifToken if1
, ifFty = ifFty if1
, ifString = Nothing
, ifValue = liftM2 f2 (ifValue if1) (ifValue if2)
, ifRaw = ifRaw if1
, ifBound = ifBound if1 && ifBound if2
}
name = ifName
string = ifString
valueInputField inf =
case ifValue inf of
Nothing -> error ("InputField { " ++
"ifName = " ++ show (ifName inf) ++ ", " ++
"ifString = " ++ show (ifString inf) ++ ", " ++
"ifBound = " ++ show (ifBound inf) ++
" }")
Just vl -> vl
feither :: (a -> b) -> (c -> d) -> Either a c -> Either b d
feither f g (Left a) = Left (f a)
feither f g (Right b) = Right (g b)
propagate :: Either [err] a -> Either [err] b -> Either [err] (a,b)
propagate (Right a) (Right b) = Right (a, b)
propagate (Right a) (Left bss) = Left bss
propagate (Left ass) (Right b) = Left ass
propagate (Left ass) (Left bss) = Left (mplus ass bss)
data ValidationError =
ValidationError { veName :: String
, veToken :: CGIFieldName
, veString :: Maybe String
}
validateInputField inf =
case ifValue inf of
Nothing | ifBound inf ->
Left [ValidationError (ifName inf) (ifToken inf) (ifString inf)]
_ ->
Right InputField{ ifName = ifName inf
, ifToken = ifToken inf
, ifFty = ifFty inf
, ifString = ifString inf
, ifValue = ifValue inf
, ifRaw = ifRaw inf
, ifBound = ifBound inf
}
data InputType = TEXT | PASSWORD | CHECKBOX |
RADIO | SUBMIT | RESET |
FILE | HIDDEN | IMAGE | BUTTON
deriving (Eq)
instance Show InputType where
show TEXT = "text"
show PASSWORD = "password"
show CHECKBOX = "checkbox"
show RADIO = "radio"
show SUBMIT = "submit"
show RESET = "reset"
show FILE = "file"
show HIDDEN = "hidden"
show IMAGE = "image"
show BUTTON = "button"
textual :: InputType -> Bool
textual TEXT = True
textual PASSWORD = True
textual FILE = True
textual _ = False
type HTMLField cgi x y a = H.WithHTML x cgi () -> H.WithHTML y cgi a
resetField :: (CGIMonad cgi) => HTMLField cgi x y (InputField () INVALID)
resetField =
genericField RESET (const (Just ()))
submitField :: (CGIMonad cgi) => cgi () -> HTMLField cgi x y ()
submitField action =
internalSubmitField False (Right action)
defaultSubmitField :: (CGIMonad cgi) => cgi () -> HTMLField cgi x y ()
defaultSubmitField action =
internalSubmitField True (Right action)
internalSubmitField isDefault what attrs =
do sf <- genericField SUBMIT (const (Just ())) attrs
attachAction (ifName sf) isDefault what
attachAction fname isDefault what =
do pageInfo <- H.lift getInfo
let mbnds = bindings pageInfo
localAction =
case what of
Right action ->
let act = resetFrame >> action in
do H.lift (setAction (const act))
H.lift (registerAction fname (const act))
Left sts ->
let names = map veName sts
values = map (fromMaybe "" . veString) sts
in
do H.lift (setAction tell)
H.lift (registerAction fname tell)
H.lift (setFaulty $ zip names values)
case mbnds of
Nothing ->
return ()
Just bnds ->
case assocParm fname bnds of
Just _ ->
localAction
Nothing ->
case assocParm subVar bnds of
Just submitter |
submitter == fname || submitter == "" && isDefault
-> localAction
_ -> return ()
activeInputField :: (CGIMonad cgi, Reason a, Read a)
=> (a -> cgi ())
-> HTMLField cgi x y ()
activeInputField actionFun attrs =
activateI actionFun inputField attrs
activateI :: (CGIMonad cgi) =>
(a -> cgi ()) -> HTMLField cgi x y (InputField a INVALID) -> HTMLField cgi x y ()
activateI actionFun inputField attrs =
do js_enabled <- H.lift getJSEnabled
let use_js = maybe True id js_enabled
invalid_inf <- inputField (do attrs
when use_js $ onChange $ "WASHSubmit(this.name);")
let r = validateInputField invalid_inf
rv = either Left (Right . valueInputField) r
when (ifBound invalid_inf) $
activateInternal actionFun (ifName invalid_inf) rv
activateInternal actionFun name what =
case what of
Right val ->
let act = resetFrame >> actionFun val in
do H.lift (setAction (const act))
H.lift (registerAction name (const act))
Left sts ->
let names = map veName sts
values = map (fromMaybe "" . veString) sts
in
do H.lift (setAction tell)
H.lift (setFaulty $ zip names values)
H.lift (registerAction name tell)
inputField :: (CGIMonad cgi, Reason a, Read a) => HTMLField cgi x y (InputField a INVALID)
inputField =
genericField TEXT (maybeRead . fromMaybe "")
maybeRead :: Read a => String -> Maybe a
maybeRead s = g (reads s)
where g ((a,""):_) = Just a
g _ = Nothing
textInputField :: (CGIMonad cgi) => HTMLField cgi x y (InputField String INVALID)
textInputField =
genericField TEXT id
checkedTextInputField :: (CGIMonad cgi) => (Maybe String -> Maybe String)
-> HTMLField cgi x y (InputField String INVALID)
checkedTextInputField g attrs =
genericField TEXT g attrs
passwordInputField :: (CGIMonad cgi, Reason a, Read a) => HTMLField cgi x y (InputField a INVALID)
passwordInputField =
genericField PASSWORD (maybeRead . fromMaybe "")
checkboxInputField :: (CGIMonad cgi) => HTMLField cgi x y (InputField Bool INVALID)
checkboxInputField =
genericField CHECKBOX g
where g Nothing = Just False
g (Just _) = Just True
fileInputField :: (CGIMonad cgi) => HTMLField cgi x y (InputField FileReference INVALID)
fileInputField attrs =
H.lift (setEnctype "multipart/form-data") >>
genericField FILE (maybeRead . fromMaybe "") attrs
checkedFileInputField :: (CGIMonad cgi) => (Maybe FileReference -> Maybe FileReference)
-> HTMLField cgi x y (InputField FileReference INVALID)
checkedFileInputField filter attrs =
H.lift (setEnctype "multipart/form-data") >>
genericField FILE (filter . maybeRead . fromMaybe "") attrs
instance Reason FileReference where
reason _ = "FileReference"
genericField :: (Reason a, CGIMonad cgi) => InputType -> (Maybe String -> Maybe a) -> HTMLField cgi x y (InputField a INVALID)
genericField inputType decode fieldAttrs =
let isSUBMIT = inputType == SUBMIT
isFILE = inputType == FILE
in
do fieldName'' <- H.lift nextName
let fieldName' = show fieldName''
fieldName | isSUBMIT = 's' : tail fieldName'
| otherwise = fieldName'
fieldType = show inputType
isTextual = textual inputType
info <- H.lift getInfo
js_enabled <- H.lift getJSEnabled
let use_js = maybe True id js_enabled
(explanation, result) <-
H.input_T
(do H.attr_SS "type" fieldType
H.attr_SD "name" fieldName
fieldAttrs
when (use_js && isSUBMIT) $
onClick ("this.form."++subVar++".value=this.name; return true")
attrs <- H.get_attrs
let [nameAttr] = [ H.attr_value a
| a <- attrs, H.attr_name a == "name"
]
bds = bindings info
maybestring = bds >>= assocParm nameAttr
rawvalues = maybeToList bds >>= assocParmR nameAttr
mdecoded = decode maybestring
decoded = fromJust mdecoded
isBound = isJust bds
theReason = reason decoded
advice = "Enter " ++ prependArticle theReason
explanation = theReason ++ " expected"
when (use_js && isTextual) $ do
onMouseOver ("self.status=" ++ jsShow advice ++ "; return true")
onMouseOut ("self.status=''; return true")
unless (isFILE || isSUBMIT) $ case maybestring of
Nothing -> H.empty
Just str -> H.attr_SD "value" str
H.attr_SS "title" explanation
return (explanation,
InputField { ifName = nameAttr
, ifToken = fieldName''
, ifFty = fieldType
, ifString = maybestring
, ifValue = mdecoded
, ifRaw = rawvalues
, ifBound = isBound
}))
H.lift $ addField (ifName result) isTextual
return result
internalSubmitLink :: (CGIMonad cgi) =>
Bool -> Either [ValidationError] (cgi ()) -> H.HTMLCons x y cgi ()
internalSubmitLink isDefault what subs =
do fieldToken <- H.lift nextName
let fieldName = show fieldToken
atv = "javascript:" ++ "WASHSubmit('"++fieldName++"'); void 0;"
H.a_T (H.attr_SS "href" atv >> subs)
attachAction fieldName isDefault what
imageField :: (CGIMonad cgi) => Image -> HTMLField cgi x y (InputField (Int, Int) INVALID)
imageField image fieldAttrs =
do fieldToken <- H.lift nextName
let fieldName = show fieldToken
H.input_T (do H.attr_SS "type" "image"
H.attr_SD "name" fieldName
H.attr_SD "src" (unURL $ imageSRC image)
fieldAttrs)
H.lift $ addField fieldName False
info <- H.lift getInfo
return $
let maybe_xy =
do bds <- bindings info
x <- assocParm (fieldName ++ ".x") bds
y <- assocParm (fieldName ++ ".y") bds
return (x, y)
in
InputField { ifName = fieldName
, ifToken = fieldToken
, ifFty = "image"
, ifString = do (x, y) <- maybe_xy
return ("(" ++ x ++ "," ++ y ++ ")")
, ifValue = do (x, y) <- maybe_xy
return (read x, read y)
, ifRaw = []
, ifBound = isJust (bindings info)
}
data RadioGroup a x =
RadioGroup { radioName :: String
, radioToken :: CGIFieldName
, radioString :: Maybe String
, radioValue :: Maybe a
, radioBound :: Bool
}
validateRadioGroup rg =
case radioValue rg of
Nothing | radioBound rg ->
Left [ValidationError (radioName rg) (radioToken rg) (radioString rg)]
_ ->
Right RadioGroup { radioName = radioName rg
, radioToken = radioToken rg
, radioString = radioString rg
, radioValue = radioValue rg
, radioBound = radioBound rg
}
valueRadioGroup rg =
case radioValue rg of
Nothing -> error ("RadioGroup { " ++
"radioName = " ++ show (radioName rg) ++ ", " ++
"radioString = " ++ show (radioString rg) ++ ", " ++
"radioBound = " ++ show (radioBound rg) ++
" }")
Just vl -> vl
radioGroup :: (CGIMonad cgi, Read a) => H.WithHTML x cgi (RadioGroup a INVALID)
radioGroup =
do token <- H.lift nextName
let fieldName = show token
info <- H.lift getInfo
H.lift $ addField fieldName False
let bds = bindings info
maybeString = bds >>= assocParm fieldName
maybeVal = maybeString >>= (g . reads . URLCoding.decode)
g ((a,""):_) = Just a
g _ = Nothing
return $
RadioGroup { radioName = fieldName
, radioToken = token
, radioString = maybeString
, radioValue = maybeVal
, radioBound = isJust bds
}
radioButton :: (Show a, Monad cgi) => RadioGroup a INVALID -> a -> HTMLField cgi x y ()
radioButton rg val fieldAttrs =
H.input_T (do H.attr_SS "type" "radio"
H.attr_SD "name" (radioName rg)
H.attr_SD "value" (URLCoding.encode (show val))
fieldAttrs)
radioError :: (CGIMonad cgi) => RadioGroup a INVALID -> H.WithHTML x cgi ()
radioError rg =
let name = radioName rg in
do im <- internalImage nothing "Select exactly one button"
makeImg im (H.attr "align" "center" >> H.attr "name" ('i' : name))
makeButton :: (CGIMonad cgi) => HTMLField cgi x y (InputField Bool INVALID)
makeButton fieldAttrs =
let fieldType = "button" in
do fieldToken <- H.lift nextName
let fieldName = show fieldToken
H.input_T (do H.attr_SS "type" fieldType
H.attr_SD "name" fieldName
fieldAttrs)
H.lift $ addField fieldName False
info <- H.lift getInfo
let bds = bindings info
maybeString = bds >>= assocParm fieldName
maybeVal =
case bds of
Nothing -> Nothing
Just parms ->
case maybeString of
Nothing -> Just False
Just _ -> Just True
return $
InputField { ifName = fieldName
, ifToken = fieldToken
, ifFty = fieldType
, ifString = maybeString
, ifValue = maybeVal
, ifRaw = []
, ifBound = isJust bds
}
constructQuery url [] =
url
constructQuery url args =
url ++ '?' : concat (List.intersperse "+" (map URLCoding.encode args))
makeForm :: (CGIMonad cgi) => H.WithHTML x cgi a -> H.WithHTML y cgi ()
makeForm attrs_elems =
makeFormWithErrorMark
["className='faultyinput'"]
attrs_elems
makeFormWithErrorMark errorMarks attrs_elems = do
url <- H.lift getUrl
args <- H.lift getCGIArgs
js_enabled <- H.lift getJSEnabled
let use_js = maybe True id js_enabled
when use_js $ H.script_S
(do H.attr_SS "type" "text/javascript"
H.comment $
"\n" ++
"var SubmitAction=[];" ++
"function OnSubmit(){" ++
"var r=true;" ++
"for(var i=0;i<SubmitAction.length;i++){r=r&&SubmitAction[i]();};" ++
"return r;};"++
"function WASHSubmit(fn){" ++
"var ff = document.forms[0];" ++
"ff."++subVar++".value=fn;" ++
"ff.submit();" ++
"}" ++
"\n// "
)
jsprog <- H.form_T $
do H.attr_SD "action" (constructQuery url args)
H.attr_SS "method" "post"
when use_js $ onSubmit ("return OnSubmit();")
attrs_elems
H.attr_SS "target" "_self"
info <- H.lift getInfo
parm <- H.lift getParm
stid <- H.lift getStateID
sessionMode <- H.lift getSessionMode
encoder <- H.lift getEncoder
fields <- H.lift getFields
let ff = faultyfields info
realparm | null ff = parm
| otherwise = tail parm
enabledString =
case js_enabled of
Just True -> "True"
_ -> "False"
H.input_S
(do H.attr_SS "type" "hidden"
H.attr_SS "name" "js_enabled"
H.attr_SS "value" enabledString)
H.input_S
(do H.attr_SS "type" "hidden"
H.attr_SS "name" subVar
H.attr_SS "value" "")
when (sessionNeedsLog sessionMode) $
H.input_S
(do H.attr_SS "type" "hidden"
H.attr_SS "name" "=CGI=parm="
H.attr_SD "value"
(Base64.encode' $ encoder $ RFC2279.encode $ show $ realparm))
when (sessionNeedsState sessionMode) $
H.input_S
(do H.attr_SS "type" "hidden"
H.attr_SS "name" "=CGI=stid="
H.attr_SD "value" (Base64.encode' stid))
let
checkForJS =
case js_enabled of
Nothing ->
"document.forms[0].js_enabled.value='True';"
_ -> ""
iFields = [iname | (iname@('f':_), True) <- fields]
questionURL = url ++ '?' : ffName question
hilight =
case iFields of
[] -> []
name':_ -> ["document.forms[0]." ++ name' ++ ".focus();"
,"document.forms[0]." ++ name' ++ ".select();"]
markAsFaulty (fname, fvalue) | fname `elem` iFields =
"if(document.i" ++ fname ++ ")" ++
"document.i" ++ fname ++ ".src = " ++ jsShow questionURL ++ ";" ++
"else{" ++
(let f mark = "document.forms[0]." ++ fname ++ "." ++ mark ++ ";" in
List.concatMap f errorMarks) ++
"}"
| otherwise =
"popupstr += "
++ jsShow ("In a previous form, the field " ++ fname ++
" had an unparsable input value: " ++ fvalue ++ "\n")
++ ";"
jsprog | null ff = hilight
| otherwise =
"popupstr = '';"
: map markAsFaulty ff
++ "if (popupstr != '') alert(popupstr + 'Please go back and reenter!');"
: hilight
when (not (null ff)) $ H.comment_T ("Faultyfields: " ++ show ff)
H.attr_SD "enctype" (enctype info)
return (checkForJS : jsprog)
when (use_js && not (null jsprog)) $
H.script_T
(do H.attr_SS "type" "text/javascript"
H.rawtext_S "<!-- "
H.rawtext ('\n' : unlines jsprog)
H.rawtext_S "// -->")
makeTextarea :: (CGIMonad cgi) => String -> HTMLField cgi x y (InputField String INVALID)
makeTextarea fieldValue fieldAttrs =
do token <- H.lift nextName
info <- H.lift getInfo
let bds = bindings info
mvalue = bds >>= assocParm name
name = show token
displayValue = fromMaybe fieldValue mvalue
H.textarea_T (do H.attr_SD "name" name
H.text_S displayValue
fieldAttrs)
return $
InputField { ifName = name
, ifToken = token
, ifFty = "textarea"
, ifString = mvalue
, ifValue = mvalue
, ifRaw = maybeToList bds >>= assocParmR name
, ifBound = isJust bds
}
selectTags = map (('o':) . show) [(1::Int)..]
selectMultiple :: (CGIMonad cgi, Eq a)
=> (a -> String)
-> [a]
-> [a]
-> (Int, Int)
-> HTMLField cgi x y (InputField [a] INVALID)
selectMultiple shw defs opts (minSel, maxSel) attrs =
do token <- H.lift nextName
let name = show token
info <- H.lift getInfo
let bds = bindings info
rawvalues = maybeToList bds >>= assocParmR name
g ('o':i:rest) = i /= '0'
g _ = False
inputs = filter g $ map fieldContents rawvalues
values = inputs >>=
(maybeToList . flip List.elemIndex selectTags) >>=
(\i -> [opts !! i])
len = length inputs
mvalue | minSel <= len && len <= maxSel = Just values
| otherwise = Nothing
revisedDefaults | isJust bds && not (null inputs) = values
| otherwise = defs
let makeoption (opt, tag) =
H.option_T (do H.text (shw opt)
H.attr_SD "value" tag
when (opt `elem` revisedDefaults) $
H.attr_SS "selected" "selected")
makeChoice :: Int -> String
makeChoice n | n == 0 = "no choice"
| n == 1 = "1 choice"
| n == maxBound = "arbitrary many choices"
| otherwise = show n ++ " choices"
makeRange :: Int -> Int -> String
makeRange lo hi | lo == maxBound = "Arbitrary many choices"
| lo == hi = "Exactly " ++ makeChoice lo
| otherwise = "Minimum " ++ makeChoice lo ++
"; maximum " ++ makeChoice hi
H.select_T
(do attrs
H.attr_SD "name" name
when (maxSel > 1) $
H.attr_SS "multiple" "multiple"
when (null defs && minSel > 0) $
H.option_S (do H.text_S "--"
H.attr_SS "value" "o0")
mapM_ makeoption (zip opts selectTags))
im <- internalImage nothing (makeRange minSel maxSel)
makeImg im (do H.attr_SS "align" "center"
H.attr_SD "name" ('i' : name))
return $
InputField { ifName = name
, ifToken = token
, ifFty = "select"
, ifString = Nothing
, ifValue = mvalue
, ifRaw = rawvalues
, ifBound = isJust bds
}
selectSingle :: (CGIMonad cgi, Eq a)
=> (a -> String)
-> Maybe a
-> [a]
-> HTMLField cgi x y (InputField a INVALID)
selectSingle shw mdef opts attrs =
do inf <- selectMultiple shw (maybeToList mdef) opts (1,1) attrs
return $
InputField { ifName = ifName inf
, ifToken = ifToken inf
, ifFty = "select"
, ifString = ifString inf
, ifValue = fmap Prelude.head (ifValue inf)
, ifRaw = ifRaw inf
, ifBound = ifBound inf
}
selectBounded :: (CGIMonad cgi, Enum a, Bounded a, Read a, Show a, Eq a) =>
Maybe a -> HTMLField cgi x y (InputField a INVALID)
selectBounded def =
selectSingle show def [minBound..maxBound]
fieldSIZE :: Monad m => Int -> H.WithHTML x m ()
fieldSIZE i = H.attr_SD "size" (show i)
fieldMAXLENGTH :: Monad m => Int -> H.WithHTML x m ()
fieldMAXLENGTH i = H.attr_SD "maxlength" (show i)
fieldVALUE :: (Monad m, Show a) => a -> H.WithHTML x m ()
fieldVALUE a = H.attr_SD "value" (show a)
data Image =
Image { imageSRC :: URL
, imageALT :: String
}
internalImage :: (CGIMonad cgi) =>
FreeForm
-> String
-> H.WithHTML x cgi Image
internalImage ff alttext =
do baseUrl <- H.lift getUrl
externalImage (URL (baseUrl ++ '?' : ffName ff)) alttext
dataImage :: (CGIMonad cgi) =>
FreeForm
-> String
-> H.WithHTML x cgi Image
dataImage ff alttext =
let url = URL (RFC2397.encode (ffContentType ff, ffRawContents ff)) in
externalImage url alttext
jsImage :: (CGIMonad cgi) =>
FreeForm
-> String
-> H.WithHTML x cgi Image
jsImage ff alttext =
let url = URL ("javascript:" ++ jsShow (ffRawContents ff)) in
externalImage url alttext
externalImage :: (CGIMonad cgi) =>
URL
-> String
-> H.WithHTML x cgi Image
externalImage url alttext =
return $ Image { imageSRC = url
, imageALT = alttext
}
makeImg :: (Monad cgi) => Image -> HTMLField cgi x y ()
makeImg image attrs =
H.img_T (do H.attr_SD "src" (unURL $ imageSRC image)
H.attr_SD "alt" (imageALT image)
H.attr_SD "title" (imageALT image)
attrs)
popuplink :: Monad m => String -> URL -> H.HTMLCons x y m ()
popuplink name url subs =
let atv = "javascript:window.open(" ++
jsShow (unURL url) ++ "," ++
jsShow name ++
"); void(0);" in
H.a_T (H.attr_SD "href" atv >> subs)
restart :: (CGIMonad cgi) => cgi ()
restart =
do myurl <- getUrl
tell (Location $ URL myurl)
standardQuery :: (CGIMonad cgi) => String -> H.WithHTML x cgi a -> cgi ()
standardQuery ttl elems =
ask (H.standardPage ttl (makeForm elems))
debug message = unsafe_io $
do putStrLn "content-type: text/plain"
putStrLn ""
putStrLn message
putStrLn "------------------------------------------------------------"
prependArticle "" = ""
prependArticle xs@(x:_) =
if x `elem` "aeiouAEIOU" then "an " ++ xs else "a " ++ xs