...
 
Commits (2)
......@@ -34,14 +34,16 @@ To generate an application, follow the steps below.
3. Change into the generated directory containing all sources as a
Curry package, e.g., by `cd Blog`.
4. Install all required packages by `make install`.
4. Define in the Makefile the variable WEBSERVERDIR (and possibly
other variables, like SYSTEM or CURRYOPTIONS).
5. Compile the generated programs by `make compile`.
5. Install all required packages by `make install`.
6. Configure the Makefile (variable WEBSERVERDIR) and execute
`make deploy` to deploy the web application.
6. Compile the generated programs by `make compile`.
7. After the successful compilation, the application is executable
7. Execute `make deploy` to deploy the web application.
8. After the successful compilation, the application is executable
in a web browser by loading `<URL of web dir>/spicey.cgi`.
Note that the database is generated with the `cdbi` package.
......
import Database.ERD
blogERD :: ERD
blogERD =
ERD "Blog"
[Entity "Entry"
[Attribute "Title" (StringDom Nothing) Unique False,
Attribute "Text" (StringDom Nothing) NoKey False,
Attribute "Author" (StringDom Nothing) NoKey False,
Attribute "Date" (DateDom Nothing) NoKey False],
Entity "Comment"
[Attribute "Text" (StringDom Nothing) NoKey False,
Attribute "Author" (StringDom Nothing) NoKey False,
Attribute "Date" (DateDom Nothing) NoKey False],
Entity "Tag"
[Attribute "Name" (StringDom Nothing) Unique False]
]
[Relationship "Commenting"
[REnd "Entry" "commentsOn" (Exactly 1),
REnd "Comment" "isCommentedBy" (Between 0 Infinite)],
Relationship "Tagging"
[REnd "Entry" "tags" (Between 0 Infinite),
REnd "Tag" "tagged" (Between 0 Infinite)]
]
blogERD = ERD "Blog"
[Entity "Entry"
[Attribute "Title" (StringDom Nothing) Unique False,
Attribute "Text" (StringDom Nothing) NoKey False,
Attribute "Author" (StringDom Nothing) NoKey False,
Attribute "Date" (DateDom Nothing) NoKey False],
Entity "Comment"
[Attribute "Text" (StringDom Nothing) NoKey False,
Attribute "Author" (StringDom Nothing) NoKey False,
Attribute "Date" (DateDom Nothing) NoKey False],
Entity "Tag"
[Attribute "Name" (StringDom Nothing) Unique False]
]
[Relationship "Commenting"
[REnd "Entry" "commentsOn" (Exactly 1),
REnd "Comment" "isCommentedBy" (Between 0 Infinite)],
Relationship "Tagging"
[REnd "Entry" "tags" (Between 0 Infinite),
REnd "Tag" "tagged" (Between 0 Infinite)]
]
......@@ -19,16 +19,19 @@ compileSpiceyApplication erdname = do
setCurrentDirectory testdir
system $ spiceup ++ " " ++
packagePath </> "examples" </> erdname ++ "ERD.curry"
let makecall = "make WEBSERVERDIR=/tmp"
putStrLn $ "Compiling Spicey application in directory '" ++ testdir ++ "'..."
ecode <- system $ "cd " ++ erdname ++ " && make install && " ++
"make CURRYOPTIONS=\":set parser -Wnone\" compile"
ecode <- system $ "cd " ++ erdname ++ " && " ++
makecall ++ " install && " ++
makecall ++ " CURRYOPTIONS=\":set parser -Wnone\" compile"
setCurrentDirectory curdir
system $ "/bin/rm -rf " ++ testdir
return ecode
-- Compile the Blog example.
testCompileBlog :: PropIO
testCompileBlog = compileSpiceyApplication "Blog" `returns` 0
-- Omitted due to bug in controller generation:
--testCompileUni :: PropIO
--testCompileUni = compileSpiceyApplication "Uni" `returns` 0
-- Compile the Uni example.
testCompileUni :: PropIO
testCompileUni = compileSpiceyApplication "Uni" `returns` 0
import Database.ERD
uniERD :: ERD
uniERD =
ERD "Uni"
[Entity "Student" [Attribute "MatNum" (IntDom Nothing) PKey False,
Attribute "Name" (StringDom Nothing) NoKey False,
Attribute "Firstname" (StringDom Nothing) NoKey False,
Attribute "Email" (StringDom Nothing) NoKey True],
Entity "Lecture" [Attribute "Id" (IntDom Nothing) PKey False,
Attribute "Title" (StringDom Nothing) Unique False,
Attribute "Hours" (IntDom (Just 4)) NoKey False],
Entity "Lecturer" [Attribute "Id" (IntDom Nothing) PKey False,
uniERD = ERD "Uni"
[Entity "Student" [Attribute "MatNum" (IntDom Nothing) PKey False,
Attribute "Name" (StringDom Nothing) NoKey False,
Attribute "Firstname" (StringDom Nothing) NoKey False,
Attribute "Email" (StringDom Nothing) NoKey True],
Entity "Lecture" [Attribute "Code" (StringDom Nothing) PKey False,
Attribute "Title" (StringDom Nothing) Unique False,
Attribute "Hours" (IntDom (Just 4)) NoKey False],
Entity "Lecturer" [Attribute "PersNum" (IntDom Nothing) PKey False,
Attribute "Name" (StringDom Nothing) NoKey False,
Attribute "Firstname" (StringDom Nothing) NoKey False],
Entity "Group" [Attribute "Time" (StringDom Nothing) NoKey False]]
Entity "Group" [Attribute "Time" (StringDom Nothing) NoKey False]]
[Relationship "Teaching"
[REnd "Lecturer" "taught_by" (Exactly 1),
REnd "Lecture" "teaches" (Between 0 Infinite)],
......@@ -21,5 +20,5 @@ uniERD =
[REnd "Student" "participated_by" (Between 0 Infinite),
REnd "Lecture" "participates" (Between 0 Infinite)],
Relationship "Membership"
[REnd "Student" "consists_of" (Exactly 3),
REnd "Group" "member_of" (Between 0 Infinite)]]
[REnd "Student" "consists_of" (Between 0 Infinite),
REnd "Group" "member_of" (Between 0 Infinite)]]
{
"name": "spicey",
"version": "3.1.0",
"version": "3.2.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "A web application framework for Curry",
"category": [ "Web", "Database" ],
......
......@@ -13,7 +13,7 @@ module System.Authentication (
) where
import System.SessionInfo
import System.Crypto
import Crypto.Hash
--------------------------------------------------------------------------
-- Operations for hashing.
......
--- Some global configurations for the Spicey application.
module Config.Spicey
where
--- Location of the directory containing private run-time data
--- such as session and authentication information.
spiceyDataDir :: String
spiceyDataDir = "data"
------------------------------------------------------------------------------
--- Some configurations where data is stored.
------------------------------------------------------------------------------
module Config.Storage where
import FilePath ( (</>) )
--- Prefix a file name with the directory where global form data
--- is stored during run-time.
inDataDir :: String -> String
inDataDir filename = "data" </> filename
......@@ -6,14 +6,19 @@
--------------------------------------------------------------------------
module Controller.SpiceySystem
(loginController,processListController,historyController)
( loginController, loginFormDef
, processListController, historyController
)
where
import Global
import ReadNumeric
import Config.Storage
import Config.UserProcesses
import System.Spicey
import System.Session
import HTML.Base
import HTML.Session
import System.Processes
import System.Authentication
import View.SpiceySystem
......@@ -24,7 +29,19 @@ import Controller.DefaultController
loginController :: Controller
loginController = do
login <- getSessionLogin
return $ loginView defaultController login
putSessionData loginViewData login
return [formExp loginFormDef]
loginFormDef :: HtmlFormDef (Maybe String)
loginFormDef =
formDefWithID "Controller.SpiceySystem.loginFormDef"
(getSessionData loginViewData Nothing)
(loginView defaultController)
--- The data processed by the login form.
loginViewData :: Global (SessionStore (Maybe String))
loginViewData =
global emptySessionStore (Persistent (inDataDir "loginViewData"))
-----------------------------------------------------------------------------
--- Controller for showing and selecting user processes.
......
----------------------------------------------------------------------------
--- This library contains operations to support simple cryptography.
--- In particular, it provides operations for hasing
--- (based on hashing algorithms from Unix).
---
--- @author Michael Hanus
----------------------------------------------------------------------------
module System.Crypto
( getHash, randomString )
where
import IO
import IOExts
import System.Random
--------------------------------------------------------------------------
-- Operations for hashing.
--- Default hashing function.
--- @param toHash - string which should be hashed
--- @return the hashSum of this str
getHash :: String -> IO String
getHash = getHashWith "md5sum"
--getHash = getHashWith "sha1sum"
--- Hashes a string with an explicit Unix hash command.
--- @param hashcmd - Unix command for hasing
--- @param toHash - string which should be hashed
--- @return the hashed string
getHashWith :: String -> String -> IO String
getHashWith hashcmd toHash = do
(sin, sout, _) <- execCmd hashcmd
hPutStrLn sin toHash
hClose sin
result <- hGetLine sout
return (head (words result))
--- Returns a random string (a hexadecimal string) of a particular length.
--- @param length - length of the desired string
--- @return the random string
randomString :: Int -> IO String
randomString n = do
seed <- getRandomSeed
ranString <- getHash (show (nextInt seed !! 3))
return (take n ranString)
--------------------------------------------------------------------------
......@@ -5,7 +5,7 @@
module Main where
import HTML.Base
import WUI
import HTML.WUI
import Config.ControllerMapping
import Config.RoutesData
......@@ -13,20 +13,18 @@ import System.Routes
import System.Processes
import System.Spicey
dispatcher :: IO HtmlForm
dispatcher :: IO HtmlPage
dispatcher = do
-- get url
(url,ctrlparams) <- getControllerURL
controller <- nextControllerRefInProcessOrForUrl url >>=
maybe (displayError "Illegal URL!")
getController
maybe displayUrlError getController
form <- getForm controller
page <- getPage controller
saveLastUrl (url ++ concatMap ("/"++) ctrlparams)
return form
return page
--- Main function: call the dispatcher
main :: IO HtmlForm
main :: IO HtmlPage
main = dispatcher
# Generic Makefile for Spicey applications
# Definition of the root of the Curry system to be used:
SYSTEM=XXXCURRYHOMEXXX
# Curry bin directory to be used:
export CURRYBIN=$(SYSTEM)/bin
CURRYOPTIONS=:set -time
# Target directory where the compiled cgi programs, style sheets, etc
# should be stored, e.g.: $(HOME)/public_html
WEBSERVERDIR = $(error "Define variable WEBSERVERDIR!")
# Definition of the Curry installation bin directory to be used:
export CURRYBIN=XXXCURRYBINXXX
# Executable of the Curry Package Manager CPM:
CPM := $(CURRYBIN)/cypm
# Executable of the curry2cgi:
CURRY2CGI := $(shell which curry2cgi)
# The root directory of the sources of the Spicey application:
SRCDIR := $(CURDIR)/src
# The load path for the Spicey application:
export CURRYPATH := $(SRCDIR):$(SRCDIR)/Model
# Executable of CPNSD:
CPNSD := $(shell which curry-cpnsd)
# Executable of the CGI registry and submission form:
CURRYCGI := $(shell which curry-cgi)
# Executable of the makecgi:
MAKECGI := $(shell which curry-makecgi)
############################################################################
.PHONY: all
......@@ -39,15 +38,9 @@ install:
# check presence of tools required for deployment and install them:
.PHONY: checkdeploy
checkdeploy:
@if [ ! -x "$(CPNSD)" ] ; then \
echo "Installing required executable 'curry-cpnsd'..." ; \
$(CPM) install cpns ; fi
@if [ ! -x "$(CURRYCGI)" ] ; then \
echo "Installing required executable 'curry-cgi'..." ; \
$(CPM) install html-cgi ; fi
@if [ ! -x "$(MAKECGI)" ] ; then \
echo "Installing required executable 'curry-makecgi'..." ; \
$(CPM) install html ; fi
@if [ ! -x "$(CURRY2CGI)" ] ; then \
echo "Installing required executable 'curry2cgi'..." ; \
$(CPM) install html2 ; fi
# Compile the generated Spicey application:
.PHONY: compile
......@@ -71,20 +64,26 @@ run:
.PHONY: deploy
deploy: checkdeploy
mkdir -p $(WEBSERVERDIR)
$(CPM) exec $(MAKECGI) -standalone -m main -o $(WEBSERVERDIR)/spicey.cgi Main.curry
$(MAKE) $(WEBSERVERDIR)/spicey.cgi
# copy other files (style sheets, images,...)
cp -r public/* $(WEBSERVERDIR)
mkdir -p $(WEBSERVERDIR)/data # create private data dir
cp -p data/htaccess $(WEBSERVERDIR)/data/.htaccess # and make it private
chmod -R go+rX $(WEBSERVERDIR)
# recreate directory for storing local session data:
/bin/rm -rf $(WEBSERVERDIR)/data
mkdir -p $(WEBSERVERDIR)/data
chmod 700 $(WEBSERVERDIR)/data
$(WEBSERVERDIR)/spicey.cgi: src/*.curry src/*/*.curry
$(CPM) exec $(CURRY2CGI) --system="$(SYSTEM)" \
-i Controller.SpiceySystem XXXICONTROLLERXXX \
-o $@ Main.curry
# clean up generated the package directory
.PHONY: clean
clean:
$(CPM) clean
# clean everything, including the deployed files (be sure to save the
# database files first!)
# clean everything, including the deployed files
.PHONY: cleanall
cleanall: clean
/bin/rm -rf $(WEBSERVERDIR)
/bin/rm -f $(WEBSERVERDIR)/spicey.cgi*
......@@ -8,17 +8,17 @@ module System.Processes
, nextControllerRefInProcessOrForUrl
) where
import Global
import Maybe
import ReadShowTerm
import Control.AllSolutions ( getOneValue )
import Global
import HTML.Base
import HTML.Session
import Config.RoutesData
import Config.UserProcesses
import System.Routes
import System.Session
--------------------------------------------------------------------------
-- A operations on the datatype for process systems.
......@@ -47,7 +47,7 @@ currentProcess = global emptySessionStore Temporary
--- Returns the process state stored in the user session.
getCurrentProcess :: IO (Maybe _)
getCurrentProcess = do
curProc <- getSessionData currentProcess
curProc <- getSessionMaybeData currentProcess
case curProc of
Just sids -> return $ Just (readQTerm sids)
Nothing -> return Nothing
......@@ -55,12 +55,12 @@ getCurrentProcess = do
--- Is the current user session in a process interaction?
isInProcess :: IO Bool
isInProcess =
getSessionData currentProcess >>= return . maybe False (const True)
getSessionMaybeData currentProcess >>= return . maybe False (const True)
--- Saves the state of a process, i.e., a node in the process graph,
--- in the user session.
saveCurrentProcess :: _ -> IO ()
saveCurrentProcess sid = putSessionData (showQTerm sid) currentProcess
saveCurrentProcess sid = putSessionData currentProcess (showQTerm sid)
--- Deletes the process in the user session.
removeCurrentProcess :: IO ()
......
--------------------------------------------------------------------------
--- This module implements the management of sessions.
--- In particular, it defines a cookie that must be sent to the client
--- in order to enable the handling of sessions.
--- Based on session, this module defines also a session store
--- that can be used by various parts of the application in order
--- to hold some session-specific data.
--------------------------------------------------------------------------
module System.Session (
sessionCookie,
SessionStore, emptySessionStore,
getSessionData, putSessionData, removeSessionData
) where
import FilePath ( (</>) )
import Global
import List
import Time
import HTML.Base
import Config.Spicey ( spiceyDataDir )
import System.Crypto
--- The life span in minutes to store data in sessions.
--- Thus, older data is deleted by a clean up that is initiated
--- whenever new data is stored in a session.
sessionLifespan :: Int
sessionLifespan = 60
--- The name of the persistent global where the last session id is stored.
sessionCookieName :: String
sessionCookieName = "spiceySessionId"
--- This global value saves time and last session id.
lastId :: Global (Int, Int)
lastId = global (0, 0) (Persistent (spiceyDataDir </> sessionCookieName))
--- The abstract type to represent session identifiers.
data SessionId = SessionId String
deriving Eq
getId :: SessionId -> String
getId (SessionId i) = i
--- Creates a new unused session id.
getUnusedId :: IO SessionId
getUnusedId = do
(ltime,lsid) <- readGlobal lastId
clockTime <- getClockTime
if clockTimeToInt clockTime /= ltime
then writeGlobal lastId (clockTimeToInt clockTime, 0)
else writeGlobal lastId (clockTimeToInt clockTime, lsid+1)
rans <- randomString 30
return (SessionId (show (clockTimeToInt clockTime) ++ show (lsid+1) ++ rans))
--- Gets the id of the current user session.
--- If this is a new session, a new id is created and returned.
getSessionId :: IO SessionId
getSessionId = do
cookies <- getCookies
case (lookup sessionCookieName cookies) of
Just sessionCookieValue -> return (SessionId sessionCookieValue)
Nothing -> getUnusedId
--- Creates a cookie to hold the current session id.
--- This cookie should be sent to the client together with every form.
sessionCookie :: IO FormParam
sessionCookie = do
sessionId <- getSessionId
clockTime <- getClockTime
return (FormCookie sessionCookieName (getId (sessionId))
[CookiePath "/",
CookieExpire (addMinutes sessionLifespan clockTime)])
----------------------------------------------------------------------------
-- Implementation of session stores.
--- The type of a session store that holds particular data used in a session.
--- A session store consists of list of data items for each session in the
--- system together with the clock time of the last access.
--- The clock time is used to remove old data in the store.
data SessionStore a = SStore [(SessionId, Int, a)]
--- An initial value for the empty session store.
emptySessionStore :: SessionStore _
emptySessionStore = SStore []
--- Retrieves data for the current user session stored in a session store.
getSessionData :: Global (SessionStore a) -> IO (Maybe a)
getSessionData sessionData = do
sid <- getSessionId
SStore sdata <- readGlobal sessionData
return (findInSession sid sdata)
where
findInSession si ((id, _, storedData):rest) =
if getId id == getId si
then Just storedData
else findInSession si rest
findInSession _ [] = Nothing
--- Stores data related to the current user session in a session store.
putSessionData :: a -> Global (SessionStore a) -> IO ()
putSessionData newData sessionData = do
sid <- getSessionId
SStore sdata <- readGlobal sessionData
currentTime <- getClockTime
case findIndex (\ (id, _, _) -> id == sid) sdata of
Just i ->
writeGlobal sessionData
(SStore (replace (sid, clockTimeToInt currentTime, newData) i
(cleanup currentTime sdata)))
Nothing ->
writeGlobal sessionData
(SStore ((sid, clockTimeToInt currentTime, newData)
: cleanup currentTime sdata))
--- Removes data related to the current user session from a session store.
removeSessionData :: Global (SessionStore a) -> IO ()
removeSessionData sessionData = do
sid <- getSessionId
SStore sdata <- readGlobal sessionData
currentTime <- getClockTime
writeGlobal sessionData
(SStore (filter (\ (id, _, _) -> id /= sid)
(cleanup currentTime sdata)))
-- expects that clockTimeToInt converts time into ascending integers!
-- we should write our own conversion-function
cleanup :: ClockTime -> [(SessionId, Int, a)] -> [(SessionId, Int, a)]
cleanup currentTime sessionData =
filter (\ (_, time, _) ->
time > clockTimeToInt (addMinutes (0-sessionLifespan) currentTime))
sessionData
--------------------------------------------------------------------------
......@@ -14,12 +14,10 @@ module System.SessionInfo (
getUserSessionInfo, updateUserSessionInfo
) where
import FilePath ( (</>) )
import Global
import HTML.Session
import Config.Spicey ( spiceyDataDir )
import System.Session
import Config.Storage
--------------------------------------------------------------------------
--- The data associated to a user session.
......@@ -44,17 +42,15 @@ 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 (spiceyDataDir </> "userSessionInfo"))
global emptySessionStore (Persistent (inDataDir "userSessionInfo"))
--- Gets the data of the current user session.
getUserSessionInfo :: IO UserSessionInfo
getUserSessionInfo =
getSessionData userSessionInfo >>= return . maybe emptySessionInfo id
getSessionData userSessionInfo emptySessionInfo
--- Updates the data of the current user session.
updateUserSessionInfo :: (UserSessionInfo -> UserSessionInfo) -> IO ()
updateUserSessionInfo upd = do
sd <- getUserSessionInfo
putSessionData (upd sd) userSessionInfo
updateUserSessionInfo = updateSessionData userSessionInfo emptySessionInfo
--------------------------------------------------------------------------
......@@ -4,16 +4,14 @@
--------------------------------------------------------------------------
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,
renderWuiForm, renderLabels,
getPage, wDateType, wBoolean, wUncheckMaybe, wFloat,
displayError, displayUrlError, cancelOperation,
renderWUI, renderLabels,
nextInProcessOr,
stringToHtml, maybeStringToHtml,
intToHtml,maybeIntToHtml, floatToHtml, maybeFloatToHtml,
......@@ -24,26 +22,24 @@ module System.Spicey (
saveLastUrl, getLastUrl, getLastUrls
) where
import Char (isSpace,isDigit)
import Char ( isSpace, isDigit )
import Global
import ReadNumeric
import ReadShowTerm(readsQTerm)
import System
import ReadShowTerm ( readsQTerm )
import Time
import Database.CDBI.Connection ( SQLResult )
import HTML.Base
import HTML.Session
import HTML.Styles.Bootstrap3
import WUI
import HTML.WUI
import Config.Storage
import Config.UserProcesses
import System.Routes
import System.Processes
import System.Session
import System.Authentication
---------------- vvvv -- Framework functions -- vvvv -----------------------
--------------------------------------------------------------------------
-- a viewable can be turned into a representation which can be displayed
-- as interface
-- here: a representation of a HTML page
......@@ -58,41 +54,49 @@ type ViewBlock = [HtmlExp]
--- Spicey.getControllerParams inside the controller.
type Controller = IO ViewBlock
--- The type class `EntityController` provides the application
--- of a controller to some entity identified by a key string.
class EntityController a where
controllerOnKey :: String -> (a -> Controller) -> Controller
--- Reads an entity for a given key and applies a controller to it.
applyControllerOn :: Maybe enkey -> (enkey -> IO en)
-> (en -> Controller) -> Controller
applyControllerOn Nothing _ _ = displayError "Illegal URL"
applyControllerOn Nothing _ _ = displayUrlError
applyControllerOn (Just userkey) getuser usercontroller =
getuser userkey >>= usercontroller
nextController :: Controller -> _ -> IO HtmlForm
nextController :: Controller -> _ -> IO HtmlPage
nextController controller _ = do
view <- controller
getForm view
getPage view
-- for WUIs
nextControllerForData :: (a -> Controller) -> a -> IO HtmlForm
nextControllerForData :: (a -> Controller) -> a -> IO HtmlPage
nextControllerForData controller param = do
view <- controller param
getForm view
getPage 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 ["list"]) [htxt "No"]]]
_ -> displayUrlError
--- A controller to execute a transaction and proceed with a given
--- controller if the transaction succeeds. Otherwise, the
......@@ -153,28 +157,22 @@ showControllerURL ctrlurl params = '?' : ctrlurl ++ concatMap ('/':) params
--------------------------------------------------------------------------
--- Standard rendering for WUI forms to edit data.
--- @param wuispec - the associated WUI specification
--- @param initdata - initial data to be prefilled in the form
--- @param ctrl - the controller that handles the submission of the data
--- @param cancelctrl - the controller called if submission is cancelled
--- @param sinfo - the UserSessionInfo to select the language
--- @param title - the title of the WUI form
--- @param buttontag - the text on the submit button
renderWuiForm :: WuiSpec a -> a -> (a -> Controller) -> Controller
-> String -> String -> [HtmlExp]
renderWuiForm wuispec initdata controller cancelcontroller title buttontag =
wuiframe hexp handler
where
wuiframe wuihexp hdlr =
[h1 [htxt title],
blockstyle "editform" [wuihexp],
wuiHandler2button buttontag hdlr `addClass` "btn btn-primary",
defaultButton "cancel"
(nextController (cancelOperation >> cancelcontroller))]
(hexp,handler) = wuiWithErrorForm wuispec
initdata
(nextControllerForData controller)
(\he whdlr -> getForm (wuiframe he whdlr))
--- @param cancelctrl - the controller called if submission is cancelled
--- @param envpar - environment parameters (e.g., user session data)
--- @param hexp - the HTML expression representing the WUI form
--- @param handler - the handler for submitting data
renderWUI :: UserSessionInfo -> String -> String -> Controller
-> a -> HtmlExp -> (CgiEnv -> Controller) -> [HtmlExp]
renderWUI _ title buttontag cancelctrl _ hexp handler =
[h1 [htxt title],
hexp,
breakline,
primButton buttontag (\env -> handler env >>= getPage),
defaultButton "Cancel" (nextController (cancelOperation >> cancelctrl))]
--- A WUI for manipulating CalendarTime entities.
--- It is based on a WUI for dates, i.e., the time is ignored.
......@@ -247,24 +245,22 @@ spiceyFooter =
htxt "Framework"]]
--- Transforms a view into an HTML form by adding the basic page layout.
getForm :: ViewBlock -> IO HtmlForm
getForm viewblock = case viewblock of
getPage :: ViewBlock -> IO HtmlPage
getPage viewblock = case viewblock of
[HtmlText ""] ->
return $ HtmlForm "forward to Spicey"
[formMetaInfo [("http-equiv","refresh"),
return $ HtmlPage "forward to Spicey"
[pageMetaInfo [("http-equiv","refresh"),
("content","1; url=spicey.cgi")]]
[par [htxt "You will be forwarded..."]]
_ -> do
routemenu <- getRouteMenu
msg <- getPageMessage
login <- getSessionLogin
lasturl <- getLastUrl
cookie <- sessionCookie
return (bootstrapForm "." ["bootstrap.min","spicey"] spiceyTitle
spiceyHomeBrand routemenu (rightTopMenu login)
0 [] [h1 [htxt spiceyTitle]]
(messageLine msg lasturl : viewblock ) spiceyFooter
`addFormParam` cookie)
routemenu <- getRouteMenu
msg <- getPageMessage
login <- getSessionLogin
lasturl <- getLastUrl
withSessionCookie $ bootstrapPage "." ["bootstrap.min","spicey"]
spiceyTitle spiceyHomeBrand routemenu (rightTopMenu login)
0 [] [h1 [htxt spiceyTitle]]
(messageLine msg lasturl : viewblock ) spiceyFooter
where
messageLine msg lasturl =
if null msg
......@@ -301,6 +297,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
......@@ -366,13 +366,13 @@ pageMessage = global emptySessionStore Temporary
--- Gets the page message and delete it.
getPageMessage :: IO String
getPageMessage = do
msg <- getSessionData pageMessage
msg <- getSessionData pageMessage ""
removeSessionData pageMessage
return (maybe "" id msg)
return msg
--- Set the page message of the current session.
setPageMessage :: String -> IO ()
setPageMessage msg = putSessionData msg pageMessage
setPageMessage msg = putSessionData pageMessage msg
--------------------------------------------------------------------------
-- Another example for using sessions.
......@@ -384,7 +384,7 @@ lastUrls = global emptySessionStore Temporary
--- Gets the list of URLs of the current session.
getLastUrls :: IO [String]
getLastUrls = getSessionData lastUrls >>= return . maybe [] id
getLastUrls = getSessionData lastUrls []
--- Gets the last URL of the current session (or "?").
getLastUrl :: IO String
......@@ -395,6 +395,6 @@ getLastUrl = do urls <- getLastUrls
saveLastUrl :: String -> IO ()
saveLastUrl url = do
urls <- getLastUrls
putSessionData (url:urls) lastUrls
putSessionData lastUrls (url:urls)
--------------------------------------------------------------------------
......@@ -9,20 +9,23 @@ module View.SpiceySystem
( loginView, processListView, historyView )
where
import HTML.Base
import HTML.Styles.Bootstrap3 (defaultButton, primButton)
import Config.UserProcesses
import System.Processes
import System.Spicey
import System.Authentication
-----------------------------------------------------------------------------
--- View for login/logout. If the passed login name is the empty string,
--- Generates a form for login/logout.
--- If the passed login name is the empty string,
--- we offer a login dialog, otherwise a logout dialog.
loginView :: Controller -> Maybe String -> [HtmlExp]
loginView controller currlogin =
case currlogin of
Nothing -> [h3 [htxt "Login as:"],
textfield loginfield "",
textField loginfield "",
defaultButton "Login" loginHandler]
Just _ -> [h3 [htxt "Really logout?"],
primButton "Logout" (logoutHandler True),
......@@ -37,12 +40,12 @@ loginView controller currlogin =
then done
else do loginToSession loginname
setPageMessage ("Logged in as: "++loginname)
nextInProcessOr controller Nothing >>= getForm
nextInProcessOr controller Nothing >>= getPage
logoutHandler confirm _ = do
if confirm then logoutFromSession >> setPageMessage "Logged out"
else done
nextInProcessOr controller Nothing >>= getForm
nextInProcessOr controller Nothing >>= getPage
-----------------------------------------------------------------------------
--- A view for all processes contained in a given process specification.
......
......@@ -7,10 +7,11 @@
"dependencies": {
"base" : ">= 1.0.0, < 2.0.0",
"cdbi" : ">= 2.0.0",
"html" : ">= 2.1.0",
"cryptohash" : ">= 0.0.1",
"html2" : ">= 0.0.1",
"random" : ">= 0.0.1",
"searchtree" : ">= 0.0.1",
"wui" : ">= 2.0.0"
"wui2" : ">= 0.0.1"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0",
......
This diff is collapsed.
......@@ -11,7 +11,7 @@ import Spicey.GenerationHelper
generateToHtml :: String -> [Entity] -> [Relationship] -> CurryProg
generateToHtml erdname allEntities relationships = simpleCurryProg
(entitiesToHtmlModule erdname)
["WUI", "HTML.Base", "Time", spiceyModule, erdname] -- imports
["Time", "HTML.Base", "HTML.WUI", spiceyModule, erdname] -- imports
[] -- typedecls
-- functions
(
......
......@@ -28,10 +28,6 @@ dbconn f = ("Database.CDBI.Connection", f)
html :: String -> QName
html f = ("HTML.Base", f)
--- Converts a string into a qualified name of the module "WUI".
wui :: String -> QName
wui f = ("WUI", f)
-- Some module names:
spiceyModule :: String
spiceyModule = "System.Spicey"
......@@ -43,9 +39,33 @@ authenticationModule = "System.Authentication"
authorizationModule :: String
authorizationModule = "System.Authorization"
--- Converts a name into a qualified name of the module "Global".
globalModule :: String -> QName
globalModule n = ("Global", n)
--- Converts a name into a qualified name of the module "HTML.Base".
htmlModule :: String -> QName
htmlModule n = ("HTML.Base", n)
--- Converts a name into a qualified name of the module "HTML.Session".
sessionModule :: String -> QName
sessionModule n = ("HTML.Session", n)
--- Converts a name into a qualified name of the module "Config.Storage".
storageModule :: String -> QName
storageModule n = ("Config.Storage", n)
--- Converts a name into a qualified name of the module "HTML.WUI".
wuiModule :: String -> QName
wuiModule n = ("HTML.WUI", n)
sessionInfoModule :: String
sessionInfoModule = "System.SessionInfo"
-- Type "UserSessionInfo"
userSessionInfoType :: CTypeExpr
userSessionInfoType = baseType (sessionInfoModule,"UserSessionInfo")
dataModuleName :: String
dataModuleName = "Config.RoutesData"
......@@ -147,6 +167,21 @@ 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 form for a given entity and form type.
controllerFormName :: String -> String -> QName
controllerFormName entityName formtype =
(controllerModuleName entityName, formtype ++ entityName ++ "Form")
--- The name of the controller store for a given entity and store type.
controllerStoreName :: String -> String -> QName
controllerStoreName entityName storetype =
(controllerModuleName entityName, storetype ++ entityName ++ "Store")
--- The name of the controller function for a given entity and controller
--- functionality.
controllerFunctionName :: String -> String -> QName
......@@ -267,9 +302,9 @@ combinator n
| n==1
= error "GenerationHelper.combinator: no combinator for list of length 1"
| n>14 = error "GenerationHelper.combinator: attribute list too long"
| n==2 = (wui "wPair")
| n==3 = (wui "wTriple")
| otherwise = (wui $ "w" ++ show n ++ "Tuple")
| n==2 = (wuiModule "wPair")
| n==3 = (wuiModule "wTriple")
| otherwise = (wuiModule $ "w" ++ show n ++ "Tuple")
-- Associate to each attribute of the argument list a WUI specification
-- as an abstract Curry program
......@@ -281,17 +316,17 @@ attrWidgets [] = []
widgetFor :: Domain -> Bool -> CExpr
widgetFor domain null =
case domain of
IntDom _ -> addMaybe (constF (wui "wInt"))
FloatDom _ -> addMaybe (constF (wui "wFloat"))
CharDom _ -> addMaybe (constF (wui "wString"))
IntDom _ -> addMaybe (constF (wuiModule "wInt"))
FloatDom _ -> addMaybe (constF (wuiModule "wFloat"))
CharDom _ -> addMaybe (constF (wuiModule "wString"))
StringDom _ -> if null then constF (spiceyModule,"wString")
else constF (wui "wRequiredString")
--constF (wui (if null then "wString" else "wRequiredString"))
BoolDom _ -> addMaybe (constF (wui "wBoolean"))
else constF (wuiModule "wRequiredString")
--constF (wuiModule (if null then "wString" else "wRequiredString"))
BoolDom _ -> addMaybe (constF (wuiModule "wBoolean"))
DateDom _ -> addMaybe (constF (spiceyModule, "wDateType"))
UserDefined _ _ -> addMaybe (applyF (wui "wCheckBool")
UserDefined _ _ -> addMaybe (applyF (wuiModule "wCheckBool")
[applyF (html "htxt") [string2ac ""]])
KeyDom _ -> addMaybe (constF (wui "wInt"))
KeyDom _ -> addMaybe (constF (wuiModule "wInt"))
_ -> error "widgetFor: unknown domain for attribute"
where
-- adds a Maybe WUI if null values are allowed
......@@ -304,3 +339,7 @@ widgetFor domain null =
(map (CLit . CIntc) [2018,1,1,0,0,0,0])])
domain, e]
else e
showQName :: QName -> String
showQName (mn,fn) = mn ++ "." ++ fn
......@@ -2,7 +2,7 @@
module Spicey.SpiceUp where
import Database.ERD ( ERD, readERDTermFile )
import Database.ERD ( ERD(..), Entity(..), readERDTermFile )
import Database.ERD.Goodies ( erdName, storeERDFromProgram )
import Directory
import Distribution ( installDir )
......@@ -16,7 +16,7 @@ import Spicey.Scaffolding
systemBanner :: String
systemBanner =
let bannerText = "Spicey Web Framework (Version " ++ packageVersion ++
" of 25/11/18)"
" of 21/10/19)"
bannerLine = take (length bannerText) (repeat '-')
in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine
......@@ -31,8 +31,9 @@ setFileMode fmode filename =
data DirTree =
Directory String [DirTree] -- a directory to be created
| ResourceFile FileMode String -- a file to be copied from resource directory
| ResourcePatchFile FileMode String (String->String) -- file to be copied from
-- resource directory where its contents is patched by the given function
| ResourcePatchFile FileMode String (ERD -> String -> String)
-- file to be copied from resource directory
-- where its contents is patched by the given function
| GeneratedFromERD (String -> ERD -> String -> String -> IO ())
-- takes an operation to generate code from ERD specification
......@@ -41,14 +42,12 @@ spiceyStructure pkgname =
Directory "." [
ResourceFile NoExec "README.txt",
ResourcePatchFile NoExec "package.json" (replacePackageName pkgname),
ResourcePatchFile NoExec "Makefile" replaceCurryBin,
ResourcePatchFile NoExec "Makefile" patchMakeFile,
Directory "src" [
ResourceFile NoExec "Main.curry",
Directory "System" [
ResourceFile NoExec "Spicey.curry",
ResourceFile NoExec "Routes.curry",
ResourceFile NoExec "Crypto.curry",
ResourceFile NoExec "Session.curry",
ResourceFile NoExec "SessionInfo.curry",
ResourceFile NoExec "Authorization.curry",
ResourceFile NoExec "Authentication.curry",
......@@ -64,7 +63,7 @@ spiceyStructure pkgname =
Directory "Model" [
GeneratedFromERD createModels ],
Directory "Config" [
ResourceFile NoExec $ "Config" </> "Spicey.curry",
ResourceFile NoExec $ "Config" </> "Storage.curry",
ResourceFile NoExec $ "Config" </> "UserProcesses.curry",
GeneratedFromERD createRoutes ]
],
......@@ -99,21 +98,27 @@ spiceyStructure pkgname =
]
]
-- Replace every occurrence of "XXXCURRYBINXXX" by installDir++"/bin"
replaceCurryBin :: String -> String
replaceCurryBin [] = []
replaceCurryBin (c:cs)
| c=='X' && take 13 cs == "XXCURRYBINXXX"
= installDir ++ "/bin" ++ replaceCurryBin (drop 13 cs)
| otherwise = c : replaceCurryBin cs
-- Replace every occurrence of `XXXCURRYHOMEXXX` by `installDir` and
-- every occurrince of `XXXICONTROLLERXXX` by
-- `-i <controllermod1> ... -i <controllermodn>`.
patchMakeFile :: ERD -> String -> String
patchMakeFile _ [] = []
patchMakeFile erd@(ERD _ entities _) (c:cs)
| c=='X' && take 14 cs == "XXCURRYHOMEXXX"
= installDir ++ patchMakeFile erd (drop 14 cs)
| c=='X' && take 16 cs == "XXICONTROLLERXXX"
= unwords (map (\ (Entity ename _) -> "-i Controller." ++ ename) entities) ++
patchMakeFile erd (drop 16 cs)
| otherwise
= c : patchMakeFile erd cs
-- Replace every occurrence of "XXXPKGNAMEXXX" by first argument
replacePackageName :: String -> String -> String
replacePackageName _ [] = []
replacePackageName pn (c:cs)
replacePackageName :: String -> ERD -> String -> String
replacePackageName _ _ [] = []
replacePackageName pn erd (c:cs)
| c=='X' && take 12 cs == "XXPKGNAMEXXX"
= pn ++ replacePackageName pn (drop 12 cs)
| otherwise = c : replacePackageName pn cs
= pn ++ replacePackageName pn erd (drop 12 cs)
| otherwise = c : replacePackageName pn erd cs
-- checks if given path exists (file or directory) and executes
-- given action if not
......@@ -137,14 +142,14 @@ createStructure target_path resource_dir _ _ _
system $ "cp \"" ++ infile ++ "\" \"" ++ targetfile ++ "\""
setFileMode fmode targetfile
createStructure target_path resource_dir _ _ _
createStructure target_path resource_dir erd _ _
(ResourcePatchFile fmode filename f) = do
let full_path = target_path </> filename
ifNotExistsDo full_path $ do
putStrLn ("Creating file '" ++ full_path ++ "'...")
cnt <- readFile (resource_dir </> filename)
let outfile = target_path </> filename
writeFile outfile (f cnt)
writeFile outfile (f erd cnt)
setFileMode fmode outfile
createStructure target_path resource_dir erd termfile db_path
......
This diff is collapsed.