Commit 7fd88476 authored by Michael Hanus 's avatar Michael Hanus

Controller generation refactored

parent 38f5c32d
......@@ -7,12 +7,13 @@ module System.Spicey (
module System,
module HTML.Base,
module ReadNumeric,
Controller, applyControllerOn,
nextController, nextControllerForData, confirmNextController,
confirmController, transactionController,
Controller, EntityController(..), applyControllerOn,
nextController, nextControllerForData,
confirmDeletionPage,
transactionController,
getControllerURL,getControllerParams, showControllerURL,
getForm, wDateType, wBoolean, wUncheckMaybe, wFloat,
displayError, cancelOperation,
displayError, displayUrlError, cancelOperation,
renderWuiForm, renderLabels,
nextInProcessOr,
stringToHtml, maybeStringToHtml,
......@@ -58,10 +59,16 @@ type ViewBlock = [HtmlExp]
--- Spicey.getControllerParams inside the controller.
type Controller = IO ViewBlock
--- The type class `EntityController` provides the application
--- of a controller to some entity identified by a key string.
class EntityController a where
controllerOnKey :: String -> (a -> Controller) -> Controller
--- Reads an entity for a given key and applies a controller to it.
applyControllerOn :: Maybe enkey -> (enkey -> IO en)
-> (en -> Controller) -> Controller
applyControllerOn Nothing _ _ = displayError "Illegal URL"
applyControllerOn Nothing _ _ = displayUrlError
applyControllerOn (Just userkey) getuser usercontroller =
getuser userkey >>= usercontroller
......@@ -76,23 +83,24 @@ nextControllerForData controller param = do
view <- controller param
getForm view
--- Call the next controller after a user confirmation.
--- The Boolean user answer is passed as an argument to the controller.
confirmNextController :: HtmlExp -> (Bool -> Controller) -> _ -> IO HtmlForm
confirmNextController question controller _ = do
getForm [question,
defaultButton "Yes" (nextController (controller True)),
defaultButton "No" (nextController (controller False))]
--- Ask the user for a confirmation and call the corresponding controller.
--- Generates a page to ask the user for a confirmation to delete an entity
--- specified in the controller URL (of the form "entity/delete/key/...").
--- The yes/no answers are references derived from the controller URL
--- where the second argument is replaced by "destroy"/"show".
--- @param question - a question asked
--- @param yescontroller - the controller used if the answer is "yes"
--- @param nocontroller - the controller used if the answer is "no"
confirmController :: [HtmlExp] -> Controller -> Controller -> Controller
confirmController question yescontroller nocontroller = do
return $ question ++
[par [defaultButton "Yes" (nextController yescontroller),
defaultButton "No" (nextController nocontroller )]]
confirmDeletionPage :: UserSessionInfo -> String -> Controller
confirmDeletionPage _ question = do
(entity,ctrlargs) <- getControllerURL
case ctrlargs of
(_:args) -> return $
[h3 [htxt question],
par [hrefButton (showControllerURL entity ("destroy":args)) [htxt "Yes"],
nbsp,
hrefButton (showControllerURL entity ("show" : args)) [htxt "No"]]]
_ -> displayUrlError
--- A controller to execute a transaction and proceed with a given
--- controller if the transaction succeeds. Otherwise, the
......@@ -301,6 +309,10 @@ displayError msg = do
then return [htxt "General error (shown by function Spicey.displayError)"]
else return [htxt msg]
--- A controller to display an URL error.
displayUrlError :: Controller
displayUrlError = displayError "Illegal URL"
-- like renderTaggedTuple from WUI Library but takes list of HtmlExp
-- instead of list of strings
renderLabels :: [[HtmlExp]] -> Rendering
......
......@@ -23,51 +23,75 @@ generateControllersForEntity :: String -> [Entity] -> Entity
-> [Relationship]
-> CurryProg
generateControllersForEntity erdname allEntities
(Entity ename attrlist) relationships =
simpleCurryProg
entity@(Entity ename _) relationships =
CurryProg
(controllerModuleName ename)
-- imports:
[ spiceyModule, "HTML.Base", "Time"
, erdname, viewModuleName ename
, "Maybe", sessionInfoModule, authorizationModule, enauthModName
, "Config.UserProcesses",
entitiesToHtmlModule erdname]
[] -- typedecls
[ "Maybe", "Time", "HTML.Base"
, erdname
, "Config.UserProcesses"
, sessionInfoModule, authorizationModule, enauthModName, spiceyModule
, entitiesToHtmlModule erdname
, viewModuleName ename
]
Nothing -- defaultdecl
[] -- classdecls
[controllerInstDecl erdname entity] -- instdecls
[newEntityType erdname entity relationships allEntities] -- typedecls
-- functions
(
[
-- controller for dispatching to various controllers:
mainController erdname (Entity ename attrlist) relationships allEntities,
mainController erdname entity relationships allEntities,
-- controller for providing a page to enter new entity data:
newController erdname (Entity ename attrlist) relationships allEntities,
newController erdname entity relationships allEntities,
-- transaction for saving data in new entity:
createTransaction erdname (Entity ename attrlist)
relationships allEntities,
createTransaction erdname entity relationships allEntities,
-- controller to show an existing record in a form to edit
editController erdname (Entity ename attrlist) relationships allEntities,
editController erdname entity relationships allEntities,
-- transaction to update a record with the given data
updateTransaction erdname (Entity ename attrlist)
relationships allEntities,
updateTransaction erdname entity relationships allEntities,
-- controller to delete an entity with the given data
deleteController erdname (Entity ename attrlist)
relationships allEntities,
deleteController erdname entity relationships allEntities,
-- controller to destroy an entity with the given data
destroyController erdname entity relationships allEntities,
-- transaction to delete an entity with the given data
deleteTransaction erdname (Entity ename attrlist)
relationships allEntities,
deleteTransaction erdname entity relationships allEntities,
-- controller to list all entities:
listController erdname (Entity ename attrlist) relationships allEntities,
listController erdname entity relationships allEntities,
-- controller to show entites:
showController erdname (Entity ename attrlist) relationships allEntities
showController erdname entity relationships allEntities
] ++
(manyToManyAddOrRemove erdname (Entity ename attrlist) (manyToMany allEntities (Entity ename attrlist)) allEntities) ++
--(getAll erdname (Entity ename attrlist) (manyToOne (Entity ename attrlist) relationships) allEntities) ++
--(getAll erdname (Entity ename attrlist) (manyToMany allEntities (Entity ename attrlist)) allEntities) ++
--(manyToManyGetRelated erdname (Entity ename attrlist) (manyToMany allEntities (Entity ename attrlist)) allEntities) ++
(manyToOneGetRelated erdname (Entity ename attrlist) (manyToOne (Entity ename attrlist) relationships) allEntities relationships)
manyToManyAddOrRemove erdname entity (manyToMany allEntities entity)
allEntities ++
--(getAll erdname entity (manyToOne entity relationships) allEntities) ++
--(getAll erdname entity (manyToMany allEntities entity) allEntities) ++
--(manyToManyGetRelated erdname entity (manyToMany allEntities entity) allEntities) ++
manyToOneGetRelated erdname entity (manyToOne entity relationships)
allEntities relationships
)
[] -- opdecls
-- Generates the instance declaration for a controller.
controllerInstDecl :: String -> Entity -> CInstanceDecl
controllerInstDecl erdname (Entity entityName _) =
CInstance (spiceyModule,"EntityController")
(CContext [])
(baseType (erdname, entityName))
[cfunc (spiceyModule,"controllerOnKey") 1 Private
(CQualType (CContext [((spiceyModule,"EntityController"),tvara)])
(stringType ~> (tvara ~> controllerType) ~> controllerType))
[simpleRule [CPVar (2,"s")]
(applyF (spiceyModule,"applyControllerOn")
[readKey, getEntityOp])]]
where
tvara = CTVar (0,"a")
readKey = applyF (erdname, "read" ++ entityName ++ "Key") [CVar (2,"s")]
getEntityOp = applyF (pre ".")
[constF (erdname, "runJustT"),
constF (erdname, "get" ++ entityName)]
-- erdname: name of the entity-relationship-specification
-- entity: the entity to generate a controller for
type ControllerGenerator = String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
......@@ -75,7 +99,7 @@ type ControllerGenerator = String -> Entity -> [Relationship] -> [Entity] -> CFu
-- Generates the main controller that dispatches to the various
-- subcontrollers according to the URL parameters.
mainController :: ControllerGenerator
mainController erdname (Entity entityName _) _ _ =
mainController _ (Entity entityName _) _ _ =
controllerFunction
("Choose the controller for a "++entityName++
" entity according to the URL parameter.")
......@@ -92,33 +116,32 @@ mainController erdname (Entity entityName _) _ _ =
cBranch (listPattern [stringPattern "list"])
(constF (controllerFunctionName entityName "list")),
cBranch (listPattern [stringPattern "new"])
(constF (controllerFunctionName entityName "new")),
cBranch (listPattern [stringPattern "show", CPVar (2,"s")])
(applyF (spiceyModule,"applyControllerOn")
[readKey,
getEntityOp,
constF (controllerFunctionName entityName "show")]),
cBranch (listPattern [stringPattern "edit", CPVar (2,"s")])
(applyF (spiceyModule,"applyControllerOn")
[readKey,
getEntityOp,
constF (controllerFunctionName entityName "edit")]),
cBranch (listPattern [stringPattern "delete", CPVar (2,"s")])
(applyF (spiceyModule,"applyControllerOn")
[readKey,
getEntityOp,
constF (controllerFunctionName entityName "delete")]),
cBranch (CPVar (3,"_"))
(applyF (spiceyModule, "displayError")
[string2ac "Illegal URL"])])
(constF (controllerFunctionName entityName "new"))] ++
map applyControllerBranch ["show", "edit", "delete", "destroy"] ++
[cBranch (CPVar (3,"_"))
(constF (spiceyModule, "displayUrlError"))])
)
]
)]
where
readKey = applyF (erdname,"read"++entityName++"Key") [CVar (2,"s")]
getEntityOp = applyF (pre ".")
[constF (erdname,"runJustT"),
constF (erdname,"get"++entityName)]
applyControllerBranch n = let svar = (2,"s") in
cBranch (listPattern [stringPattern n, CPVar svar])
(applyF (spiceyModule,"controllerOnKey")
[CVar svar, constF (controllerFunctionName entityName n)])
--- Generates a type alias for a "new entity" tuple type which is
--- used to create and insert new entities (without an entity key).
newEntityType :: String -> Entity -> [Relationship] -> [Entity] -> CTypeDecl
newEntityType erdname (Entity entityName attrList) relationships allEntities =
let notGeneratedAttributes = filter (\attr -> not (isForeignKey attr)
&& notPKey attr)
attrList
manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
manyToOneEntities = manyToOne (Entity entityName attrList) relationships
in CTypeSyn (newEntityTypeName entityName) Private []
(tupleType (map attrType notGeneratedAttributes ++
map ctvar manyToOneEntities ++
map (listType . ctvar) manyToManyEntities))
-- generates a controller to show a form to create a new entity
-- the input is then passed to the create controller
......@@ -197,10 +220,8 @@ createTransaction erdname (Entity entityName attrList) relationships allEntities
("Transaction to persist a new "++entityName++" entity to the database.")
(transFunctionName entityName "create")
1 Private
(tupleType (map attrType notGeneratedAttributes ++
map ctvar manyToOneEntities ++
map (listType . ctvar) manyToManyEntities)
~> applyTC (dbconn "DBAction") [baseType (pre "()")])
(baseType (newEntityTypeName entityName)
~> applyTC (dbconn "DBAction") [unitType])
[simpleRule
[tuplePattern
(map (\ (param, varId) -> CPVar (varId, param))
......@@ -365,38 +386,52 @@ updateTransaction erdname (Entity entityName attrList) _ allEntities =
--- Generates controller to delete an entity after confirmation.
deleteController :: ControllerGenerator
deleteController erdname (Entity entityName _) _ _ =
let entlc = lowerFirst entityName -- entity name in lowercase
entvar = (0, entlc) -- entity parameter for controller
let entlc = lowerFirst entityName -- entity name in lowercase
entvar = (0, entlc) -- entity parameter for controller
sinfovar = (1, "sinfo") -- "sinfo" parameter
in
controllerFunction
("Deletes a given "++entityName++" entity (after asking for confirmation)\n"++
"and proceeds with the list controller.")
entityName "delete" 1
(baseType (erdname, entityName) ~> controllerType)
[simpleRule [CPVar entvar]
(applyF (pre "$")
[applyF checkAuthorizationFunc
[applyF (enauthModName,entlc++"OperationAllowed")
[applyF (authorizationModule,"DeleteEntity") [CVar entvar]]],
CLambda [CPVar sinfovar] $
applyF (spiceyModule,"confirmDeletionPage")
[CVar sinfovar,
applyF (pre "concat")
[list2ac [string2ac "Really delete entity \"",
applyF (entitiesToHtmlModule erdname,
entlc ++ "ToShortView")
[CVar entvar],
string2ac "\"?"]]]])]
--- Generates controller to delete an entity.
destroyController :: ControllerGenerator
destroyController erdname (Entity entityName _) _ _ =
let entlc = lowerFirst entityName -- entity name in lowercase
entvar = (0, entlc) -- entity parameter for controller
in
controllerFunction
("Deletes a given " ++ entityName ++ " entity\n" ++
"and proceeds with the list controller.")
entityName "destroy" 1
(baseType (erdname, entityName) ~> controllerType)
[simpleRule [CPVar entvar]
(applyF (pre "$")
[applyF checkAuthorizationFunc
[applyF (enauthModName,entlc++"OperationAllowed")
[applyF (authorizationModule,"DeleteEntity") [CVar entvar]]],
CLambda [CPVar (0,"_")] $
applyF (spiceyModule,"confirmController")
[list2ac
[applyF (html "h3")
[list2ac
[applyF (html "htxt")
[applyF (pre "concat")
[list2ac [string2ac "Really delete entity \"",
applyF (entitiesToHtmlModule erdname,
entlc++"ToShortView")
[CVar entvar],
string2ac "\"?"]]]]]],
applyF (spiceyModule,"transactionController")
applyF (spiceyModule,"transactionController")
[applyF (erdname,"runT")
[applyF (transFunctionName entityName "delete")
[CVar entvar]],
constF (controllerFunctionName entityName "list")],
applyF (controllerFunctionName entityName "show")
[CVar entvar]]])]
constF (controllerFunctionName entityName "list")]])]
--- Generates a transaction to delete an entity.
deleteTransaction :: ControllerGenerator
......
......@@ -147,6 +147,11 @@ controllerType = baseType (spiceyModule,"Controller")
controllerModuleName :: String -> String
controllerModuleName entityName = "Controller." ++ entityName
--- The name of the type synonym for a "new entity" tuple.
newEntityTypeName :: String -> QName
newEntityTypeName entityName =
(controllerModuleName entityName, "New" ++ entityName)
--- The name of the controller function for a given entity and controller
--- functionality.
controllerFunctionName :: String -> String -> QName
......
......@@ -16,7 +16,7 @@ import Spicey.Scaffolding
systemBanner :: String
systemBanner =
let bannerText = "Spicey Web Framework (Version " ++ packageVersion ++
" of 25/11/18)"
" of 20/10/19)"
bannerLine = take (length bannerText) (repeat '-')
in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment