Commit b3978372 authored by Michael Hanus 's avatar Michael Hanus
Browse files

Resource files restructured, redirection controllers added, type class for routing added

parent 4cb7d355
......@@ -22,7 +22,6 @@ import HTML.Session
import System.Processes
import System.Authentication
import View.SpiceySystem
import Controller.DefaultController
-----------------------------------------------------------------------------
--- Controller for login/logout.
......@@ -33,10 +32,8 @@ loginController = do
return [formExp loginFormDef]
loginFormDef :: HtmlFormDef (Maybe String)
loginFormDef =
formDefWithID "Controller.SpiceySystem.loginFormDef"
(getSessionData loginViewData Nothing)
(loginView defaultController)
loginFormDef = formDefWithID "Controller.SpiceySystem.loginFormDef"
(getSessionData loginViewData Nothing) loginView
--- The data processed by the login form.
loginViewData :: Global (SessionStore (Maybe String))
......
......@@ -15,9 +15,10 @@ module System.SessionInfo (
) where
import Global
import HTML.Session
import Config.Storage
import Config.Storage ( inDataDir )
--------------------------------------------------------------------------
--- The data associated to a user session.
......
......@@ -4,7 +4,9 @@
--------------------------------------------------------------------------
module System.Spicey (
Controller, EntityController(..), applyControllerOn,
Controller, EntityController(..), showRoute, editRoute, deleteRoute,
applyControllerOn,
redirectController,
nextController, nextControllerForData,
confirmDeletionPage,
transactionController,
......@@ -54,11 +56,29 @@ 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.
--- The type class `EntityController` contains:
--- * the application of a controller to some entity identified by a key string
--- * an operation to construct a URL route for an entity w.r.t. to a route
--- string
class EntityController a where
controllerOnKey :: String -> (a -> Controller) -> Controller
entityRoute :: String -> a -> String
--- Returns the URL route to show a given entity.
showRoute :: EntityController a => a -> String
showRoute = entityRoute "show"
--- Returns the URL route to edit a given entity.
editRoute :: EntityController a => a -> String
editRoute = entityRoute "edit"
--- Returns the URL route to delete a given entity.
deleteRoute :: EntityController a => a -> String
deleteRoute = entityRoute "delete"
--- Reads an entity for a given key and applies a controller to it.
applyControllerOn :: Maybe enkey -> (enkey -> IO en)
......@@ -67,6 +87,11 @@ applyControllerOn Nothing _ _ = displayUrlError
applyControllerOn (Just userkey) getuser usercontroller =
getuser userkey >>= usercontroller
--- A controller to redirect to an URL starting with "?"
--- (see implementation of `getPage`).
redirectController :: String -> Controller
redirectController url = return [HtmlText url]
nextController :: Controller -> _ -> IO HtmlPage
nextController controller _ = do
view <- controller
......@@ -160,18 +185,18 @@ showControllerURL ctrlurl params = '?' : ctrlurl ++ concatMap ('/':) params
--- @param sinfo - the UserSessionInfo to select the language
--- @param title - the title of the WUI form
--- @param buttontag - the text on the submit button
--- @param cancelctrl - the controller called if submission is cancelled
--- @param cancelurl - the URL selected 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
renderWUI :: UserSessionInfo -> String -> String -> String
-> a -> HtmlExp -> (CgiEnv -> Controller) -> [HtmlExp]
renderWUI _ title buttontag cancelctrl _ hexp handler =
renderWUI _ title buttontag cancelurl _ hexp handler =
[h1 [htxt title],
hexp,
breakline,
primButton buttontag (\env -> handler env >>= getPage),
defaultButton "Cancel" (nextController (cancelOperation >> cancelctrl))]
hrefButton cancelurl [htxt "Cancel"]]
--- A WUI for manipulating CalendarTime entities.
......@@ -243,15 +268,14 @@ spiceyFooter =
[image "images/spicey-logo.png" "Spicey"]
`addAttr` ("target","_blank"),
htxt "Framework"]]
--- Transforms a view into an HTML form by adding the basic page layout.
--- If the view is an empty text or a text starting with "?",
--- generates a redirection page.
getPage :: ViewBlock -> IO HtmlPage
getPage viewblock = case viewblock of
[HtmlText ""] ->
return $ HtmlPage "forward to Spicey"
[pageMetaInfo [("http-equiv","refresh"),
("content","1; url=spicey.cgi")]]
[par [htxt "You will be forwarded..."]]
[HtmlText ""] -> return $ redirectPage "spicey.cgi"
[HtmlText ('?':route)] -> return $ redirectPage ('?':route)
_ -> do
routemenu <- getRouteMenu
msg <- getPageMessage
......@@ -361,7 +385,7 @@ spTable items = table items `addClass` "table table-hover table-condensed"
--- Definition of the session state to store the page message (a string).
pageMessage :: Global (SessionStore String)
pageMessage = global emptySessionStore Temporary
pageMessage = global emptySessionStore (Persistent (inDataDir "pageMessage"))
--- Gets the page message and delete it.
getPageMessage :: IO String
......@@ -380,7 +404,7 @@ setPageMessage msg = putSessionData pageMessage msg
--- Definition of the session state to store the last URL (as a string).
lastUrls :: Global (SessionStore [String])
lastUrls = global emptySessionStore Temporary
lastUrls = global emptySessionStore (Persistent (inDataDir "lastUrls"))
--- Gets the list of URLs of the current session.
getLastUrls :: IO [String]
......
......@@ -10,7 +10,7 @@ module View.SpiceySystem
where
import HTML.Base
import HTML.Styles.Bootstrap3 (defaultButton, primButton)
import HTML.Styles.Bootstrap3 (defaultButton, hrefButton, primButton)
import Config.UserProcesses
import System.Processes
......@@ -21,15 +21,15 @@ import System.Authentication
--- 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 =
loginView :: Maybe String -> [HtmlExp]
loginView currlogin =
case currlogin of
Nothing -> [h3 [htxt "Login as:"],
textField loginfield "",
defaultButton "Login" loginHandler]
Just _ -> [h3 [htxt "Really logout?"],
primButton "Logout" (logoutHandler True),
defaultButton "Cancel" (logoutHandler False)]
primButton "Logout" logoutHandler,
hrefButton "?" [htxt "Cancel"]]
where
loginfield free
......@@ -40,12 +40,11 @@ loginView controller currlogin =
then done
else do loginToSession loginname
setPageMessage ("Logged in as: "++loginname)
nextInProcessOr controller Nothing >>= getPage
nextInProcessOr (redirectController "?") Nothing >>= getPage
logoutHandler confirm _ = do
if confirm then logoutFromSession >> setPageMessage "Logged out"
else done
nextInProcessOr controller Nothing >>= getPage
logoutHandler _ = do
logoutFromSession >> setPageMessage "Logged out"
nextInProcessOr (redirectController "?") Nothing >>= getPage
-----------------------------------------------------------------------------
--- A view for all processes contained in a given process specification.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment