Commit 237559b0 authored by Michael Hanus 's avatar Michael Hanus
Browse files

Updated to version3

parent cd528af7
Copyright (c) 2021, Michael Hanus
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the names of the copyright holders nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- CurryCheck test for Spicey web application framework
import Directory ( createDirectory, getCurrentDirectory, setCurrentDirectory )
import FilePath ( (</>) )
import System ( system )
import System.Directory ( createDirectory, getCurrentDirectory
, setCurrentDirectory )
import System.FilePath ( (</>) )
import System.Process ( system )
import Test.Prop
import Spicey.PackageConfig ( packagePath, packageExecutable )
......
{
"name": "spicey",
"version": "3.4.0",
"version": "4.0.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "A web application framework for Curry",
"category": [ "Web", "Database" ],
"license": "BSD-3-Clause",
"licenseFile": "LICENSE",
"dependencies": {
"base" : ">= 1.0.0, < 2.0.0",
"abstract-curry": ">= 2.0.0",
"ertools" : ">= 2.0.0"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0, < 3.0.0",
"kics2": ">= 2.0.0, < 3.0.0"
"base" : ">= 3.0.0, < 4.0.0",
"abstract-curry": ">= 3.0.0, < 4.0.0",
"directory" : ">= 3.0.0, < 4.0.0",
"ertools" : ">= 3.0.0, < 4.0.0",
"filepath" : ">= 3.0.0, < 4.0.0",
"process" : ">= 3.0.0, < 4.0.0",
"time" : ">= 3.0.0, < 4.0.0"
},
"configModule": "Spicey.PackageConfig",
"executable": {
......
......@@ -5,17 +5,15 @@
"synopsis": "Web application 'XXXPKGNAMEXXX' generated by Spicey",
"category": [ "Web" ],
"dependencies": {
"base" : ">= 1.0.0, < 2.0.0",
"cdbi" : ">= 2.0.0",
"cryptohash" : ">= 0.0.1",
"html2" : ">= 1.0.0, < 2.0.0",
"random" : ">= 0.0.1",
"searchtree" : ">= 0.0.1",
"wui2" : ">= 1.0.0, < 2.0.0"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0, < 3.0.0",
"kics2": ">= 2.0.0, < 3.0.0"
"base" : ">= 3.0.0, < 4.0.0",
"cdbi" : ">= 3.2.0, < 4.0.0",
"cryptohash" : ">= 3.0.0, < 4.0.0",
"filepath" : ">= 3.0.0, < 4.0.0",
"html2" : ">= 3.4.0, < 4.0.0",
"random" : ">= 3.0.0, < 4.0.0",
"searchtree" : ">= 3.0.0, < 4.0.0",
"time" : ">= 3.0.0, < 4.0.0",
"wui2" : ">= 3.1.0, < 4.0.0"
},
"sourceDirs": [ "src", "src/Model" ]
}
......@@ -33,6 +33,7 @@ type ControllerResult = String
-- Node ids for the processes:
data Node = NewEntry | NewComment | EndCmt | NewTag | EndTag
deriving (Read,Show)
availableProcesses :: Processes Node
availableProcesses = ProcSpec [] failed failed -- default declaration
......
......@@ -11,8 +11,7 @@ module Controller.SpiceySystem
)
where
import Global
import ReadNumeric
import Numeric
import Config.UserProcesses
import System.Spicey
......@@ -27,7 +26,7 @@ import View.SpiceySystem
loginController :: Controller
loginController = do
login <- getSessionLogin
writeSessionData loginViewData login
putSessionData loginViewData login
return [formElem loginFormDef]
loginFormDef :: HtmlFormDef (Maybe String)
......@@ -35,9 +34,8 @@ loginFormDef = formDefWithID "Controller.SpiceySystem.loginFormDef"
(getSessionData loginViewData Nothing) loginView
--- The data processed by the login form.
loginViewData :: Global (SessionStore (Maybe String))
loginViewData =
global emptySessionStore (Persistent (inSessionDataDir "loginViewData"))
loginViewData :: SessionStore (Maybe String)
loginViewData = sessionStore "loginViewData"
-----------------------------------------------------------------------------
--- Controller for showing and selecting user processes.
......@@ -45,12 +43,11 @@ processListController :: Controller
processListController = do
args <- getControllerParams
if null args
then return $ processListView availableProcesses
else case (readInt (head args)) of
Just (idInt, _) -> do
startProcess (processNames availableProcesses !! (idInt - 1))
Nothing ->
displayError "could not read process id"
then return $ processListView availableProcesses
else case readInt (head args) of
[(idInt, "")] ->
startProcess (processNames availableProcesses !! (idInt - 1))
_ -> displayError "could not read process id"
-----------------------------------------------------------------------------
--- Controller for the URL history.
......
......@@ -38,7 +38,7 @@ randomPassword = randomString
--- Gets the login name of the current session
--- (or the Nothing if there is no login).
getSessionLogin :: IO (Maybe String)
getSessionLogin = liftM userLoginOfSession getUserSessionInfo
getSessionLogin = fmap userLoginOfSession getUserSessionInfo
--- Stores a login name in the current session.
--- The authentication has to be done before!
......
......@@ -8,8 +8,7 @@ module System.Processes
, nextControllerRefInProcessOrForUrl
) where
import Global
import Maybe
import Data.Maybe
import ReadShowTerm
import Control.AllSolutions ( getOneValue )
......@@ -41,15 +40,15 @@ isFinalState sid (ProcSpec _ _ trans) = do
--------------------------------------------------------------------------
-- The current processes are stored in a persistent entity.
currentProcess :: Global (SessionStore String)
currentProcess = global emptySessionStore Temporary
currentProcess :: SessionStore String
currentProcess = sessionStore "currentProcess"
--- Returns the process state stored in the user session.
getCurrentProcess :: IO (Maybe _)
getCurrentProcess :: Read a => IO (Maybe a)
getCurrentProcess = do
curProc <- fromFormReader $ getSessionMaybeData currentProcess
case curProc of
Just sids -> return $ Just (readQTerm sids)
Just sids -> return $ Just (read sids)
Nothing -> return Nothing
--- Is the current user session in a process interaction?
......@@ -59,8 +58,8 @@ isInProcess = fromFormReader $
--- Saves the state of a process, i.e., a node in the process graph,
--- in the user session.
saveCurrentProcess :: _ -> IO ()
saveCurrentProcess sid = writeSessionData currentProcess (showQTerm sid)
saveCurrentProcess :: Show a => a -> IO ()
saveCurrentProcess sid = putSessionData currentProcess (show sid)
--- Deletes the process in the user session.
removeCurrentProcess :: IO ()
......@@ -83,13 +82,13 @@ advanceInProcess :: Maybe ControllerResult -> IO ()
advanceInProcess ctrlinfo = do
curprocess <- getCurrentProcess
case curprocess of
Nothing -> done -- no active process, do nothing
Nothing -> return () -- no active process, do nothing
Just sid -> do
let (ProcSpec _ _ trans) = availableProcesses
nextsid <- getOneValue (trans sid ctrlinfo)
case nextsid of
Just sid' -> saveCurrentProcess sid'
Nothing -> done -- this case should not occur in a good spec.
Nothing -> return () -- this case should not occur in a good spec.
--- Returns the next controller in the current process or,
--- if there is no current process, the controller associated to the given URL.
......@@ -101,5 +100,5 @@ nextControllerRefInProcessOrForUrl url = do
Nothing -> getControllerReference url -- no current process
Just sid -> do isfinal <- isFinalState sid availableProcesses
if isfinal then removeCurrentProcess
else done
else return ()
return (Just (getControllerForState sid availableProcesses))
......@@ -14,8 +14,6 @@ module System.SessionInfo (
getUserSessionInfo, updateUserSessionInfo
) where
import Global
import HTML.Base ( fromFormReader )
import HTML.Session
......@@ -25,6 +23,7 @@ import HTML.Session
--- The argument of the session data is `Nothing` if the user is not logged in.
--- Otherwise, it is `Maybe ln` where `ln` is the login name of the user.
data UserSessionInfo = SD (Maybe String)
deriving (Read,Show)
--- The initial (empty) session data
emptySessionInfo :: UserSessionInfo
......@@ -40,9 +39,8 @@ setUserLoginOfSession login (SD _) = SD login
--------------------------------------------------------------------------
--- Definition of the session state to store the login name (as a string).
userSessionInfo :: Global (SessionStore UserSessionInfo)
userSessionInfo =
global emptySessionStore (Persistent (inSessionDataDir "userSessionInfo"))
userSessionInfo :: SessionStore UserSessionInfo
userSessionInfo = sessionStore "userSessionInfo"
--- Gets the data of the current user session.
getUserSessionInfo :: IO UserSessionInfo
......
......@@ -24,11 +24,10 @@ module System.Spicey (
saveLastUrl, getLastUrl, getLastUrls
) where
import Char ( isSpace, isDigit )
import FilePath ( (</>) )
import Global
import ReadShowTerm ( readsQTerm )
import Time
import Data.Char ( isSpace, isDigit )
import Data.Time
import System.FilePath ( (</>) )
import Database.CDBI.Connection ( SQLResult )
import HTML.Base
......@@ -243,9 +242,9 @@ wFloat = transformWSpec (readFloat, show)
readMaybeFloat :: String -> Maybe Float
readMaybeFloat s =
if all isFloatChar s
then case readsQTerm s of
then case reads s of
[(x,tail)] -> if all isSpace tail then Just x else Nothing
_ -> Nothing
_ -> Nothing
else Nothing
where
isFloatChar c = isDigit c || c == '.'
......@@ -320,14 +319,14 @@ jsIncludes =
cancelOperation :: IO ()
cancelOperation = do
inproc <- isInProcess
if inproc then removeCurrentProcess else done
if inproc then removeCurrentProcess else return ()
setPageMessage $ (if inproc then "Process" else "Operation") ++ " cancelled"
-- dummy-controller to display an error
displayError :: String -> Controller
displayError msg = do
inproc <- isInProcess
if inproc then removeCurrentProcess else done
if inproc then removeCurrentProcess else return ()
setPageMessage ("Error occurred!" ++
if inproc then " Process terminated!" else "")
if null msg
......@@ -393,13 +392,12 @@ spTable items = table items `addClass` "table table-hover table-condensed"
--------------------------------------------------------------------------
-- The page messages are implemented by a session store.
-- We define a global variable to store a message which is shown
-- This store contains a message which is shown
-- in the next HTML page of a session.
--- Definition of the session state to store the page message (a string).
pageMessage :: Global (SessionStore String)
pageMessage =
global emptySessionStore (Persistent (inSessionDataDir "pageMessage"))
pageMessage :: SessionStore String
pageMessage = sessionStore "pageMessage"
--- Gets the page message and delete it.
getPageMessage :: IO String
......@@ -410,15 +408,15 @@ getPageMessage = do
--- Set the page message of the current session.
setPageMessage :: String -> IO ()
setPageMessage msg = writeSessionData pageMessage msg
setPageMessage msg = putSessionData pageMessage msg
--------------------------------------------------------------------------
-- Another example for using sessions.
-- We store the list of selected URLs into the current session.
--- Definition of the session state to store the last URL (as a string).
lastUrls :: Global (SessionStore [String])
lastUrls = global emptySessionStore (Persistent (inSessionDataDir "lastUrls"))
lastUrls :: SessionStore [String]
lastUrls = sessionStore "lastUrls"
--- Gets the list of URLs of the current session.
getLastUrls :: IO [String]
......@@ -433,6 +431,6 @@ getLastUrl = do urls <- getLastUrls
saveLastUrl :: String -> IO ()
saveLastUrl url = do
urls <- getLastUrls
writeSessionData lastUrls (url:urls)
putSessionData lastUrls (url:urls)
--------------------------------------------------------------------------
......@@ -37,7 +37,7 @@ loginView currlogin =
let loginname = env loginfield
-- In the real system, you should also verify a password here.
if null loginname
then done
then return ()
else do loginToSession loginname
setPageMessage ("Logged in as: "++loginname)
nextInProcessOr (redirectController "?") Nothing >>= getPage
......
......@@ -2,7 +2,7 @@
module Spicey.ControllerGeneration where
import Char(toLower)
import Data.Char ( toLower )
import AbstractCurry.Types
import AbstractCurry.Build
......@@ -29,7 +29,7 @@ generateControllersForEntity erdname allEntities
CurryProg
(controllerModuleName ename)
-- imports:
[ "Global", "Maybe", "Time"
[ timeModule
, "HTML.Base", "HTML.Session", "HTML.WUI"
, erdname
, "Config.EntityRoutes", "Config.UserProcesses"
......@@ -160,7 +160,7 @@ newController erdname (Entity entityName attrList) relationships allEntities =
) ++
(if withCTime
then [CSPat (CPVar ctimevar)
(constF ("Time","getClockTime"))]
(constF (timeModule,"getClockTime"))]
else []) ++
[CSExpr setParCall,
CSExpr $ applyF (pre "return")
......@@ -256,15 +256,12 @@ 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]])
(emptyClassType $
applyTC (sessionModule "SessionStore")
[newTupleType entity relationships allEntities])
[simpleRule []
(applyF (globalModule "global")
[constF (sessionModule "emptySessionStore"),
applyF (globalModule "Persistent")
[applyF (sessionModule "inSessionDataDir")
[string2ac $ "new" ++ entityName ++ "Store"]]])]
(applyF (sessionModule "sessionStore")
[string2ac $ "new" ++ entityName ++ "Store"])]
--- Computes the tuple type of the data to be stored and manipulated
......@@ -299,7 +296,7 @@ createTransaction erdname (Entity entityName attrList)
map (\e -> (lowerFirst e) ++ "s") manyToManyEntities)
[1..]))
] -- parameter list for controller
(applyF (dbconn ">+=")
(applyF (pre ">>=")
[applyF (entityConstructorFunction erdname (Entity entityName attrList) relationships)
(map (\ ((Attribute name dom key null), varId) ->
if (isForeignKey (Attribute name dom key null))
......@@ -313,7 +310,7 @@ createTransaction erdname (Entity entityName attrList)
(zip noPKeys [1..])
),
CLambda [cpvar "newentity"]
(foldr1 (\a b -> applyF (dbconn ">+") [a,b])
(foldr1 (\a b -> applyF (pre ">>") [a,b])
(map (\name -> applyF (controllerModuleName entityName,
"add"++(linkTableName entityName name allEntities))
[cvar (lowerFirst name ++ "s"),
......@@ -482,15 +479,12 @@ 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]])
(emptyClassType $
applyTC (sessionModule "SessionStore")
[editTupleType erdname entity relationships allEntities])
[simpleRule []
(applyF (globalModule "global")
[constF (sessionModule "emptySessionStore"),
applyF (globalModule "Persistent")
[applyF (sessionModule "inSessionDataDir")
[string2ac $ "edit" ++ entityName ++ "Store"]]])]
(applyF (sessionModule "sessionStore")
[string2ac $ "edit" ++ entityName ++ "Store"])]
--- Computes the tuple type of the data to be stored and manipulated
--- by the WUI to edit a new entity.
......@@ -520,7 +514,7 @@ updateTransaction erdname (Entity entityName attrList) _ allEntities =
2 Private
(tupleType ([baseType (erdname, entityName)] ++
map (\name -> listType (ctvar name)) manyToManyEntities)
~> applyTC (dbconn "DBAction") [baseType (pre "()")])
~> applyTC (dbconn "DBAction") [unitType])
[simpleRule
[tuplePattern
([CPVar (0, lowerFirst entityName)] ++
......@@ -530,11 +524,11 @@ updateTransaction erdname (Entity entityName attrList) _ allEntities =
manyToManyEntities)
[1..])))
] -- parameter list for controller
(foldr1 (\a b -> applyF (dbconn ">+") [a,b])
(foldr1 (\a b -> applyF (pre ">>") [a,b])
([applyF (erdname, "update"++entityName)
[cvar (lowerFirst entityName)]] ++
(map (\name ->
applyF (dbconn ">+=") [
applyF (pre ">>=") [
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)])
]
......@@ -610,23 +604,22 @@ deleteTransaction erdname (Entity entityName attrList) _ allEntities =
entvar = (0, entlc) -- entity parameter for trans.
in
stCmtFunc
("Transaction to delete a given "++entityName++" entity.")
("Transaction to delete a given " ++ entityName ++ " entity.")
(transFunctionName entityName "delete")
1 Private
(baseType (erdname, entityName) ~>
applyTC (dbconn "DBAction") [baseType (pre "()")])
(baseType (erdname, entityName) ~> applyTC (dbconn "DBAction") [unitType])
[simpleRule
[CPVar entvar] -- entity parameter for controller
(foldr1 (\a b -> applyF (dbconn ">+") [a,b])
(foldr1 (\a b -> applyF (pre ">>") [a,b])
(map (\name ->
applyF (dbconn ">+=")
applyF (pre ">>=")
[applyF (controllerModuleName entityName,
"get"++entityName++name++"s")
"get" ++ entityName ++ name ++ "s")
[CVar entvar],
CLambda [CPVar(0, "old"++(linkTableName entityName name allEntities)++name++"s")]
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"),
"remove" ++ (linkTableName entityName name allEntities))
[cvar ("old" ++ (linkTableName entityName name allEntities) ++ name ++ "s"),
CVar entvar ])
]
)
......@@ -637,20 +630,20 @@ deleteTransaction erdname (Entity entityName attrList) _ allEntities =
listController :: ControllerGenerator
listController erdname (Entity entityName _) _ _ =
controllerFunction
("Lists all "++entityName++" entities with buttons to show, delete,\n"++
("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 (enauthModName,lowerFirst entityName ++ "OperationAllowed")
[applyF (authorizationModule,"ListEntities") []]],
CLambda [CPVar infovar] $
CDoExpr (
[CSPat (CPVar entsvar)
(applyF (erdname,"runQ")
[constF (erdname,"queryAll"++entityName++"s")]),
[constF (erdname,"queryAll" ++ entityName ++ "s")]),
CSExpr (applyF (pre "return")
[applyF (viewFunctionName entityName "list")
[CVar infovar, CVar entsvar]])
......@@ -660,7 +653,7 @@ listController erdname (Entity entityName _) _ _ =
)]
where
infovar = (0, "sinfo")
entsvar = (1, (lowerFirst entityName)++"s")
entsvar = (1, (lowerFirst entityName) ++ "s")
------------------------------------------------------------------------------
showController :: ControllerGenerator
......@@ -671,14 +664,14 @@ showController erdname (Entity entityName attrList) relationships allEntities =
infovar = (1, "sinfo")
in
controllerFunction
("Shows a "++entityName++" entity.")
("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")
[applyF (enauthModName,lowerFirst entityName ++ "OperationAllowed")
[applyF (authorizationModule,"ShowEntity") [CVar pvar]]],
CLambda [CPVar infovar] $
CDoExpr (
......@@ -690,7 +683,7 @@ showController erdname (Entity entityName attrList) relationships allEntities =
[applyF (controllerModuleName entityName,
"get"++ fst (relationshipName
entityName ename relationships)
++ename)
++ ename)
[CVar pvar]
])
)
......@@ -699,10 +692,10 @@ showController erdname (Entity entityName attrList) relationships allEntities =
(map (\ (ename, num) ->
CSPat (CPVar (num,lowerFirst (linkTableName entityName
ename allEntities)
++ename++"s"))
++ename ++ "s"))
(applyF (erdname,"runJustT")
[applyF (controllerModuleName entityName,
"get"++entityName++ename++"s")
"get" ++ entityName ++ ename ++ "s")
[CVar pvar]])
)
(zip (manyToManyEntities) [1..])
......@@ -719,7 +712,7 @@ showController erdname (Entity entityName attrList) relationships allEntities =
(map (\ (ename, num) ->
CVar (num,lowerFirst (linkTableName entityName
ename allEntities)
++ename++"s"))
++ename ++ "s"))
(zip (manyToManyEntities) [1..])))
])
])
......@@ -736,20 +729,20 @@ manyToManyAddOrRemove erdname (Entity entityName _) entities allEntities =
addOrRemoveFunction funcPrefix dbFuncPrefix e1 e2 =
stCmtFunc
(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))
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
(listType (ctvar e2) ~> ctvar e1 ~> applyTC (dbconn "DBAction")
[tupleType []])
[simpleRule [CPVar (0, (lowerFirst e2)++"s"), CPVar (1, (lowerFirst e1))]
[simpleRule [CPVar (0, (lowerFirst e2) ++ "s"), CPVar (1, (lowerFirst e1))]
(applyF (pre "mapM_")
[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")])]
(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 _ =
......@@ -758,8 +751,8 @@ getAll erdname (Entity entityName _) entities _ =
getAllFunction :: String -> CFuncDecl
getAllFunction foreignEntity =
stCmtFunc
("Gets all "++foreignEntity++" entities.")
(controllerModuleName entityName, "getAll"++foreignEntity++"s")
("Gets all " ++ foreignEntity ++ " entities.")
(controllerModuleName entityName, "getAll" ++ foreignEntity ++ "s")
0
Private
(ioType (listType (ctvar foreignEntity)))
......@@ -783,23 +776,23 @@ manyToManyGetRelated erdname (Entity entityName _) entities allEntities =
getRelatedFunction :: String -> CFuncDecl
getRelatedFunction foreignEntity =
stCmtFunc
("Gets the associated "++foreignEntity++" entities for a given "++entityName++" entity.")
(controllerModuleName entityName, "get"++(linkTableName entityName foreignEntity allEntities)++foreignEntity++"s")
("Gets the associated " ++ foreignEntity ++ " entities for a given " ++ entityName ++ " entity.")
(controllerModuleName entityName, "get" ++ (linkTableName entityName foreignEntity allEntities) ++ foreignEntity ++ "s")
0
Private
(ctvar entityName ~> applyTC (dbconn "DBAction")
[listType (ctvar foreignEntity)])
[simpleRule [CPVar (1, (take 1 $ lowerFirst entityName)++foreignEntity)]
[simpleRule [CPVar (1, (take 1 $ lowerFirst entityName) ++ foreignEntity)]
(applyF (erdname,"queryAll")
[CLambda [CPVar(0, take 1 (lowerFirst foreignEntity) )]
(CLetDecl
[CLocalVars [(1,(take 1 $ lowerFirst entityName)++"key"),
(2,(take 1 $ lowerFirst foreignEntity)++"key")]]
[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 (linkTableName entityName foreignEntity allEntities)) [cvar ((take 1 $ lowerFirst entityName) ++ "key"), cvar ((take 1 $ lowerFirst foreignEntity) ++ "key")])