Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry-packages
spicey
Commits
7fd88476
Commit
7fd88476
authored
Oct 20, 2019
by
Michael Hanus
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Controller generation refactored
parent
38f5c32d
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
143 additions
and
91 deletions
+143
-91
resource_files/Spicey.curry
resource_files/Spicey.curry
+31
-19
src/Spicey/ControllerGeneration.curry
src/Spicey/ControllerGeneration.curry
+106
-71
src/Spicey/GenerationHelper.curry
src/Spicey/GenerationHelper.curry
+5
-0
src/Spicey/SpiceUp.curry
src/Spicey/SpiceUp.curry
+1
-1
No files found.
resource_files/Spicey.curry
View file @
7fd88476
...
...
@@ -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 _ _ = display
Url
Error
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
...
...
src/Spicey/ControllerGeneration.curry
View file @
7fd88476
...
...
@@ -23,51 +23,75 @@ generateControllersForEntity :: String -> [Entity] -> Entity
-> [Relationship]
-> CurryProg
generateControllersForEntity erdname allEntities
(Entity ename
attrlist
) relationships =
simple
CurryProg
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
(E
ntity
ename attrlist)
relationships allEntities,
mainController erdname
e
ntity relationships allEntities,
-- controller for providing a page to enter new entity data:
newController erdname
(E
ntity
ename attrlist)
relationships allEntities,
newController erdname
e
ntity 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
(E
ntity
ename attrlist)
relationships allEntities,
editController erdname
e
ntity 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
(E
ntity
ename attrlist)
relationships allEntities,
listController erdname
e
ntity relationships allEntities,
-- controller to show entites:
showController erdname
(E
ntity
ename attrlist)
relationships allEntities
showController erdname
e
ntity 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
...
...
src/Spicey/GenerationHelper.curry
View file @
7fd88476
...
...
@@ -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
...
...
src/Spicey/SpiceUp.curry
View file @
7fd88476
...
...
@@ -16,7 +16,7 @@ import Spicey.Scaffolding
systemBanner :: String
systemBanner =
let bannerText = "Spicey Web Framework (Version " ++ packageVersion ++
" of 2
5
/1
1
/1
8
)"
" of 2
0
/1
0
/1
9
)"
bannerLine = take (length bannerText) (repeat '-')
in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment