Scaffolding.curry 6.73 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
------------------------------------------------------------------------
--- This is the main file for scaffolding.
------------------------------------------------------------------------

module Spicey.Scaffolding where

import AbstractCurry.Types
import AbstractCurry.Build
import AbstractCurry.Pretty hiding(showCProg)
import Database.ERD
11
import Directory
12 13 14 15
import FilePath ( (</>) )
import IO
import System(system)

16
import ERD2Curry ( erd2cdbiWithDBandERD )
17
import Database.ERD.Goodies
18 19 20

import Spicey.ControllerGeneration
import Spicey.EntitiesToHtmlGeneration
21
import Spicey.EntityRoutesGeneration
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
import Spicey.GenerationHelper
import Spicey.RouteGeneration
import Spicey.Transformation
import Spicey.ViewGeneration

--- Pretty print an AbstractCurry program with name qualification on demand.
--- TODO: Currently, our naming scheme should ensure that there are no
--- name conflicts. Therefore, we omit the list of Curry modules
--- for the on-demand qualification. However, to be on the safe side,
--- one should explicitly set this list to the current module and the
--- list of its imports.
showCProg :: CurryProg -> String
showCProg = prettyCurryProg (setOnDemandQualification [] defaultOptions)

getRelationships :: ERD -> [Relationship]
getRelationships (ERD _ _ relationships) = relationships

getEntities :: ERD -> [Entity]
getEntities (ERD _ entities _) = entities

Michael Hanus 's avatar
Michael Hanus committed
42 43
createViews :: String -> ERD -> String -> String -> IO ()
createViews _ (ERD name entities relationship) path _ =
44 45
  mapM_ (saveView name (getEntities erdt) (getRelationships erdt))
        (filter (not . Spicey.GenerationHelper.isGenerated) (getEntities erdt))
Michael Hanus 's avatar
Michael Hanus committed
46 47 48 49 50 51 52 53 54 55
 where
  erdt = transform (ERD name entities relationship)

  saveView :: String -> [Entity] -> [Relationship] -> Entity -> IO ()
  saveView erdname allEntities relationships (Entity ename attrlist) = do
    putStrLn ("Saving view operations in 'View."++ename++".curry'...")
    writeFile (path </> ename++".curry")
              (showCProg (generateViewsForEntity erdname allEntities
                            (Entity ename attrlist) relationships))

56 57 58 59 60 61 62
createEntityRoutes :: String -> ERD -> String -> String -> IO ()
createEntityRoutes _ (ERD name entities _) path _ = do
  putStrLn "Generating enitity routes 'Config.EntityRoutes.curry'..."
  writeFile (path </> "EntityRoutes.curry")
            (showCProg (generateRoutesForEntity name entities))


Michael Hanus 's avatar
Michael Hanus committed
63 64
createControllers :: String -> ERD -> String -> String -> IO ()
createControllers _ (ERD name entities relationship) path _ = do
65 66
  mapM_ (saveController name (getEntities erdt) (getRelationships erdt))
        (filter (not . Spicey.GenerationHelper.isGenerated) (getEntities erdt))
Michael Hanus 's avatar
Michael Hanus committed
67
  putStrLn "Generating default controller authorization 'AuthorizedControllers.curry'..."
68 69 70 71 72
 where
  erdt = transform (ERD name entities relationship)

  saveController :: String -> [Entity] -> [Relationship] -> Entity -> IO ()
  saveController erdname allEntities relationships (Entity ename attrlist) = do
73 74
    putStrLn ("Saving controllers in 'Controller."++ename++".curry'...")
    writeFile (path </> ename++".curry")
75 76 77
              (showCProg (generateControllersForEntity erdname allEntities
                            (Entity ename attrlist) relationships))

78 79 80 81 82 83
createAuthorizations :: String -> ERD -> String -> String -> IO ()
createAuthorizations _ (ERD name entities _) path _ = do
  let targetfile = path </> "AuthorizedActions.curry"
  putStrLn $ "Generating default action authorization '" ++ targetfile ++ "'..."
  writeFile targetfile (showCProg (generateAuthorizations name entities))

Michael Hanus 's avatar
Michael Hanus committed
84 85 86
createHtmlHelpers :: String -> ERD -> String -> String -> IO ()
createHtmlHelpers _ (ERD name entities relationship) path _ =
  saveToHtml name (getEntities erdt) (getRelationships erdt)
87 88 89 90 91
 where
  erdt = transform (ERD name entities relationship)

  saveToHtml :: String -> [Entity] -> [Relationship] -> IO ()
  saveToHtml erdname allEntities relationships = do
92 93
    putStrLn $ "Saving 'View." ++ entitiesToHtmlModule erdname ++ ".curry'..."
    fileh <- openFile (path </> "EntitiesToHtml.curry") WriteMode
94 95 96
    hPutStr fileh (showCProg (generateToHtml erdname allEntities relationships))
    hClose fileh

97
-- Uses Curry package `ertools` for ERD to Curry transformation
Michael Hanus 's avatar
Michael Hanus committed
98
createModels :: String -> ERD -> String -> String -> IO ()
99
createModels termpath erd path dbpath = do
100
  let erdname = erdName erd
101 102
      dbfile = if null dbpath then erdname ++ ".db"
                              else dbpath
103 104
  curdir <- getCurrentDirectory
  setCurrentDirectory path
105
  erd2cdbiWithDBandERD dbfile termpath
106
  setCurrentDirectory curdir
107

Michael Hanus 's avatar
Michael Hanus committed
108 109
createRoutes :: String -> ERD -> String -> String -> IO ()
createRoutes _ erd path _ = do
110 111
  putStrLn $ "Saving '"++mappingModuleName++".curry'..."
  mmfileh <- openFile (path </> "ControllerMapping.curry") WriteMode
112 113
  hPutStr mmfileh (showCProg (generateRoutesForERD erd))
  hClose mmfileh  
114 115
  putStrLn $ "Saving '"++dataModuleName++".curry'..."
  dmfileh <- openFile (path </> "RoutesData.curry") WriteMode
116 117 118 119
  hPutStr dmfileh (showCProg (generateStartpointDataForERD erd))
  hClose dmfileh

------------------------------------------------------------------------
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
-- Generate all default authorizations.
generateAuthorizations :: String -> [Entity] -> CurryProg
generateAuthorizations erdname entities = simpleCurryProg
  enauthModName
  [authorizationModule, sessionInfoModule, erdname] -- imports
  [] -- typedecls
  -- functions
  (map operationAllowed entities)
  [] -- opdecls
 where
  operationAllowed (Entity entityName _) =
   stCmtFunc
    ("Checks whether the application of an operation to a "++entityName++"\n"++
     "entity is allowed.")
    (enauthModName, lowerFirst entityName ++ "OperationAllowed")
    1
    Public
    (applyTC (authorizationModule,"AccessType") [baseType (erdname,entityName)]
     ~> baseType (sessionInfoModule,"UserSessionInfo")
     ~> ioType (baseType (authorizationModule,"AccessResult")))
    [simpleRule [CPVar (1,"at"), CPVar (2,"_")]
     (CCase CRigid (CVar (1,"at"))
       [cBranch (CPComb (authorizationModule,"ListEntities") []) allowed,
        cBranch (CPComb (authorizationModule,"NewEntity")    []) allowed,
        cBranch (CPComb (authorizationModule,"ShowEntity")   [CPVar (3,"_")])
                allowed,
        cBranch (CPComb (authorizationModule,"DeleteEntity") [CPVar (3,"_")])
                allowed,
        cBranch (CPComb (authorizationModule,"UpdateEntity") [CPVar (3,"_")])
                allowed])]

  -- Expression implemented access allowed
  allowed = applyF (pre "return") [constF (authorizationModule,"AccessGranted")]

  -- Expression implemented access denied
  --exprDenied = applyF (pre "return")
  --                    [applyF (authorizationModule,"AccessDenied")
  --                            [string2ac "Operation not allowed!"]]

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