Commit 72023d2f authored by Michael Hanus 's avatar Michael Hanus

Improved version without unsafe operations

parent f873428c
Some implementation details
---------------------------
This small document describes a few details about the implementation
of web forms used in this package.
The basic idea is to combine the actions generating the HTML page
containing the source of the forms with the event handlers processing
a submitted form in one program (see the various examples
in directory `examples`). This has the advantage that input
fields do not require explicit names so that the consistency
of input fields and their event handlers can be controlled
by the Curry compiler. This technique exploits the functional logic
features of Curry and is explained in detail in
[this paper](http://www.informatik.uni-kiel.de/~mh/papers/PADL01.html).
This idea is implemented by starting the same executable for
generating and processing a form. Therefore, the `action`
attribute of a form occurring in a web page has the same URL
as the original page, i.e., each form has the structure
<form method="post" action="?">
<input type="hidden" name="FORMID" value="..."/>
...
</form>
If a form is submitted by the client, the hidden field with name `FORMID`
indicates this form submission to the main program. The value associated
to this name is a unique identifier for this form. Usually, this
is the qualified name of the operation in the Curry source code
producing this form (this is checked by the program `curry2cgi`).
This information is used by the main program to invoke the
corresponding event handler. The input fields occurring in
the form (text fields, submit buttons, etc), identified by
logic variables in the source programs, are sequentially numbered
when a form is generated. This allows a simple identification
of the corresponding values submitted by the client.
The auxiliary program `curry2cgi` is used to transform a
Curry program containing forms into an executable.
`curry2cgi` collects all operations defining forms in a program
and generates the main program which is compiled as the executable
invoked by CGI. The generated program defines a main operation
of the following form:
main :: IO ()
main = HTML.CGI.Exec.printMainPage
[ (<formid1>, HTML.CGI.Exec.execFormDef <formdef1>)
, ...
, (<formidk>, HTML.CGI.Exec.execFormDef <formdefk>)
]
<mainpage>
Here `<formid1>,...<formidk>` are the identifiers of all form definitions
to be compiled. Thus, the operation `HTML.CGI.Exec.printMainPage`
is responsible to generate the initial HTML page or, if a form
is submitted, invoke the corresponding event handler defined
in the form.
Copyright (c) 2017, Michael Hanus
Copyright (c) 2019, Michael Hanus
All rights reserved.
Redistribution and use in source and binary forms, with or without
......
......@@ -10,7 +10,7 @@ the Curry Port Name Server (CPNS), the HTML/CGI Registry, etc.
For this purpose, web forms are a bit more restricted:
each web form has an IO action to read the data required for
the form and a result page shown after submitting the form.
To implement the event handler inside a form without a process,
To implement the event handlers inside a form without a process,
the read IO action is executed again when a form is submitted.
Some simple examples for dynamic web pages can be found in the
......
......@@ -15,14 +15,14 @@ guessNr :: Global (SessionStore Int)
guessNr = global emptySessionStore (Persistent "guessNr")
guessInputForm :: HtmlFormDef Int
guessInputForm = HtmlFormDef "Guess.guessInputForm" readGuesses formHtml
guessInputForm = formDefWithID "Guess.guessInputForm" readGuesses formHtml
where
readGuesses = getSessionData guessNr 0 -- read session data
formHtml n =
(if n>0 then [h4 [htxt $ show (n+1) ++ ". attempt:"]] else []) ++
[htxt "Guess a natural number: ", textfield nref "",
formButton "Check" guessHandler]
[htxt "Guess a natural number: ", textField nref "",
button "Check" guessHandler]
where
nref free
......@@ -42,11 +42,8 @@ guessInputForm = HtmlFormDef "Guess.guessInputForm" readGuesses formHtml
-- main HTML page containing the form
main :: IO HtmlPage
main = do
cookie <- sessionCookie -- be sure that there is a cookie for the session
putSessionData guessNr 0 -- initialize session state
return (standardPage "Number Guessing Game"
[ formExp guessInputForm ] `addPageParam` cookie)
main = withSessionCookieInfo $
standardPage "Number Guessing Game" [ formExp guessInputForm ]
-- Install the CGI script in user homepage by:
-- > cypm exec curry2cgi -o ~/public_html/cgi-bin/guess.cgi Guess
......@@ -8,13 +8,13 @@ import HTML.Base
-- Example: a form with a text input field and two submit buttons.
revDupForm :: HtmlFormDef String
revDupForm = HtmlFormDef "RevDup.revDupForm" (return "") formHtml
revDupForm = formDefWithID "RevDup.revDupForm" (return "") formHtml
where
formHtml _ =
[ htxt "Enter a string: ", textfield ref ""
[ htxt "Enter a string: ", textField ref ""
, hrule
, formButton "Reverse string" revHandler
, formButton "Duplicate string" dupHandler
, button "Reverse string" revHandler
, button "Duplicate string" dupHandler
]
where
ref free
......
......@@ -3,7 +3,7 @@
-- A web page with a form containing a text input field and two submit buttons
-- to reverse and duplicate the input string.
-- Here we use session data to store the string typed into the input
-- field in order to use it for a subsequent form.
-- field in order to use it for the subsequent form.
------------------------------------------------------------------------------
import FilePath ( (</>) )
......@@ -18,15 +18,15 @@ rdInput = global emptySessionStore (Persistent ("." </> "rdInput"))
-- Example: a form with a text input field and two submit buttons.
revDupForm :: HtmlFormDef String
revDupForm = HtmlFormDef "RevDupSession.revDupForm" readInfo formHtml
revDupForm = formDefWithID "RevDupSession.revDupForm" readInfo formHtml
where
readInfo = getSessionData rdInput ""
formHtml s =
[ htxt "Enter a string: ", textfield ref s
[ htxt "Enter a string: ", textField ref s
, hrule
, formButton "Reverse string" revHandler
, formButton "Duplicate string" dupHandler
, button "Reverse string" revHandler
, button "Duplicate string" dupHandler
]
where
ref free
......@@ -45,7 +45,7 @@ revDupForm = HtmlFormDef "RevDupSession.revDupForm" readInfo formHtml
-- main HTML page containing the form
main :: IO HtmlPage
main = withSessionCookie $ page "Question"
main = withSessionCookieInfo $ page "Question"
[ h1 [htxt "This is an example form"]
, formExp revDupForm
]
......
......@@ -6,18 +6,19 @@
------------------------------------------------------------------------------
import Time
import HTML.Base
import TimeForm ( timeForm )
-- Example: a form with a text input field and two submit buttons.
revDupForm :: HtmlFormDef String
revDupForm = HtmlFormDef "RevDupTime.revDupForm" (return "") formHtml
revDupForm = formDefWithID "RevDupTime.revDupForm" (return "") formHtml
where
formHtml _ =
[ htxt "Enter a string: ", textfield ref ""
[ htxt "Enter a string: ", textField ref ""
, hrule
, formButton "Reverse string" revHandler
, formButton "Duplicate string" dupHandler
, button "Reverse string" revHandler
, button "Duplicate string" dupHandler
]
where
ref free
......
......@@ -8,9 +8,9 @@ import HTML.Base
-- Example: a form with button to show the current time.
timeForm :: HtmlFormDef String
timeForm = HtmlFormDef "TimeForm.timeForm" (return "") formHtml
timeForm = formDefWithID "TimeForm.timeForm" (return "") formHtml
where
formHtml _ = [ formButton "Show time" timeHandler ]
formHtml _ = [ button "Show time" timeHandler ]
where
timeHandler _ = do
ltime <- getLocalTime
......
......@@ -2,17 +2,19 @@
"name": "html2",
"version": "0.0.1",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Libraries for better HTML programming.",
"synopsis": "Libraries for HTML programming.",
"category": [ "Web" ],
"dependencies": {
"currypath": ">= 0.0.1",
"flatcurry": ">= 2.0.0",
"random" : ">= 0.0.1"
"base" : ">= 1.0.0, < 2.0.0",
"abstract-curry": ">= 2.0.0",
"cryptohash" : ">= 0.0.1",
"currypath" : ">= 0.0.1",
"random" : ">= 0.0.1"
},
"sourceDirs": [ "src", "scripts" ],
"exportedModules": [ "HTML.Base",
"HTML.CategorizedList", "HTML.LaTeX",
"HTML.Parser",
"HTML.Parser", "HTML.Session",
"HTML.Styles.Bootstrap3" ],
"compilerCompatibility": {
"pakcs": ">= 2.0.0",
......@@ -25,7 +27,7 @@
"main": "Curry2CGI"
},
"source": {
"git": "https://git.ps.informatik.uni-kiel.de/curry-packages/html.git",
"git": "https://git.ps.informatik.uni-kiel.de/curry-packages/html2.git",
"tag": "$version"
}
}
------------------------------------------------------------------------------
--- Auxiliary definitions used by the form checker.
---
--- @author Michael Hanus
--- @version September 2019
------------------------------------------------------------------------------
import System ( exitWith )
import HTML.Base
checkFormID :: (HtmlFormDef a, String) -> IO ()
checkFormID (fd, s) =
unless (formDefId fd == s) $ do
putStrLn $ "ERROR: form operation '" ++ s ++ "' has non-matching ID!"
exitWith 1
......@@ -5,7 +5,7 @@
--- for executing cgi scripts.
---
--- @author Michael Hanus
--- @version September 2019
--- @version October 2019
------------------------------------------------------------------------------
module Curry2CGI
......@@ -21,17 +21,18 @@ import ReadNumeric ( readNat )
import System
import Time ( calendarTimeToString, getLocalTime )
import FlatCurry.Types
import System.CurryPath ( stripCurrySuffix )
import AbstractCurry.Types ( QName )
import System.CurryPath ( stripCurrySuffix )
import ExtractForms ( extractFormsInProg )
import ExtractForms ( extractFormsInProg, showQName )
main :: IO ()
main = do
args <- getArgs
(opts,prog) <- processOptions args
checkCurrySystem (optSystem opts)
formops <- mapM (extractFormsInProg (optSystem opts)) (optFormMods opts)
formops <- mapM (extractFormsInProg (optVerb opts) (optSystem opts))
(optFormMods opts)
compileCGI (opts { optForms = nub (concat formops) }) prog
checkCurrySystem :: String -> IO ()
......@@ -43,7 +44,7 @@ checkCurrySystem currydir = do
compileCGI :: Options -> String -> IO ()
compileCGI opts mname = do
putStrLn $ "Wrapping '" ++ mname ++ "' to generate CGI binary..."
putStrLnIfNQ opts $ "Wrapping '" ++ mname ++ "' to generate CGI binary..."
pid <- getPID
let mainmod = mname ++ "_CGIMAIN_" ++ show pid
maincall = "main_cgi_9999_" ++ show pid
......@@ -51,12 +52,17 @@ compileCGI opts mname = do
else optOutput opts
cgidir = dirName cgifile
createDirectoryIfMissing True cgidir
writeFile (mainmod ++ ".curry") (genMainProg opts mname mainmod maincall)
let mainprog = genMainProg opts mname mainmod maincall
when (optVerb opts > 1) $ putStr $ unlines
[line, "GENERATED MAIN PROGRAM:", mainprog, line]
writeFile (mainmod ++ ".curry") mainprog
-- compile main module:
cf <- system $ unwords
[optCPM opts, optSystem opts </> "bin" </> "curry", "--nocypm",
-- $CURRYDOPTIONS $CURRYOPTIONS
":load", mainmod, ":save", maincall, ":quit"]
cf <- system $ unwords $
[ optCPM opts, optSystem opts </> "bin" </> "curry" , "--nocypm" ] ++
map (\rcopts -> "-D" ++ rcopts) (optCurryRC opts) ++
[ ":set", 'v' : show (optVerb opts) ] ++
optCurryOpts opts ++
[ ":load", mainmod, ":save", maincall, ":quit" ]
when (cf > 0) $ do
putStrLn "Error occurred, generation aborted."
cleanMain mainmod
......@@ -69,13 +75,14 @@ compileCGI opts mname = do
cleanMain mainmod
cdate <- getLocalTime >>= return . calendarTimeToString
writeFile (cgifile ++ ".log") (cdate ++ ": cgi script compiled\n")
putStrLn $ "New files \"" ++ cgifile ++ "*\" with compiled cgi script generated."
putStrLnIfNQ opts $
"New files \"" ++ cgifile ++ "*\" with compiled cgi script generated."
where
cleanMain mainmod = do
system $ unwords [optSystem opts </> "bin" </> "cleancurry", mainmod]
system $ "/bin/rm -f " ++ mainmod ++ ".curry"
-- generate cgi shell script:
-- Generates the small cgi shell script that actually calls the executable.
genShellScript :: Options -> String -> IO ()
genShellScript opts cgifile = do
system $ "/bin/rm -f " ++ cgifile
......@@ -91,6 +98,19 @@ genShellScript opts cgifile = do
system $ unwords ["chmod", "755", cgifile]
done
--- Generates the main program which is compiled as the CGI executable.
--- The program defines a main operation of the following form:
---
--- main :: IO ()
--- main = HTML.CGI.Exec.printMainPage
--- [ (<formid1>, HTML.CGI.Exec.execFormDef <formdef1>)
--- , ...
--- , (<formidk>, HTML.CGI.Exec.execFormDef <formdefk>)
--- ]
--- <mainpage>
---
--- where `<formid1>,...<formidk>` are the identifiers of all form definitions
--- to be compiled.
genMainProg :: Options -> String -> String -> String -> String
genMainProg opts mname mainmod maincall = unlines $
[ "module " ++ mainmod ++ "(" ++ maincall ++ ") where"
......@@ -98,11 +118,12 @@ genMainProg opts mname mainmod maincall = unlines $
, "import HTML.CGI.Exec" ] ++
(map ("import " ++) (nub (mname : optFormMods opts))) ++
[ maincall ++ " :: IO ()"
, maincall ++ " = HTML.CGI.Exec.showFormPageAction [" ++
intercalate "," formCalls ++ "] (" ++ optMain opts ++ ")"
, maincall ++ " = HTML.CGI.Exec.printMainPage\n [" ++
intercalate "\n ," formCalls ++ "]\n" ++
" (" ++ optMain opts ++ ")"
]
where
formCalls = map (\f -> "(\"" ++ f ++ "\", HTML.CGI.Exec.showFormAction " ++
formCalls = map (\f -> "(\"" ++ f ++ "\", HTML.CGI.Exec.execFormDef " ++
f ++ ")")
(map showQName (optForms opts))
......@@ -110,19 +131,24 @@ genMainProg opts mname mainmod maincall = unlines $
-- Option processing for the script.
data Options = Options
{ optVerb :: Int -- verbosity (0: quiet, 1: status, 2: interm, 3: all)
, optHelp :: Bool -- if help info should be printed
, optOutput :: String -- name of the cgi program file (with suffix .cgi)
, optMain :: String -- the main expression
, optForms :: [QName] -- qualified names of form operations
, optFormMods:: [String] -- names of modules containing form operations
, optSystem :: String -- path to root of Curry system
, optCPM :: String -- command to invoke Curry Package Manager
, optLimit :: String -- ulimit settings for the cgi program
{ optVerb :: Int -- verbosity (0: quiet, 1: status, 2: interm, 3: all)
, optHelp :: Bool -- if help info should be printed
, optOutput :: String -- name of the cgi program file (with suffix .cgi)
, optMain :: String -- the main expression
, optForms :: [QName] -- qualified names of form operations
, optFormMods :: [String] -- names of modules containing form operations
, optSystem :: String -- path to root of Curry system
, optCPM :: String -- command to invoke Curry Package Manager
, optCurryRC :: [String] -- curryrc options
, optCurryOpts :: [String] -- options passed to the Curry compiler
, optLimit :: String -- ulimit settings for the cgi program
}
defaultOptions :: Options
defaultOptions = Options 1 False "" "" [] [] installDir "cypm exec" "-t 120"
defaultOptions =
Options 1 False "" "" [] [] installDir "cypm exec"
[] [":set -time", ":set -interactive"]
"-t 120"
--- Process the actual command line argument and return the options
--- and the name of the main program.
......@@ -158,7 +184,7 @@ options =
"print help and exit"
, Option "v" ["verb"]
(OptArg (maybe (checkVerb 2) (safeReadNat checkVerb)) "<n>")
"verbosity level:\n0: quiet (same as `-q')\n1: show status messages (default)\n2: show intermediate results (same as `-v')\n3: show all details (e.g., SMT scripts)"
"verbosity level:\n0: quiet (same as `-q')\n1: show status messages (default)\n2: show intermediate results (same as `-v')\n3: show all details"
, Option "m" ["main"]
(ReqArg (\s opts -> opts { optMain = s }) "<m>")
("Curry expression (of type IO HtmlPage) computing\n" ++
......@@ -177,9 +203,13 @@ options =
("set path to the root of Curry system\n" ++
"(then 'path/bin/curry' is invoked to compile script)")
, Option "" ["cpmexec"]
(ReqArg (\s opts -> opts { optSystem = s }) "<c>")
(ReqArg (\s opts -> opts { optCPM = s }) "<c>")
("set the command to execute programs with the\n" ++
"Curry Package Manager (default: 'cypm exec')")
, Option "D" []
(ReqArg (\s opts -> opts { optCurryRC = optCurryRC opts ++ [s] })
"name=val")
"define (curry)rc property 'name' as 'val'"
, Option "u" ["ulimit"]
(ReqArg (\s opts -> opts { optLimit = s }) "<l>")
("set 'ulimit <l>' when executing the cgi program\n" ++
......@@ -196,4 +226,10 @@ options =
then opts { optVerb = n }
else error "Illegal verbosity level (try `-h' for help)"
putStrLnIfNQ :: Options -> String -> IO ()
putStrLnIfNQ opts s = unless (optVerb opts == 0) $ putStrLn s
line :: String
line = take 78 (repeat '-')
-------------------------------------------------------------------------
......@@ -2,59 +2,76 @@
--- Compute infos about all `HtmlFormDef` operations occurring in a module.
---
--- @author Michael Hanus
--- @version September 2019
--- @version October 2019
------------------------------------------------------------------------------
module ExtractForms ( extractFormsInProg )
module ExtractForms ( extractFormsInProg, showQName )
where
import FilePath ( (</>) )
import List ( intercalate )
import List ( intercalate, partition )
import System ( exitWith, getArgs, getPID, system )
import FlatCurry.Files
import FlatCurry.Goodies
import FlatCurry.Types
import AbstractCurry.Files
import AbstractCurry.Select
import AbstractCurry.Types
import HTML.Base
import System.CurryPath ( stripCurrySuffix )
extractFormsInProg :: String -> String -> IO [QName]
extractFormsInProg curryroot mname = do
putStrLn $ "Extracting and checking forms contained in module '" ++
mname ++ "'..."
intcurry <- readFlatCurryInt mname
let formnames = extractFormOps intcurry
putStrLn $ "Form operations found: " ++ unwords (map snd formnames)
checkFormIDsInProg curryroot mname formnames
--- Extract and check all forms defined in a Curry module (their argument).
--- Returns the qualified names of the exported forms.
extractFormsInProg :: Int -> String -> String -> IO [QName]
extractFormsInProg verb curryroot mname = do
unless (verb==0) $ putStrLn $
"Extracting and checking forms contained in module '" ++ mname ++ "'..."
when (verb>1) $ putStr $ "Reading module '" ++ mname ++ "'..."
cprog <- readCurry mname
when (verb>1) $ putStrLn "done!"
let (formnames,privatenames) = extractFormOps cprog
unless (null privatenames) $ putStrLn $
"WARNING: Private form operations found (and not translated):\n" ++
unwords (map snd privatenames)
unless (verb==0) $ putStrLn $
"Form operations found: " ++ unwords (map snd formnames)
unless (null formnames) $ checkFormIDsInProg verb curryroot mname formnames
return formnames
extractFormOps :: Prog -> [QName]
extractFormOps prog = map funcName (filter isPublicFormDef (progFuncs prog))
--- Extract public and private form definitions from a program.
extractFormOps :: CurryProg -> ([QName], [QName])
extractFormOps prog =
let (fds1,fds2) = partition (\fd -> funcVis fd == Public)
(filter hasFormDefType (functions prog))
in (map funcName fds1, map funcName fds2)
where
isPublicFormDef fdecl =
funcVisibility fdecl == Public &&
isFormDefType (funcType fdecl)
isFormDefType t = case t of
TCons tc _ -> tc == ("HTML.Base","HtmlFormDef")
_ -> False
hasFormDefType fdecl = case resultType (typeOfQualType (funcType fdecl)) of
CTApply (CTCons tc) _ -> tc == ("HTML.Base","HtmlFormDef")
_ -> False
-- Test whether all `HtmlFormDef` identifiers in a module are correct,
-- i.e., are identical to the string representation of their defining
-- operations.
checkFormIDsInProg :: String -> String -> [QName] -> IO ()
checkFormIDsInProg curryroot mname formnames = do
checkFormIDsInProg :: Int -> String -> String -> [QName] -> IO ()
checkFormIDsInProg verb curryroot mname formnames = do
pid <- getPID
let testprogname = "TESTFORMPROG_" ++ show pid
writeFile (testprogname ++ ".curry") $ unlines
[ "import " ++ mname
, "import HTML.Base"
, "import CheckFormIDs"
, "main :: IO ()"
, "main = sequence_ [" ++
intercalate "," (map genFormCall formnames) ++ "]"
]
when (verb>1) $ putStrLn $
"Generating check program '" ++ testprogname ++ "':"
let testprog = unlines
[ "import " ++ mname
, "import HTML.Base"
, "import System ( exitWith )"
, ""
, checkFormIDDefinition
, ""
, "main :: IO ()"
, "main = sequence_ [" ++
intercalate "," (map genFormCall formnames) ++ "]"
]
writeFile (testprogname ++ ".curry") testprog
when (verb>2) $ putStrLn testprog
when (verb>1) $ putStrLn $
"Executing check program '" ++ testprogname ++ "'..."
c <- system $ unwords
[curryroot </> "bin" </> "curry",":set v0", ":load", testprogname,
":eval", "main", ":quit"]
......@@ -68,3 +85,30 @@ checkFormIDsInProg curryroot mname formnames = do
genFormCall qn =
let s = showQName qn
in "checkFormID (" ++ s ++ ",\"" ++ s ++ "\")"
showQName :: QName -> String
showQName (mn,fn) = mn ++ "." ++ fn
checkFormIDDefinition :: String
checkFormIDDefinition = unlines
["checkFormID :: (HtmlFormDef a, String) -> IO ()"
,"checkFormID (fd, s) = unless (formDefId fd == s)"
," (putStrLn (\"ERROR: form operation '\" ++ s ++ \"' has non-matching ID!\") >>"
," exitWith 1)"
]
{-
------------------------------------------------------------------------------
--- Auxiliary definitions used by the form checker.
------------------------------------------------------------------------------
import System ( exitWith )
import HTML.Base
checkFormID :: (HtmlFormDef a, String) -> IO ()
checkFormID (fd, s) =
unless (formDefId fd == s) $ do
putStrLn $ "ERROR: form operation '" ++ s ++ "' has non-matching ID!"
exitWith 1
-}
This diff is collapsed.
......@@ -5,14 +5,14 @@
--- to compile Curry CGI scripts into executables.
---
--- @author Michael Hanus
--- @version September 2019
--- @version October 2019
------------------------------------------------------------------------------
module HTML.CGI.Exec ( showFormPageAction, showFormAction )
module HTML.CGI.Exec ( printMainPage, execFormDef )
where
import IO ( hPutStrLn, stderr )
import List ( intercalate )
import List ( intercalate, split )
import ReadNumeric ( readHex, readNat )
import System ( getEnviron )
import Time ( calendarTimeToString, getLocalTime )
......@@ -21,37 +21,44 @@ import HTML.Base
------------------------------------------------------------------------------
--- Shows the HTML page generated from the parameter action
--- Shows the HTML page generated from the second parameter
--- as a string on stdout.
--- The forms possibly contained in the HTML page are passed as parameters,
--- where the elements are usually `(formid, showFormAction formdef)`.
--- This operation is used by the script to compile web scripts
--- where the elements are usually of the form
--- `(formid, execFormDef formdef)`.
--- This operation is used by the script `curry2gi` to compile web scripts
--- into executables.
showFormPageAction :: [(String, [(String,String)] -> IO ())] -> IO HtmlPage
-> IO ()
showFormPageAction formmap genpage = catchFormErrors $ do
printMainPage :: [(String, [(String,String)] -> IO ())] -> IO HtmlPage -> IO ()
printMainPage formmap genpage = catchFormErrors $ do
cgivars <- getFormVariables
maybe (genpage >>= showPage)
(\formid -> maybe (showPage (formNotCompiledPage formid))
maybe (genpage >>= execPage >>= printPage)
(\formid -> maybe (printPage (formNotCompiledPage formid))
(\f -> f cgivars)
(lookup formid formmap))
(lookup "FORMID" cgivars)
--- Processes a submitted HTML form by reading the data and
--- construct the initial form to find the corresponding event handler.
--- The list of CGI variables/values if passed as the second argument.
showFormAction :: HtmlFormDef a -> [(String,String)] -> IO ()
showFormAction (HtmlFormDef _ readact formgen) cgivars = catchFormErrors $ do
--- Translates a form definition into an operation which takes
--- CGI variables and their values and produces the HTML text on
--- standard output.
--- The generated operation processes reads the required data (by executing
--- the read action of the form definition) and
--- constructs the initial form to find the corresponding event handler
--- contained in this form.
--- The list of CGI variables/values is passed as the second argument.
execFormDef :: HtmlFormDef a -> [(String,String)] -> IO ()
execFormDef (HtmlFormDef _ readact formgen) cgivars = catchFormErrors $ do
val <- readact
let (iform,_) = instCgiRefs (formgen val) 0
hexps <- mapM execHtml (formgen val)
let (iform,_) = instCgiRefs hexps 0
let cenv = cgiGetValue cgivars
p <- maybe (return noHandlerPage) (\h -> h cenv) (findHandler cenv iform)
showPage p
execPage p >>= printPage
-- for debugging:
--let fenv = unlines $ map (\ (x,y) -> x ++ "=" ++ y) cgivars
--putStrLn ("Content-type: text/plain\n\n" ++ fenv)
--- Catches run-time errors, print them on stderr and also
--- in a specific webpages.
--- in a specific web page.
catchFormErrors :: IO () -> IO ()
catchFormErrors formact = catch formact showFormError
where
......@@ -59,14 +66,17 @@ catchFormErrors formact = catch formact showFormError
let errstr = showError err
cdate <- getLocalTime >>= return . calendarTimeToString
hPutStrLn stderr $ cdate ++ ": " ++ errstr
showPage $ page "Run-time exception"
printPage $ page "Run-time exception"
[h1 [htxt "Run-time exception occurred"],
par [htxt "An error occurred during the execution of the web script."],
par [htxt $ "Error message: " ++ errstr]]
--- Shows a HTML page on stdout.
showPage :: HtmlPage -> IO ()
showPage p = do
printPage :: HtmlPage -> IO ()
printPage (HtmlAnswer ctype cont) = do
putStrLn $ "Content-Length: " ++ show (length cont) ++
"\nContent-Type: " ++ ctype ++ "\n\n" ++ cont
printPage p@(HtmlPage _ _ _) = do
let (cookiestring,hpage) = extractCookies p
putStrLn $ cookiestring ++
"Content-type: text/html\n\n" ++ showHtmlPage hpage
......@@ -74,6 +84,7 @@ showPage p = do
-- Extract the cookies contained in a HTML page and return the
-- "set cookie" string and the HTML page without the cookies:
extractCookies :: HtmlPage -> (String,HtmlPage)
extractCookies (HtmlAnswer ctype cont) = ("", HtmlAnswer ctype cont)
extractCookies (HtmlPage title params hexp) =