ControllerGeneration.curry 41.7 KB
Newer Older
Michael Hanus 's avatar
Michael Hanus committed
1 2
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}

3 4
module Spicey.ControllerGeneration where

5 6
import Char(toLower)

7 8
import AbstractCurry.Types
import AbstractCurry.Build
9 10
import Database.ERD
import Database.ERD.Goodies
11 12 13 14

import Spicey.GenerationHelper

-- Name of entity-specific authorization module:
Michael Hanus 's avatar
Michael Hanus committed
15
enauthModName :: String
16
enauthModName = "System.AuthorizedActions"
Michael Hanus 's avatar
Michael Hanus committed
17

18
-- Name of module defining the default controller:
Michael Hanus 's avatar
Michael Hanus committed
19
defCtrlModName :: String
20
defCtrlModName = "Controller.DefaultController"
21 22 23 24 25 26

-- "main"-function
generateControllersForEntity :: String -> [Entity] -> Entity
                             -> [Relationship]
                             -> CurryProg
generateControllersForEntity erdname allEntities
27 28 29 30 31 32 33 34 35
                             entity@(Entity ename attrlist) relationships =
 let noKeyAttrs = filter (\a -> notKey a && notPKey a) attrlist
 in
  CurryProg
   (controllerModuleName ename)
   -- imports:
   [ "Global", "Maybe", "Time"
   , "HTML.Base", "HTML.Session", "HTML.WUI"
   , erdname
36
   , "Config.EntityRoutes", "Config.Storage" , "Config.UserProcesses"
37 38 39 40 41 42
   , sessionInfoModule, authorizationModule, enauthModName, spiceyModule
   , entitiesToHtmlModule erdname
   , viewModuleName ename
   ]
   Nothing -- defaultdecl
   [] -- classdecls
43
   [] -- instdecls
44 45 46
   [newEntityType erdname entity relationships allEntities] -- typedecls
   -- functions
   (
47 48
    [
     -- controller for dispatching to various controllers:
49
     mainController erdname entity relationships allEntities,
50
     -- controller for providing a page to enter new entity data:
51 52 53 54
     --newController erdname entity relationships allEntities,
     newController erdname (Entity ename noKeyAttrs) relationships allEntities,
     newForm  erdname (Entity ename noKeyAttrs) relationships allEntities,
     newStore erdname (Entity ename noKeyAttrs) relationships allEntities,
55
     -- transaction for saving data in new entity:
56
     createTransaction erdname entity relationships allEntities,
57
     -- controller to show an existing record in a form to edit
58
     editController erdname entity relationships allEntities,
59 60
     editForm  erdname (Entity ename noKeyAttrs) relationships allEntities,
     editStore erdname (Entity ename noKeyAttrs) relationships allEntities,
61
     -- transaction to update a record with the given data
62
     updateTransaction erdname entity relationships allEntities,
63
     -- controller to delete an entity with the given data
64 65 66
     deleteController erdname entity relationships allEntities,
     -- controller to destroy an entity with the given data
     destroyController erdname entity relationships allEntities,
67
     -- transaction to delete an entity with the given data
68
     deleteTransaction erdname entity relationships allEntities,
69
     -- controller to list all entities:
70
     listController erdname entity relationships allEntities,
71
     -- controller to show entites:
72
     showController erdname entity relationships allEntities
73 74 75
    ] ++ 
    manyToManyAddOrRemove erdname entity (manyToMany allEntities entity)
                          allEntities ++
76 77 78
    --(getAll erdname entity (manyToOne entity relationships) allEntities) ++
    --(getAll erdname entity (manyToMany allEntities entity) allEntities) ++
    --(manyToManyGetRelated erdname entity (manyToMany allEntities entity) allEntities) ++
79 80 81 82
     manyToOneGetRelated erdname entity (manyToOne entity relationships)
                         allEntities relationships
   )
   [] -- opdecls
83 84 85 86


-- erdname: name of the entity-relationship-specification
-- entity: the entity to generate a controller for
87 88
type ControllerGenerator = String -> Entity -> [Relationship] -> [Entity]
                        -> CFuncDecl
89 90 91 92

-- Generates the main controller that dispatches to the various
-- subcontrollers according to the URL parameters.
mainController :: ControllerGenerator
93
mainController _ (Entity entityName _) _ _ =
94 95 96 97 98 99 100 101
  controllerFunction 
  ("Choose the controller for a "++entityName++
   " entity according to the URL parameter.")
  entityName "main" 0
    controllerType -- function type
    [simpleRule [] -- no arguments
      (CDoExpr
         [CSPat (CPVar (1,"args"))
102
                (constF (spiceyModule,"getControllerParams")),
103 104 105 106 107 108 109
          CSExpr
           (CCase CRigid (CVar (1,"args"))
            ([cBranch (listPattern [])
                      (constF (controllerFunctionName entityName "list")),
              cBranch (listPattern [stringPattern "list"])
                      (constF (controllerFunctionName entityName "list")),
              cBranch (listPattern [stringPattern "new"])
110 111 112 113
                      (constF (controllerFunctionName entityName "new"))] ++
              map applyControllerBranch ["show", "edit", "delete", "destroy"] ++
             [cBranch (CPVar (3,"_"))
                      (constF (spiceyModule, "displayUrlError"))])
114 115 116
          )
         ]
      )]
117
 where
118 119 120 121 122 123 124 125
  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
126
newEntityType _ (Entity entityName attrList) relationships allEntities =
127 128 129 130 131 132 133 134 135
  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))
136

137
------------------------------------------------------------------------------
138 139 140 141 142
-- generates a controller to show a form to create a new entity
-- the input is then passed to the create controller
-- only has to call the blank entry form and pass the create controller
newController :: ControllerGenerator
newController erdname (Entity entityName attrList) relationships allEntities =
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211
  controllerFunction 
  ("Shows a form to create a new " ++ entityName ++ " entity.")
  entityName "new" 0
  controllerType -- function type
  [simpleRule [] $ -- no arguments
     applyF (pre "$")
       [applyF checkAuthorizationFunc
         [applyF (enauthModName, lowerFirst entityName ++ "OperationAllowed")
           [constF (authorizationModule,"NewEntity")]],
        CLambda [CPVar infovar] $
         CDoExpr (
         (map 
           (\ (ename, num) ->
              CSPat (CPVar (num,"all" ++ ename ++ "s")) 
                    (applyF (erdname,"runQ")
                            [constF (erdname,"queryAll" ++ ename ++ "s")])
           )
           (zip (manyToOneEntities ++ manyToManyEntities) [2..])
         ) ++
         (if withCTime
          then [CSPat (CPVar ctimevar)
                      (constF ("Time","getClockTime"))]
          else []) ++
         [CSExpr setParCall,         
          CSExpr $ applyF (pre "return")
            [list2ac [applyF (html "formExp")
                        [constF (controllerFormName entityName "new")]]]
         ])]]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
  manyToOneEntities  = manyToOne (Entity entityName attrList) relationships
  withCTime          = hasDateAttribute attrList
  infovar            = (0,"sinfo")
  ctimevar           = (1,"ctime")

  setParCall =
    applyF (wuiModule "setParWuiStore")
      [constF (controllerStoreName entityName "new"),
       tupleExpr
        ([CVar infovar] ++ 
         map (\ (ename, num) -> CVar (num, "all" ++ ename ++ "s"))
             (zip (manyToOneEntities ++ manyToManyEntities) [2 ..])),
       tupleExpr $
         attrDefaultValues (CVar (0,"ctime")) attrList ++
         map (\ (name, varId) -> applyF (pre "head")
                                   [CVar (varId,("all" ++ name ++ "s"))])
             (zip manyToOneEntities [2..]) ++
         map (\_ -> list2ac []) (zip manyToManyEntities [2..])
      ]

--- Generates the form definition to create a new entity.
newForm :: String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
newForm erdname entity@(Entity entityName attrlist) relationships allEntities =
  cmtfunc ("A WUI form to create a new " ++ entityName ++ " entity.\n" ++
           "The default values for the fields are stored in '" ++
           snd (controllerStoreName entityName "new") ++ "'.")
    (controllerFormName entityName "new") 0
    Public
    (emptyClassType $ applyTC (htmlModule "HtmlFormDef")
        [newTupleType entity relationships allEntities])
    [simpleRule []
      (applyF (wuiModule "pwui2FormDef")
        [string2ac $ showQName $ controllerFormName entityName "new",
         constF (controllerStoreName entityName "new"),
         wuiFun, storeFun, renderFun])]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
  manyToOneEntities  = manyToOne (Entity entityName attrlist) relationships
  arity1 = 1 + length manyToOneEntities + length manyToManyEntities
212
  listEntityURL = '?' : entityName ++ "/list"
213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236

  wuiFun =
    CLambda
      [tuplePattern
        ([CPVar (1,"_")] ++
         map (\ (name, varId) -> CPVar(varId,("possible"++name++"s")))
             (zip (manyToOneEntities++manyToManyEntities) [2..]))] $
      applyF (viewModuleName entityName, "w" ++ entityName)
        (map (\ (name, varId) -> CVar(varId,("possible"++name++"s")))
             (zip (manyToOneEntities ++ manyToManyEntities) [2..]) )

  storeFun =
    let entvar = (1, "entity")
    in
    CLambda [CPVar (0,"_"), CPVar entvar]
      (applyF checkAuthorizationFunc
         [applyF (enauthModName, lowerFirst entityName ++ "OperationAllowed")
            [constF (authorizationModule,"NewEntity")],
          CLambda [CPVar (0,"_")]
            (applyF (spiceyModule,"transactionController")
               [applyF (erdname,"runT")
                  [applyF (transFunctionName entityName "create")
                           [CVar entvar]],
                applyF (spiceyModule,"nextInProcessOr")
237 238
                  [applyF (spiceyModule,"redirectController")
                          [string2ac listEntityURL],
239 240 241 242 243 244 245 246 247
                   constF (pre "Nothing")]])])

  renderFun =
    CLambda [tuplePattern
               (map CPVar (sinfovar : map (\v -> (v,"_")) [2 .. arity1]))] $
      applyF (spiceyModule,"renderWUI")
        [CVar sinfovar,
         string2ac $ "Create new " ++ entityName,
         string2ac "Create",
248
         string2ac listEntityURL,
249 250 251 252
         constF (pre "()")
        ]
   where sinfovar = (1, "sinfo")

253

254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287
--- Generates the store for WUI to create a new entity.
newStore :: String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
newStore _ entity@(Entity entityName _) relationships allEntities =
  cmtfunc "The data stored for executing the \"new entity\" WUI form."
    (controllerStoreName entityName "new") 0
    Private
    (emptyClassType $ applyTC (globalModule "Global")
      [applyTC (sessionModule "SessionStore")
        [newTupleType entity relationships allEntities]])
    [simpleRule []
      (applyF (globalModule "global")
        [constF (sessionModule "emptySessionStore"),
         applyF (globalModule "Persistent")
          [applyF (storageModule "inDataDir")
            [string2ac $ "new" ++ entityName ++ "Store"]]])]


--- Computes the tuple type of the data to be stored and manipulated
--- by the WUI to create a new entity.
newTupleType :: Entity -> [Relationship] -> [Entity] -> CTypeExpr
newTupleType (Entity entityName attrlist) relationships allEntities =
  tupleType
    [tupleType $
       [userSessionInfoType] ++
       map (\e -> listType (ctvar e))
           (manyToOneEntities ++ manyToManyEntities), -- possible values
     applyTC (wuiModule "WuiStore")
             [baseType (newEntityTypeName entityName)]]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
  manyToOneEntities  = manyToOne (Entity entityName attrlist) relationships


--- Generates a transaction to store a new entity.
288
createTransaction :: ControllerGenerator
289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335
createTransaction erdname (Entity entityName attrList)
                  relationships allEntities = stCmtFunc
  ("Transaction to persist a new " ++ entityName ++ " entity to the database.")
  (transFunctionName entityName "create")
  1 Private
    (baseType (newEntityTypeName entityName)
      ~> applyTC (dbconn "DBAction") [unitType])
    [simpleRule 
      [tuplePattern
        (map (\ (param, varId) -> CPVar (varId, param)) 
             (zip (parameterList ++ map lowerFirst manyToOneEntities ++
                   map (\e -> (lowerFirst e) ++ "s") manyToManyEntities)
                   [1..]))
      ] -- parameter list for controller
      (applyF (dbconn ">+=")
         [applyF (entityConstructorFunction erdname (Entity entityName attrList) relationships) 
                     (map (\ ((Attribute name dom key null), varId) -> 
                        if (isForeignKey (Attribute name dom key null))
                          then applyF (erdname, (lowerFirst (getReferencedEntityName dom))++"Key")
                                      [CVar (varId, lowerFirst (getReferencedEntityName dom))]
                          else let cv = CVar (varId, lowerFirst name)
                                in if hasDefault dom && not (isStringDom dom)
                                      && not null
                                   then applyF (pre "Just") [cv]
                                   else cv)
                        (zip noPKeys [1..])
                      ),
          CLambda [cpvar "newentity"]
           (foldr1 (\a b -> applyF (dbconn ">+") [a,b])
            (map (\name -> applyF (controllerModuleName entityName,
                                   "add"++(linkTableName entityName name allEntities))
                                  [cvar (lowerFirst name ++ "s"),
                                   cvar "newentity"])
                 manyToManyEntities ++
             [applyF (pre "return") [constF (pre "()")]])
           )
         ]
         )]
 where
  noPKeys            = (filter notPKey attrList)
  -- foreignKeys = (filter isForeignKey attrList)
  -- notGeneratedAttributes = filter (\attr -> (not (isForeignKey attr))
  --                                          && (notPKey attr))     attrList
  parameterList      = map (\(Attribute name _ _ _) -> lowerFirst name)
                           (filter (not . isForeignKey) noPKeys)
  manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
  manyToOneEntities  = manyToOne (Entity entityName attrList) relationships
336

337 338
------------------------------------------------------------------------------
--- Generates a controller to edit an entity.
339 340
editController :: ControllerGenerator
editController erdname (Entity entityName attrList) relationships allEntities =
341 342
  controllerFunction
    ("Shows a form to edit the given " ++ entityName ++ " entity.")
343
    entityName "edit" 1
344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426
    (baseType (erdname,entityName) ~> controllerType)
    [simpleRule [CPVar pvar] -- parameterlist for controller
      (applyF (pre "$")
        [applyF checkAuthorizationFunc
          [applyF (enauthModName,lowerFirst entityName++"OperationAllowed")
            [applyF (authorizationModule,"UpdateEntity") [CVar pvar]]],
         CLambda [CPVar infovar] $
           CDoExpr (
            map (\ (ename, num) ->
                    CSPat (CPVar (num,"all"++ename++"s")) 
                          (applyF (erdname,"runQ")
                                  [constF (erdname,"queryAll"++ename++"s")]))
               (zip (manyToOneEntities ++ manyToManyEntities) [1..]) ++
            map 
              (\ (ename, num) -> CSPat (CPVar (num,(lowerFirst (fst $ relationshipName entityName ename relationships))++ename)) 
                              (
                                applyF (erdname,"runJustT") [
                                  applyF (controllerModuleName entityName,"get"++(fst $ relationshipName entityName ename relationships)++ename) [CVar pvar]
                                ]
                              )
              )
              (zip manyToOneEntities [1..]) ++
            map 
              (\ (ename, num) -> CSPat (CPVar (num,(lowerFirst (linkTableName entityName ename allEntities))++ename++"s")) 
                              (
                                applyF (erdname,"runJustT") [
                                  applyF (controllerModuleName entityName,"get"++entityName++ename++"s") [CVar pvar]
                                ]
                              )
              )
              (zip manyToManyEntities [1..]) ++
            [CSExpr setParCall,
             CSExpr $ applyF (pre "return")
               [list2ac [applyF (html "formExp")
                           [constF (controllerFormName entityName "edit")]]]
            ])])]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
  manyToOneEntities  = manyToOne (Entity entityName attrList) relationships
  pvar               = (0, lowerFirst entityName ++ "ToEdit")
  infovar            = (1, "sinfo")

  setParCall =
    applyF (wuiModule "setParWuiStore")
      [constF (controllerStoreName entityName "edit"),
       tupleExpr
        ([CVar infovar, CVar pvar] ++ 
         map (\ (ename, num) ->
               CVar (num,lowerFirst (fst $ relationshipName
                            entityName ename relationships)
                         ++ ename))
             (zip manyToOneEntities [1..]) ++
         map (\ (ename, num) -> CVar (num, "all"++ename++"s"))
             (zip (manyToOneEntities ++ manyToManyEntities)
                  [1..])),
       tupleExpr
        ([CVar pvar] ++ 
          (map (\ (ename, num) ->
                 CVar (num,lowerFirst (linkTableName entityName
                                       ename allEntities)
                        ++ename++"s"))
               (zip manyToManyEntities [1..])))]


--- Generates the form definition to edit an entity.
editForm :: String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
editForm erdname entity@(Entity entityName attrlist) relationships allEntities =
  cmtfunc ("A WUI form to edit a " ++ entityName ++ " entity.\n" ++
           "The default values for the fields are stored in '" ++
           snd (controllerStoreName entityName "edit") ++ "'.")
    (controllerFormName entityName "edit") 0
    Public
    (emptyClassType $ applyTC (htmlModule "HtmlFormDef")
      [editTupleType erdname entity relationships allEntities])
    [simpleRule []
      (applyF (wuiModule "pwui2FormDef")
        [string2ac $ showQName $ controllerFormName entityName "edit",
         constF (controllerStoreName entityName "edit"),
         wuiFun, storeFun, renderFun])]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
  manyToOneEntities  = manyToOne (Entity entityName attrlist) relationships
  arity1 = 2 + length manyToOneEntities * 2 + length manyToManyEntities
427
  listEntityURL = '?' : entityName ++ "/list"
428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462

  wuiFun =
    CLambda
      [tuplePattern
        ([CPVar (1,"_"), CPVar (1, lowerFirst entityName)] ++
         map (\ (name, varId) -> CPVar(varId,("related"++name)))
             (zip manyToOneEntities [2..]) ++
         map (\ (name, varId) -> CPVar(varId,("possible"++name++"s")))
             (zip (manyToOneEntities++manyToManyEntities) [2..]))] $
      applyF (viewModuleName entityName, "w" ++ entityName ++ "Type")
        ([cvar (lowerFirst entityName)] ++
         map (\ (name, varId) -> CVar(varId,("related"++name)))
             (zip manyToOneEntities [2..]) ++
         map (\ (name, varId) -> CVar(varId,("possible"++name++"s")))
             (zip (manyToOneEntities++manyToManyEntities) [2..]) )

  storeFun =
    let evar   = (1, lowerFirst entityName ++ "ToEdit")
        entvar = (2, "entity")
    in
    CLambda [CPVar (0,"_"),
             CPAs entvar
               (tuplePattern
                  ([CPVar evar] ++ 
                   map (\i -> CPVar (i+2,"_"))
                       [1 .. length manyToManyEntities]))]
      (applyF checkAuthorizationFunc
         [applyF (enauthModName,lowerFirst entityName++"OperationAllowed")
            [applyF (authorizationModule,"UpdateEntity") [CVar evar]],
          CLambda [CPVar (0,"_")]
            (applyF (spiceyModule,"transactionController")
               [applyF (erdname,"runT")
                  [applyF (transFunctionName entityName "update")
                           [CVar entvar]],
                applyF (spiceyModule,"nextInProcessOr")
463 464
                  [applyF (spiceyModule,"redirectController")
                          [string2ac listEntityURL],
465 466 467 468 469 470 471 472 473
                   constF (pre "Nothing")]])])

  renderFun =
    CLambda [tuplePattern
               (map CPVar (sinfovar : map (\v -> (v,"_")) [2 .. arity1]))] $
      applyF (spiceyModule,"renderWUI")
        [CVar sinfovar,
         string2ac $ "Edit " ++ entityName,
         string2ac "Change",
474
         string2ac listEntityURL,
475 476 477 478
         constF (pre "()")
        ]
   where sinfovar = (1, "sinfo")

479

480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514
--- Generates the store for WUI to edit an entity.
editStore :: String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
editStore erdname entity@(Entity entityName _) relationships allEntities =
  cmtfunc "The data stored for executing the edit WUI form."
    (controllerStoreName entityName "edit") 0
    Private
    (emptyClassType $ applyTC (globalModule "Global")
      [applyTC (sessionModule "SessionStore")
        [editTupleType erdname entity relationships allEntities]])
    [simpleRule []
      (applyF (globalModule "global")
        [constF (sessionModule "emptySessionStore"),
         applyF (globalModule "Persistent")
          [applyF (storageModule "inDataDir")
            [string2ac $ "edit" ++ entityName ++ "Store"]]])]

--- Computes the tuple type of the data to be stored and manipulated
--- by the WUI to edit a new entity.
editTupleType :: String -> Entity -> [Relationship] -> [Entity] -> CTypeExpr
editTupleType erdname (Entity entityName attrlist) relationships allEntities =
  tupleType
    [tupleType $
      [userSessionInfoType, baseType (erdname, entityName)] ++
      map ctvar manyToOneEntities ++ -- defaults for n:1
      map (\e -> listType (ctvar e))
          (manyToOneEntities ++ manyToManyEntities), -- possible values
     applyTC (wuiModule "WuiStore")
      [tupleType $
         [baseType (erdname, entityName)] ++
         map (\name -> listType (ctvar name)) manyToManyEntities]]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
  manyToOneEntities  = manyToOne (Entity entityName attrlist) relationships

--- Generates the transaction to update an entity.
515 516
updateTransaction :: ControllerGenerator
updateTransaction erdname (Entity entityName attrList) _ allEntities =
517 518 519
  stCmtFunc
    ("Transaction to persist modifications of a given " ++ entityName ++
     " entity\nto the database.")
520 521
    (transFunctionName entityName "update")
    2 Private
522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551
    (tupleType ([baseType (erdname, entityName)] ++
                 map (\name -> listType (ctvar name)) manyToManyEntities)
      ~> applyTC (dbconn "DBAction") [baseType (pre "()")])
    [simpleRule 
      [tuplePattern
             ([CPVar (0, lowerFirst entityName)] ++
              (map (\ (param, varId) -> CPVar (varId, param)) 
                   (zip (map (\e -> lowerFirst e ++ "s" ++
                                    linkTableName entityName e allEntities)
                             manyToManyEntities)
                        [1..])))
      ] -- parameter list for controller
      (foldr1 (\a b -> applyF (dbconn ">+") [a,b])
                ([applyF (erdname, "update"++entityName)
                         [cvar (lowerFirst entityName)]] ++ 
                 (map  (\name -> 
                          applyF (dbconn ">+=") [
                            applyF (controllerModuleName entityName,"get"++entityName++name++"s") [cvar (lowerFirst entityName)],
                            CLambda [CPVar(0, "old"++(linkTableName entityName name allEntities)++name++"s")] (applyF (controllerModuleName entityName, "remove"++(linkTableName entityName name allEntities)) [cvar ("old"++(linkTableName entityName name allEntities)++name++"s"), cvar (lowerFirst entityName)])
                          ]
                        )
                       manyToManyEntities
                      ) ++
                      (map (\name -> applyF (controllerModuleName entityName, "add"++(linkTableName entityName name allEntities)) [cvar ((lowerFirst name)++"s"++(linkTableName entityName name allEntities)), cvar (lowerFirst entityName)]) manyToManyEntities)
                    )
        )]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
  -- manyToOneEntities = manyToOne (Entity entityName attrList) relationships
  -- noPKeys = (filter notPKey attrList)
552

553
------------------------------------------------------------------------------
554 555 556
--- Generates controller to delete an entity after confirmation.
deleteController :: ControllerGenerator
deleteController erdname (Entity entityName _) _ _ =
557 558 559
  let entlc    = lowerFirst entityName  -- entity name in lowercase
      entvar   = (0, entlc)             -- entity parameter for controller
      sinfovar = (1, "sinfo")           -- "sinfo" parameter
560 561 562 563 564 565
  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)
566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585
  [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
586
      listEntityURL = '?' : entityName ++ "/list"
587 588 589 590 591 592
  in
  controllerFunction
  ("Deletes a given " ++ entityName ++ " entity\n" ++
   "and proceeds with the list controller.")
  entityName "destroy" 1
  (baseType (erdname, entityName) ~> controllerType)
593 594 595 596
  [simpleRule [CPVar entvar]
    (applyF (pre "$")
       [applyF checkAuthorizationFunc
         [applyF (enauthModName,entlc++"OperationAllowed")
597
                 [applyF (authorizationModule,"DeleteEntity") [CVar entvar]]],
598
        CLambda [CPVar (0,"_")] $
599
         applyF (spiceyModule,"transactionController")
600
            [applyF (erdname,"runT")
601 602
                    [applyF (transFunctionName entityName "delete")
                            [CVar entvar]],
603 604
             applyF (spiceyModule,"redirectController")
                    [string2ac listEntityURL]]])]
605 606 607 608 609 610 611 612

--- Generates a transaction to delete an entity.
deleteTransaction :: ControllerGenerator
deleteTransaction erdname (Entity entityName attrList) _ allEntities =
  let manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
      entlc  = lowerFirst entityName  -- entity name in lowercase
      entvar = (0, entlc)             -- entity parameter for trans.
  in
Michael Hanus 's avatar
Michael Hanus committed
613
   stCmtFunc
614 615 616 617
    ("Transaction to delete a given "++entityName++" entity.")
    (transFunctionName entityName "delete")
    1 Private
    (baseType (erdname, entityName) ~>
618
                     applyTC (dbconn "DBAction") [baseType (pre "()")])
619 620
    [simpleRule 
      [CPVar entvar] -- entity parameter for controller
621
      (foldr1 (\a b -> applyF (dbconn ">+") [a,b])
622
           (map (\name ->
623
                  applyF (dbconn ">+=")
624 625 626 627 628 629 630 631 632 633 634
                         [applyF (controllerModuleName entityName,
                                  "get"++entityName++name++"s")
                                 [CVar entvar],
                          CLambda [CPVar(0, "old"++(linkTableName entityName name allEntities)++name++"s")]
                            (applyF (controllerModuleName entityName,
                                     "remove"++(linkTableName entityName name allEntities))
                                    [cvar ("old"++(linkTableName entityName name allEntities)++name++"s"),
                                     CVar entvar ])
                        ]
                 )
                 manyToManyEntities ++
635
            [applyF (erdname, "delete" ++ entityName) [CVar entvar]]))]
636

637
------------------------------------------------------------------------------
638 639
listController :: ControllerGenerator
listController erdname (Entity entityName _) _ _ =
640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664
  controllerFunction
    ("Lists all "++entityName++" entities with buttons to show, delete,\n"++
     "or edit an entity.")
    entityName "list" 0
    controllerType
    [simpleRule [] -- no arguments
      (applyF (pre "$")
          [applyF checkAuthorizationFunc
            [applyF (enauthModName,lowerFirst entityName++"OperationAllowed")
              [applyF (authorizationModule,"ListEntities") []]],
           CLambda [CPVar infovar] $
            CDoExpr (            
            [CSPat (CPVar entsvar)
                   (applyF (erdname,"runQ")
                           [constF (erdname,"queryAll"++entityName++"s")]),
             CSExpr (applyF (pre "return")
                           [applyF (viewFunctionName entityName "list")
                                   [CVar infovar, CVar entsvar]])
            ]
          )
         ]
        )]
 where
  infovar = (0, "sinfo")
  entsvar = (1, (lowerFirst entityName)++"s")
665

666
------------------------------------------------------------------------------
667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682
showController :: ControllerGenerator
showController erdname (Entity entityName attrList) relationships allEntities =
  let manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
      manyToOneEntities  = manyToOne (Entity entityName attrList) relationships
      pvar               = (0, lowerFirst entityName)
      infovar            = (1, "sinfo")
  in
    controllerFunction
    ("Shows a "++entityName++" entity.")
    entityName "show" 1
      (baseType (erdname,entityName) ~> controllerType)
      [simpleRule 
        [CPVar pvar] -- parameterlist for controller
        (applyF (pre "$")
            [applyF checkAuthorizationFunc
              [applyF (enauthModName,lowerFirst entityName++"OperationAllowed")
683
                [applyF (authorizationModule,"ShowEntity") [CVar pvar]]],
684 685 686 687 688 689
             CLambda [CPVar infovar] $
              CDoExpr (
              (map (\ (ename, num) ->
                     CSPat (CPVar (num,lowerFirst
                                         (fst $ relationshipName entityName
                                               ename relationships) ++ ename)) 
690
                           (applyF (erdname,"runJustT")
691 692 693 694 695 696 697 698 699 700 701 702 703
                              [applyF (controllerModuleName entityName,
                                       "get"++ fst (relationshipName
                                                entityName ename relationships)
                                            ++ename)
                                      [CVar pvar]
                              ])
                   )
                   (zip (manyToOneEntities) [1..])
              ) ++
              (map (\ (ename, num) ->
                      CSPat (CPVar (num,lowerFirst (linkTableName entityName
                                                           ename allEntities)
                                        ++ename++"s"))
704
                            (applyF (erdname,"runJustT")
705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737
                               [applyF (controllerModuleName entityName,
                                        "get"++entityName++ename++"s")
                                       [CVar pvar]])
                   )
                   (zip (manyToManyEntities) [1..])
              ) ++
              [CSExpr (
                 applyF (pre "return")
                    [applyF (viewFunctionName entityName "show")
                       ([CVar infovar, CVar pvar] ++
                        (map (\ (ename, num) ->
                                CVar (num,lowerFirst (fst $ relationshipName
                                             entityName ename relationships)
                                           ++ ename))
                             (zip (manyToOneEntities) [1..])) ++
                        (map (\ (ename, num) ->
                               CVar (num,lowerFirst (linkTableName entityName
                                                       ename allEntities)
                                         ++ename++"s"))
                             (zip (manyToManyEntities) [1..])))
                    ])
              ])
            ]
          )
      ]

manyToManyAddOrRemove :: String -> Entity -> [String] -> [Entity] -> [CFuncDecl]
manyToManyAddOrRemove erdname (Entity entityName _) entities allEntities =
    (map (addOrRemoveFunction "add" "new" entityName) entities) ++
    (map (addOrRemoveFunction "remove" "delete" entityName) entities)
  where
    addOrRemoveFunction :: String -> String -> String -> String -> CFuncDecl
    addOrRemoveFunction funcPrefix dbFuncPrefix e1 e2 =      
Michael Hanus 's avatar
Michael Hanus committed
738
      stCmtFunc 
739 740 741 742 743 744
      (if (funcPrefix == "add")
        then ("Associates given entities with the "++entityName++" entity.")
        else ("Removes association to the given entities with the "++entityName++" entity."))
      (controllerModuleName e1, funcPrefix++(linkTableName e1 e2 allEntities))
      2 
      Private
745
      (listType (ctvar e2) ~> ctvar e1 ~> applyTC (dbconn "DBAction")
746 747
                                                 [tupleType []])
      [simpleRule [CPVar (0, (lowerFirst e2)++"s"), CPVar (1, (lowerFirst e1))]
748
        (applyF (pre "mapM_")
749 750 751 752 753 754 755 756 757 758 759 760
           [CLambda [CPVar(2, "t")]
             (applyF (erdname, dbFuncPrefix++(linkTableName e1 e2 allEntities))
               [applyF (erdname, (lowerFirst e1)++"Key") [cvar (lowerFirst e1)],
                applyF (erdname, (lowerFirst e2)++"Key") [cvar "t"]]),
            cvar ((lowerFirst e2)++"s")])]

getAll :: String -> Entity -> [String] -> [Entity] -> [CFuncDecl]
getAll erdname (Entity entityName _) entities _ =
    map getAllFunction entities
  where
    getAllFunction :: String -> CFuncDecl
    getAllFunction foreignEntity =
Michael Hanus 's avatar
Michael Hanus committed
761
      stCmtFunc 
762 763 764 765 766 767
      ("Gets all "++foreignEntity++" entities.")
      (controllerModuleName entityName, "getAll"++foreignEntity++"s")
      0
      Private
      (ioType (listType (ctvar foreignEntity)))
      [simpleRule []
768 769
        (applyF (erdname,"runQ")
          [applyF (erdname,"queryAll")
770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785
            [CLambda [CPVar(0, take 1 (lowerFirst foreignEntity) )]
                     (CLetDecl [(CLocalVars [(1,"key")])]
                        (applyF (erdname, lowerFirst foreignEntity)
                                [cvar "key",
                                 cvar (take 1 (lowerFirst foreignEntity))]))
                    ]
            ]
       )
      ]
      
manyToManyGetRelated :: String -> Entity -> [String] -> [Entity] -> [CFuncDecl]
manyToManyGetRelated erdname (Entity entityName _) entities allEntities =      
    map getRelatedFunction entities
  where
    getRelatedFunction :: String -> CFuncDecl
    getRelatedFunction foreignEntity =
Michael Hanus 's avatar
Michael Hanus committed
786
      stCmtFunc 
787 788 789 790
      ("Gets the associated "++foreignEntity++" entities for a given "++entityName++" entity.")
      (controllerModuleName entityName, "get"++(linkTableName entityName foreignEntity allEntities)++foreignEntity++"s")
      0
      Private
791 792
      (ctvar entityName ~> applyTC (dbconn "DBAction")
                                   [listType (ctvar foreignEntity)])
793
      [simpleRule [CPVar (1, (take 1 $ lowerFirst entityName)++foreignEntity)]
794
        (applyF (erdname,"queryAll")
795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821
          [CLambda [CPVar(0, take 1 (lowerFirst foreignEntity) )] 
            (CLetDecl
               [CLocalVars [(1,(take 1 $ lowerFirst entityName)++"key"),
                            (2,(take 1 $ lowerFirst foreignEntity)++"key")]]
               (foldr (\a b -> applyF ("Dynamic", "<>") [a,b]) 
                 (applyF (erdname, lowerFirst (linkTableName entityName foreignEntity allEntities)) [cvar ((take 1 $ lowerFirst entityName)++"key"), cvar ((take 1 $ lowerFirst foreignEntity)++"key")])
                 [
                 (applyF (erdname, lowerFirst entityName) [cvar $ (take 1 $ lowerFirst entityName)++"key", cvar ((take 1 $ lowerFirst entityName)++foreignEntity)]),
                 (applyF (erdname, lowerFirst foreignEntity) [cvar $ (take 1 $ lowerFirst foreignEntity)++"key", cvar (take 1 (lowerFirst foreignEntity))])
                 ]
               )
            )
          ]
        )
      ]

manyToOneGetRelated :: String -> Entity -> [String] -> [Entity]
                    -> [Relationship] -> [CFuncDecl]
manyToOneGetRelated erdname (Entity entityName _) entities _ relationships =      
    map getRelatedFunction entities
  where
    getRelatedFunction :: String -> CFuncDecl
    getRelatedFunction foreignEntity =
      let argvar  = (1, (take 1 $ lowerFirst entityName)++foreignEntity)
          rname   = fst (relationshipName entityName foreignEntity relationships)
          fkeysel = lowerFirst entityName++foreignEntity++rname++"Key"
      in
Michael Hanus 's avatar
Michael Hanus committed
822
      stCmtFunc 
823 824 825 826 827 828
      ("Gets the associated "++foreignEntity++" entity for a given "++
       entityName++" entity.")
      (controllerModuleName entityName,
       "get"++rname++foreignEntity)
      0
      Private
829
      ((ctvar entityName) ~> applyTC (dbconn "DBAction") [ctvar foreignEntity])
830 831 832 833 834 835 836 837 838 839 840 841 842 843
      [simpleRule [CPVar argvar]
                  (applyF (erdname,"get"++foreignEntity)
                          [applyF (erdname,fkeysel) [CVar argvar]])]

relationshipName :: String -> String -> [Relationship] -> (String, String)
relationshipName e1 e2 (rel:relrest)=
  case rel of
    (Relationship name [(REnd relE1 _ _), (REnd relE2 relName _)]) ->
      if ((relE1 == e1 && relE2 == e2) || (relE1 == e2 && relE2 == e1)) then (name, relName) else relationshipName e1 e2 relrest
relationshipName _ _ [] = error "relationshipName: relationship not found"
---- aux ---


displayErrorFunction :: QName
844
displayErrorFunction = (spiceyModule, "displayError")
845 846 847 848 849 850 851 852 853 854 855 856

entityConstructorFunction :: String -> Entity -> [Relationship] -> QName
entityConstructorFunction erdname (Entity entityName attrList) relationships =
  (erdname, "new" ++ 
    entityName ++ (newSuffix entityName attrList relationships)
  )

-- entityName: Name of entity the controller should be generated for
-- controllerType: the function of the generated Controller, e.g. "new", "edit", "list"
-- arity
-- functionType: the type of the controller function
-- rules: the rules defining the controller
Michael Hanus 's avatar
Michael Hanus committed
857 858
controllerFunction :: String -> String -> String -> Int -> CTypeExpr -> [CRule]
                   -> CFuncDecl
859 860
controllerFunction description entityName controllerType arity functionType
                   rules =
Michael Hanus 's avatar
Michael Hanus committed
861
  stCmtFunc description (controllerFunctionName entityName controllerType) arity
862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882
          (if controllerType `elem` ["main"]
           then Public
           else Private)
          functionType rules

getReferencedEntityName :: Domain -> String
getReferencedEntityName t =
  case t of KeyDom kd -> kd
            _         -> ""
            
relatedEntityNames :: Entity -> [Relationship] -> [String]
relatedEntityNames (Entity entityName attrlist) relationships =
  map (\(Relationship _ ((REnd name1 _ _):(REnd name2 _ _):[])) -> if (name1 == entityName) then name2 else name1) (relationshipsForEntity (Entity entityName attrlist) relationships)

-- gets all relationships 
relationshipsForEntity :: Entity -> [Relationship] -> [Relationship]
relationshipsForEntity (Entity entityName _) relationships =
  filter (\(Relationship _ ((REnd name1 _ _):(REnd name2 _ _):[])) -> name1 == entityName || name2 == entityName) (filter (not . isGeneratedR) relationships)
    
------ from ERD CodeGeneration

Michael Hanus 's avatar
Michael Hanus committed
883
newSuffix :: String -> [Attribute] -> [Relationship] -> String
884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908
newSuffix eName attrs rels = 
  let
    generatedRs = filter isGeneratedR rels
    exactRs  = filter isExactB  generatedRs --(i,i), i>1
    maxRs    = filter isMaxB    generatedRs --(0,i), i>1
    minMaxRs = filter isMinMaxB generatedRs --(i,j), i>0, j>i
  in
    concatMap ("With"++)
              (map attributeName (filter isForeignKey attrs)) ++
    if (length (exactRs ++ maxRs ++ minMaxRs))==0
    then ""
    else concatMap (\k->"With"++k++"Keys")
                   (map (relatedRelation eName)
                        (exactRs++maxRs++minMaxRs))
  where
    isExactB (Relationship _ [REnd _ _ _, REnd _ _ c]) =
      case c of Exactly i -> i>1
                _         -> False
    isMaxB (Relationship _ [REnd _ _ _, REnd _ _ c]) =
      case c of (Between 0 (Max i)) -> i>1
                _                   -> False
    isMinMaxB (Relationship _ [REnd _ _ _, REnd _ _ c]) =
      case c of (Between i (Max j)) -> i>0 && j>i
                _                   -> False

Michael Hanus 's avatar
Michael Hanus committed
909
isGeneratedR :: Relationship -> Bool
910 911 912 913 914 915 916 917 918 919 920 921 922 923 924
isGeneratedR (Relationship n _) = n == ""

-- extracts the name of the relationship related to a given entity name
relatedRelation :: String -> Relationship -> String
relatedRelation en (Relationship _ [REnd en1 _ _, REnd en2 _ _]) =
  if en==en1 then en2 else en1

relationshipsForEntityName :: String -> [Relationship] -> [Relationship]
relationshipsForEntityName ename rels = filter endsIn rels
 where
  endsIn (Relationship _ ends) = any (\ (REnd n _ _) -> ename == n) ends

------------------------------------------------------------------------
-- Auxiliaries:

Michael Hanus 's avatar
Michael Hanus committed
925
getUserSessionInfoFunc :: CExpr
926
getUserSessionInfoFunc = constF (sessionInfoModule,"getUserSessionInfo")
927

Michael Hanus 's avatar
Michael Hanus committed
928
checkAuthorizationFunc :: QName
929
checkAuthorizationFunc = (authorizationModule,"checkAuthorization")
930 931

------------------------------------------------------------------------