WashNGo-2.12: WASH/CGI/CGIInternals.hs
-- © 2001-2005 Peter Thiemann
module WASH.CGI.CGIInternals (module WASH.CGI.CGIInternals, getPathInfo)
{-- interface
(ask -- WithHTML x CGI a -> CGI ()
,tell -- CGIOutput a => a -> CGI ()
,htell -- WithHTML x IO () -> CGI ()
,run -- CGI () -> IO ()
,runWithHook -- ([String] -> CGI ()) -> CGI () -> IO ()
)
--}
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
-- ======================================================================
-- internal references
-- |Create a hyperlink to internal entity.
makeRef :: (CGIMonad cgi, Monad m)
=> String -- ^internal name of entity
-> H.WithHTML x m () -- ^body of the reference
-> cgi (H.WithHTML y m ())
makeRef fileName elems =
wrapCGI (\cgistate ->
let fileURL = url cgistate ++ '?' : fileName in
return (hlink (URL fileURL) elems, cgistate))
-- |Create a popup hyperlink to internal entity.
makePopupRef :: (CGIMonad cgi) =>
String -- ^name of popup window
-> String -- ^internal name of entity
-> H.HTMLCons x y cgi ()
makePopupRef name fileName elems =
do baseUrl <- H.lift getUrl
let fileURL = baseUrl ++ '?' : fileName
popuplink name (URL fileURL) elems
-- |Create hyperlink to internal entity @\/path?name@.
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
-- ======================================================================
-- input fields & forms
--
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 -- True if form submitted
}
-- |create a virtual input field from the concatenation of two input fields
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
-- |Create a virtual input field from the result of applying a function to two
-- input fields. Parsing is applied to the result of the function call.
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 -- ++ '|' : ifName ifb
, ifToken = ifToken ifa
, ifFty = ifFty ifa
, ifString = newString
, ifValue = newValue
, ifRaw = ifRaw ifa
, ifBound = ifBound ifa && all ifBound ifbs
}
-- |Combine the values of separately parsed fields
combineFieldsWith2 f2 if1 if2 =
InputField { ifName = ifName if1 -- ++ '|' : ifName if2
, ifToken = ifToken if1
, ifFty = ifFty if1
, ifString = Nothing
, ifValue = liftM2 f2 (ifValue if1) (ifValue if2)
, ifRaw = ifRaw if1
, ifBound = ifBound if1 && ifBound if2
}
-- transition code
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
-- raw = ifRaw
-- transition code end
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)
-- to expose less of the implementation, the following type could be
-- propagate :: MonadPlus err => Either (err x) a -> .. Either (err x) (a, 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 -- name of erroneous field
, veToken :: CGIFieldName -- token of erroneous field
, veString :: Maybe String -- value of erroneous field
}
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
}
-- internal
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
-- |Every input widget maps the content generator for the widget (which may
-- produce HTML elements or attributes) to the content generator of the widget.
type HTMLField cgi x y a = H.WithHTML x cgi () -> H.WithHTML y cgi a
-- |Creates a reset button that clears all fields of a form.
resetField :: (CGIMonad cgi) => HTMLField cgi x y (InputField () INVALID)
resetField =
genericField RESET (const (Just ()))
-- |Creates a submit button. Unsafe. Internal use only.
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) -- CHANGE THIS
H.lift (registerAction fname tell)
H.lift (setFaulty $ zip names values)
{--
lift (unsafe_io (do appendFile "/tmp/CGIMBNDS" ("\nlooking for "++name sf++"\n")
appendFile "/tmp/CGIMBNDS" (show mbnds)))
--}
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 ()
-- |Creates an input field that submits the field to the browser when data is
-- entered into this field.
activeInputField :: (CGIMonad cgi, Reason a, Read a)
=> (a -> cgi ()) -- ^Function that maps input data to a CGI action.
-> HTMLField cgi x y ()
activeInputField actionFun attrs =
activateI actionFun inputField attrs
-- |Attach a CGI action to the value returned by the input field. Activation
-- means that data is submitted as soon as it is entered.
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) -- CHANGE THIS
H.lift (setFaulty $ zip names values)
H.lift (registerAction name tell)
-- |Create a textual input field. Return type can be *anything* in class 'Reason'
-- and 'Read'.
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
-- |Create a textual input field that returns the string entered. (Avoids having
-- to put quotes around a string.)
textInputField :: (CGIMonad cgi) => HTMLField cgi x y (InputField String INVALID)
textInputField =
genericField TEXT id
-- |Creates a textual input field that takes a custom validation function.
checkedTextInputField :: (CGIMonad cgi) => (Maybe String -> Maybe String)
-> HTMLField cgi x y (InputField String INVALID)
checkedTextInputField g attrs =
genericField TEXT g attrs
-- |Like 'inputField' but the characters are not echoed on the screen.
passwordInputField :: (CGIMonad cgi, Reason a, Read a) => HTMLField cgi x y (InputField a INVALID)
passwordInputField =
genericField PASSWORD (maybeRead . fromMaybe "")
-- |Creates a checkbox. Returns 'True' if box was checked.
checkboxInputField :: (CGIMonad cgi) => HTMLField cgi x y (InputField Bool INVALID)
checkboxInputField =
genericField CHECKBOX g
where g Nothing = Just False
g (Just _) = Just True
-- |Creates a file input field. Returns a temporary 'FileReference'. The
-- 'fileReferenceName' of the result is *not* guaranteed to be persistent. The
-- application is responsible for filing it away at a safe place.
fileInputField :: (CGIMonad cgi) => HTMLField cgi x y (InputField FileReference INVALID)
fileInputField attrs =
H.lift (setEnctype "multipart/form-data") >>
genericField FILE (maybeRead . fromMaybe "") attrs
-- |Creates a file input field. Like 'fileInputField' but has an additional
-- parameter for additional validation of the input.
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
-- unless isTextual $ H.attr_SD "name" fieldName
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"
-- H.attr_SD "washtype" (washtype decoded)
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
-- {- obsoleted by working css stuff -}
-- when isTextual $ do
-- nothingI <- internalImage nothing explanation
-- makeImg nothingI
-- (do H.attr_SS "align" "center"
-- H.attr_SD "name" ('i' : ifName result))
return result
-- |generates a hyperlink that submits the current form.
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
-- |Create an input field from an image. Returns (x,y)
-- position clicked in the image.
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)
}
-- a virtual field that never appears on the screen
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
-- |Create a handle for a new radio group. /This handle is invisible on the screen!/
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
}
-- |Create a new radio button and attach it to an existing 'RadioGroup'.
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)
-- |Create and place the error indicator for an existing 'RadioGroup'. Becomes
-- visible only if no button of a radio group is pressed.
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))
-- buttons
-- |Create a single button.
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
}
-- form
-- multiple arguments formed according to CGI 1.1 rev 3 spec
-- http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#5.0
constructQuery url [] =
url
constructQuery url args =
url ++ '?' : concat (List.intersperse "+" (map URLCoding.encode args))
-- |Wraps an HTML form around its arguments. All standard attributes are
-- computed and need not be supplied explicitly.
makeForm :: (CGIMonad cgi) => H.WithHTML x cgi a -> H.WithHTML y cgi ()
makeForm attrs_elems =
makeFormWithErrorMark
-- ["style.backgroundColor='red'", "style.borderColor='black'"]
["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" -- ensure target attr is present
-- formname <- liftM show $ H.lift nextName
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 "name" formname
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 "// -->")
-- textarea
-- |Create a text area with a preset string.
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
}
-- select
selectTags = map (('o':) . show) [(1::Int)..]
-- |Create a selection box where multiple entries can be selected.
selectMultiple :: (CGIMonad cgi, Eq a)
=> (a -> String) -- ^function to display values of type a
-> [a] -- ^list of preselected entries
-> [a] -- ^list of all possible entries
-> (Int, Int) -- ^(min, max) number of fields that must be selected
-> 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 -- fmap show value
, ifValue = mvalue
, ifRaw = rawvalues
, ifBound = isJust bds
}
-- |Create a selection box where exactly one entry can be selected.
selectSingle :: (CGIMonad cgi, Eq a)
=> (a -> String) -- ^function to display values of type a
-> Maybe a -- ^optional preselected value
-> [a] -- ^list of all possible values
-> 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
}
-- |Selection box for elements of a "Bounded" type. Argument is the optional
-- preselected value.
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]
-- ======================================================================
-- attributes
-- |Create a 'SIZE' attribute from an 'Int'.
fieldSIZE :: Monad m => Int -> H.WithHTML x m ()
fieldSIZE i = H.attr_SD "size" (show i)
-- |Create a 'MAXLENGTH' attribute from an 'Int'.
fieldMAXLENGTH :: Monad m => Int -> H.WithHTML x m ()
fieldMAXLENGTH i = H.attr_SD "maxlength" (show i)
-- |Create a 'VALUE' attribute from any 'Show'able.
fieldVALUE :: (Monad m, Show a) => a -> H.WithHTML x m ()
fieldVALUE a = H.attr_SD "value" (show a)
-- Images
data Image =
Image { imageSRC :: URL
, imageALT :: String
}
-- |Reference to internal image.
internalImage :: (CGIMonad cgi) =>
FreeForm -- ^the raw image
-> String -- ^alternative text
-> H.WithHTML x cgi Image
internalImage ff alttext =
do baseUrl <- H.lift getUrl
externalImage (URL (baseUrl ++ '?' : ffName ff)) alttext
-- |Reference to internal image via data URL (small images, only).
dataImage :: (CGIMonad cgi) =>
FreeForm -- ^the raw image
-> String -- ^alternative text
-> H.WithHTML x cgi Image
dataImage ff alttext =
let url = URL (RFC2397.encode (ffContentType ff, ffRawContents ff)) in
externalImage url alttext
-- |Reference to internal image via javascript URL (does not seem to work).
jsImage :: (CGIMonad cgi) =>
FreeForm -- ^the raw image
-> String -- ^alternative text
-> H.WithHTML x cgi Image
jsImage ff alttext =
let url = URL ("javascript:" ++ jsShow (ffRawContents ff)) in
externalImage url alttext
-- |Reference to image by URL.
externalImage :: (CGIMonad cgi) =>
URL -- ^URL of image
-> String -- ^alternative text
-> H.WithHTML x cgi Image
externalImage url alttext =
return $ Image { imageSRC = url
, imageALT = alttext
}
-- |Create an inline image.
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)
-- |Hyperlink that creates a named popup window from an URL string.
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 application.
restart :: (CGIMonad cgi) => cgi ()
restart =
do myurl <- getUrl
tell (Location $ URL myurl)
-- |Convenient workhorse. Takes the title of a page and a monadic HTML value for
-- the contents of the page. Wraps the contents in a form so that input fields
-- and buttons may be used inside.
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