Commit 632cbf7d authored by Michael Hanus 's avatar Michael Hanus

Package adapted to html2-1.0.0

parent 36333ef3
{
"name": "spicey",
"version": "3.3.0",
"version": "3.4.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "A web application framework for Curry",
"category": [ "Web", "Database" ],
......
......@@ -8,10 +8,10 @@
"base" : ">= 1.0.0, < 2.0.0",
"cdbi" : ">= 2.0.0",
"cryptohash" : ">= 0.0.1",
"html2" : ">= 0.0.1, < 1.0.0",
"html2" : ">= 1.0.0, < 2.0.0",
"random" : ">= 0.0.1",
"searchtree" : ">= 0.0.1",
"wui2" : ">= 0.0.1, < 1.0.0"
"wui2" : ">= 1.0.0, < 2.0.0"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0, < 3.0.0",
......
......@@ -27,8 +27,8 @@ import View.SpiceySystem
loginController :: Controller
loginController = do
login <- getSessionLogin
putSessionData loginViewData login
return [formExp loginFormDef]
writeSessionData loginViewData login
return [formElem loginFormDef]
loginFormDef :: HtmlFormDef (Maybe String)
loginFormDef = formDefWithID "Controller.SpiceySystem.loginFormDef"
......
......@@ -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 = getUserSessionInfo >>= return . userLoginOfSession
getSessionLogin = liftM userLoginOfSession getUserSessionInfo
--- Stores a login name in the current session.
--- The authentication has to be done before!
......
......@@ -47,20 +47,20 @@ currentProcess = global emptySessionStore Temporary
--- Returns the process state stored in the user session.
getCurrentProcess :: IO (Maybe _)
getCurrentProcess = do
curProc <- getSessionMaybeData currentProcess
curProc <- fromFormReader $ getSessionMaybeData currentProcess
case curProc of
Just sids -> return $ Just (readQTerm sids)
Nothing -> return Nothing
--- Is the current user session in a process interaction?
isInProcess :: IO Bool
isInProcess =
isInProcess = fromFormReader $
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 currentProcess (showQTerm sid)
saveCurrentProcess sid = writeSessionData currentProcess (showQTerm sid)
--- Deletes the process in the user session.
removeCurrentProcess :: IO ()
......@@ -68,7 +68,7 @@ removeCurrentProcess = removeSessionData currentProcess
--- Starts a new process with a given name. In the next step, the
--- controller of the start state of the process is executed.
startProcess :: String -> IO [HtmlExp]
startProcess :: String -> IO [BaseHtml]
startProcess pname =
maybe (return [htxt $ "startProcess: process not found: " ++ pname])
(\state -> do saveCurrentProcess state
......
......@@ -40,19 +40,18 @@ getControllerReference url = getRoutes >>= return . findControllerReference
--- each page. As a default, all routes specified with URL matcher
--- `Exact` in the module RouteData, except for "login",
--- are taken as menu entries.
getRouteMenu :: IO [[HtmlExp]]
getRouteMenu :: IO [[BaseHtml]]
getRouteMenu = do
routes <- getRoutes
return $ getLinks routes
where
getLinks :: [Route] -> [[HtmlExp]]
getLinks ((name, matcher, _):restroutes) =
case matcher of
Exact string -> if string == "login"
then getLinks restroutes
else [(hrefNav ("?" ++ string) [htxt name])] :
getLinks restroutes
Prefix s1 s2 -> [hrefNav ("?"++s1++"/"++s2) [htxt name]] :
getLinks restroutes
_ -> getLinks restroutes
getLinks [] = []
getLinks [] = []
getLinks ((name, matcher, _) : restroutes) =
case matcher of
Exact string -> if string == "login"
then getLinks restroutes
else [(hrefNav ("?" ++ string) [htxt name])] :
getLinks restroutes
Prefix s1 s2 -> [hrefNav ("?"++s1++"/"++s2) [htxt name]] :
getLinks restroutes
_ -> getLinks restroutes
......@@ -16,6 +16,7 @@ module System.SessionInfo (
import Global
import HTML.Base ( fromFormReader )
import HTML.Session
--------------------------------------------------------------------------
......@@ -46,10 +47,10 @@ userSessionInfo =
--- Gets the data of the current user session.
getUserSessionInfo :: IO UserSessionInfo
getUserSessionInfo =
getSessionData userSessionInfo emptySessionInfo
fromFormReader $ getSessionData userSessionInfo emptySessionInfo
--- Updates the data of the current user session.
updateUserSessionInfo :: (UserSessionInfo -> UserSessionInfo) -> IO ()
updateUserSessionInfo = updateSessionData userSessionInfo emptySessionInfo
updateUserSessionInfo = modifySessionData userSessionInfo emptySessionInfo
--------------------------------------------------------------------------
......@@ -47,7 +47,7 @@ import System.Authentication
-- here: a representation of a HTML page
type Viewable = HtmlPage
type ViewBlock = [HtmlExp]
type ViewBlock = [BaseHtml]
--- Controllers contains all logic and their result should be a Viewable.
--- if the behavior of controller should depend on URL parameters
......@@ -90,7 +90,7 @@ applyControllerOn (Just userkey) getuser usercontroller =
--- A controller to redirect to an URL starting with "?"
--- (see implementation of `getPage`).
redirectController :: String -> Controller
redirectController url = return [HtmlText url]
redirectController url = return [htmlText url]
nextController :: Controller -> _ -> IO HtmlPage
nextController controller _ = do
......@@ -258,11 +258,11 @@ spiceyTitle :: String
spiceyTitle = "Spicey Application"
--- The home URL and brand shown at the left top of the main page.
spiceyHomeBrand :: (String, [HtmlExp])
spiceyHomeBrand :: (String, [BaseHtml])
spiceyHomeBrand = ("?", [htxt " Home"])
--- The standard footer of the Spicey page.
spiceyFooter :: [HtmlExp]
spiceyFooter :: [BaseHtml]
spiceyFooter =
[par [htxt "powered by",
href "http://www.informatik.uni-kiel.de/~pakcs/spicey"
......@@ -275,8 +275,8 @@ spiceyFooter =
--- generates a redirection page.
getPage :: ViewBlock -> IO HtmlPage
getPage viewblock = case viewblock of
[HtmlText ""] -> return $ redirectPage "spicey.cgi"
[HtmlText ('?':route)] -> return $ redirectPage ('?':route)
[BaseText ""] -> return $ redirectPage "spicey.cgi"
[BaseText ('?':route)] -> return $ redirectPage ('?':route)
_ -> do
routemenu <- getRouteMenu
msg <- getPageMessage
......@@ -285,20 +285,21 @@ getPage viewblock = case viewblock of
withSessionCookie $ bootstrapPage favIcon cssIncludes jsIncludes
spiceyTitle spiceyHomeBrand routemenu (rightTopMenu login)
0 [] [h1 [htxt spiceyTitle]]
(messageLine msg lasturl : viewblock ) spiceyFooter
(messageLine msg lasturl : viewblock)
spiceyFooter
where
messageLine msg lasturl =
if null msg
then HtmlStruct "header" [("class","pagemessage pagemessage-empty")]
[htxt ("Last page: "++lasturl)]
else HtmlStruct "header" [("class","pagemessage")] [htxt msg]
then htmlStruct "header" [("class","pagemessage pagemessage-empty")]
[htxt ("Last page: " ++ lasturl)]
else htmlStruct "header" [("class","pagemessage")] [htxt msg]
rightTopMenu login =
[[hrefNav "?login" (maybe [htxt "Login"]
(\n -> [ htxt "Logout"
, htxt $ " (" ++ n ++ ")"
])
login)]]
login)]]
favIcon :: String
favIcon = "bt4" </> "img" </> "favicon.ico"
......@@ -346,48 +347,48 @@ renderLabels labels hexps =
enlargeInput h = h `addClass` "input-xxlarge"
-- Convert standard datatype values to HTML representation
stringToHtml :: String -> HtmlExp
stringToHtml :: HTML h => String -> h
stringToHtml s = textstyle "type_string" s
maybeStringToHtml :: Maybe String -> HtmlExp
maybeStringToHtml :: HTML h => Maybe String -> h
maybeStringToHtml s = textstyle "type_string" (maybe "" id s)
intToHtml :: Int -> HtmlExp
intToHtml :: HTML h => Int -> h
intToHtml i = textstyle "type_int" (show i)
maybeIntToHtml :: Maybe Int -> HtmlExp
maybeIntToHtml :: HTML h => Maybe Int -> h
maybeIntToHtml i = textstyle "type_int" (maybe "" show i)
floatToHtml :: Float -> HtmlExp
floatToHtml :: HTML h => Float -> h
floatToHtml i = textstyle "type_float" (show i)
maybeFloatToHtml :: Maybe Float -> HtmlExp
maybeFloatToHtml :: HTML h => Maybe Float -> h
maybeFloatToHtml i = textstyle "type_float" (maybe "" show i)
boolToHtml :: Bool -> HtmlExp
boolToHtml :: HTML h => Bool -> h
boolToHtml b = textstyle "type_bool" (show b)
maybeBoolToHtml :: Maybe Bool -> HtmlExp
maybeBoolToHtml :: HTML h => Maybe Bool -> h
maybeBoolToHtml b = textstyle "type_bool" (maybe "" show b)
dateToHtml :: ClockTime -> HtmlExp
dateToHtml :: HTML h => ClockTime -> h
dateToHtml ct = textstyle "type_calendartime" (toDayString (toUTCTime ct))
maybeDateToHtml :: Maybe ClockTime -> HtmlExp
maybeDateToHtml :: HTML h => Maybe ClockTime -> h
maybeDateToHtml ct =
textstyle "type_calendartime" (maybe "" (toDayString . toUTCTime) ct)
userDefinedToHtml :: Show a => a -> HtmlExp
userDefinedToHtml :: (Show a, HTML h) => a -> h
userDefinedToHtml ud = textstyle "type_string" (show ud)
maybeUserDefinedToHtml :: Show a => Maybe a -> HtmlExp
maybeUserDefinedToHtml :: (Show a, HTML h) => Maybe a -> h
maybeUserDefinedToHtml ud = textstyle "type_string" (maybe "" show ud)
--------------------------------------------------------------------------
-- Auxiliary HTML items:
--- Standard table in Spicey.
spTable :: [[[HtmlExp]]] -> HtmlExp
spTable :: HTML h => [[[h]]] -> h
spTable items = table items `addClass` "table table-hover table-condensed"
--------------------------------------------------------------------------
......@@ -403,13 +404,13 @@ pageMessage =
--- Gets the page message and delete it.
getPageMessage :: IO String
getPageMessage = do
msg <- getSessionData pageMessage ""
msg <- fromFormReader $ getSessionData pageMessage ""
removeSessionData pageMessage
return msg
--- Set the page message of the current session.
setPageMessage :: String -> IO ()
setPageMessage msg = putSessionData pageMessage msg
setPageMessage msg = writeSessionData pageMessage msg
--------------------------------------------------------------------------
-- Another example for using sessions.
......@@ -421,7 +422,7 @@ lastUrls = global emptySessionStore (Persistent (inSessionDataDir "lastUrls"))
--- Gets the list of URLs of the current session.
getLastUrls :: IO [String]
getLastUrls = getSessionData lastUrls []
getLastUrls = fromFormReader $ getSessionData lastUrls []
--- Gets the last URL of the current session (or "?").
getLastUrl :: IO String
......@@ -432,6 +433,6 @@ getLastUrl = do urls <- getLastUrls
saveLastUrl :: String -> IO ()
saveLastUrl url = do
urls <- getLastUrls
putSessionData lastUrls (url:urls)
writeSessionData lastUrls (url:urls)
--------------------------------------------------------------------------
......@@ -48,7 +48,7 @@ loginView currlogin =
-----------------------------------------------------------------------------
--- A view for all processes contained in a given process specification.
processListView :: Processes a -> [HtmlExp]
processListView :: Processes a -> [BaseHtml]
processListView procs =
[h1 [htxt "Processes"],
ulist (map processColumn (zip (processNames procs) [1..]))]
......@@ -58,7 +58,7 @@ processListView procs =
-----------------------------------------------------------------------------
--- A view for all URLs of a session.
historyView :: [String] -> [HtmlExp]
historyView :: [String] -> [BaseHtml]
historyView urls =
[h1 [htxt "History"],
ulist (map (\url -> [href ("?"++url) [htxt url]])
......
......@@ -20,8 +20,7 @@ defCtrlModName :: String
defCtrlModName = "Controller.DefaultController"
-- "main"-function
generateControllersForEntity :: String -> [Entity] -> Entity
-> [Relationship]
generateControllersForEntity :: String -> [Entity] -> Entity -> [Relationship]
-> CurryProg
generateControllersForEntity erdname allEntities
entity@(Entity ename attrlist) relationships =
......@@ -165,7 +164,7 @@ newController erdname (Entity entityName attrList) relationships allEntities =
else []) ++
[CSExpr setParCall,
CSExpr $ applyF (pre "return")
[list2ac [applyF (html "formExp")
[list2ac [applyF (html "formElem")
[constF (controllerFormName entityName "new")]]]
])]]
where
......@@ -374,7 +373,7 @@ editController erdname (Entity entityName attrList) relationships allEntities =
(zip manyToManyEntities [1..]) ++
[CSExpr setParCall,
CSExpr $ applyF (pre "return")
[list2ac [applyF (html "formExp")
[list2ac [applyF (html "formElem")
[constF (controllerFormName entityName "edit")]]]
])])]
where
......
......@@ -15,14 +15,16 @@ generateToHtml erdname allEntities relationships = simpleCurryProg
[] -- typedecls
-- functions
(
foldr1 (++) (map (\e -> generateToHtmlForEntity erdname allEntities e relationships)
(filter (not . Spicey.GenerationHelper.isGenerated)
allEntities))
foldr1 (++)
(map (\e -> generateToHtmlForEntity erdname allEntities e relationships)
(filter (not . Spicey.GenerationHelper.isGenerated)
allEntities))
)
[]
generateToHtmlForEntity :: String -> [Entity] -> Entity -> [Relationship] -> [CFuncDecl]
generateToHtmlForEntity :: String -> [Entity] -> Entity -> [Relationship]
-> [CFuncDecl]
generateToHtmlForEntity erdname allEntities (Entity ename attrlist) relationships =
[toListView erdname (Entity ename (filter noKeyAttr attrlist)) relationships allEntities,
toShortView erdname (Entity ename (filter noKeyAttr attrlist)) relationships allEntities,
......@@ -30,19 +32,19 @@ generateToHtmlForEntity erdname allEntities (Entity ename attrlist) relationship
labelList erdname (Entity ename (filter noKeyAttr attrlist)) relationships allEntities
]
where
noKeyAttr a = (notKey a) && (notPKey a)
noKeyAttr a = (notKey a) && (notPKey a)
type ToHtmlGenerator = String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
toListView :: ToHtmlGenerator
toListView erdname (Entity entityName attrlist) _ _ =
stCmtFunc
cmtfunc
("The list view of a "++entityName++" entity in HTML format.\n"++
"This view is used in a row of a table of all entities.")
(thisModuleName erdname, (lowerFirst entityName)++"ToListView") 2 Public
(baseType (erdname, entityName)
~> listType (listType (baseType (html "HtmlExp"))))
(thisModuleName erdname, lowerFirst entityName ++ "ToListView") 2 Public
(withHTMLContext
(baseType (erdname, entityName) ~> listType (listType htmlTVar)))
[simpleRule [CPVar (1, lowerFirst entityName)]
(list2ac (
(map (\a -> list2ac [
......@@ -92,19 +94,20 @@ toDetailsView erdname (Entity entityName attrlist) relationships allEntities =
eName = lowerFirst entityName
evar = (1,eName)
in
stCmtFunc
("The detailed view of a "++entityName++" entity in HTML format.\n"++
cmtfunc
("The detailed view of a " ++ entityName ++ " entity in HTML format.\n" ++
if null (manyToOneEntities ++ manyToManyEntities) then "" else
"It also takes associated entities for every associated entity type.")
(thisModuleName erdname, (lowerFirst entityName)++"ToDetailsView")
(thisModuleName erdname, lowerFirst entityName ++ "ToDetailsView")
2
Public
-- function type
(foldr CFuncType (listType (baseType (html "HtmlExp")))
([baseType (erdname, entityName)] ++
(map ctvar manyToOneEntities) ++ -- defaults for n:1
(map (\name -> listType (ctvar name)) manyToManyEntities)
)
(withHTMLContext $
foldr CFuncType (listType htmlTVar)
([baseType (erdname, entityName)] ++
(map ctvar manyToOneEntities) ++ -- defaults for n:1
(map (\name -> listType (ctvar name)) manyToManyEntities)
)
)
[CRule
( -- parameters
......@@ -163,23 +166,23 @@ labelList erdname (Entity entityName attrlist) relationships allEntities =
manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
manyToOneEntities = manyToOne (Entity entityName attrlist) relationships
in
stCmtFunc
cmtfunc
("The labels of a "++entityName++" entity, as used in HTML tables.")
(thisModuleName erdname, (lowerFirst entityName)++"LabelList") 2 Public
(
listType (listType (baseType (html "HtmlExp")))
)
(withHTMLContext (listType (listType htmlTVar)))
[simpleRule []
(list2ac (
(map (\ (Attribute name domain _ _) ->
list2ac [applyF (html "textstyle")
[string2ac ("spicey_label spicey_label_for_type_"++
domainToString domain),
string2ac name]])
list2ac
[applyF (html "textstyle")
[string2ac ("spicey_label spicey_label_for_type_"++
domainToString domain),
string2ac name]])
attrlist) ++
(map (\s -> list2ac [applyF (html "textstyle")
[string2ac "spicey_label spicey_label_for_type_relation",
string2ac s]])
(map (\s -> list2ac
[applyF (html "textstyle")
[string2ac "spicey_label spicey_label_for_type_relation",
string2ac s]])
(manyToOneEntities++manyToManyEntities))
)
)]
......
......@@ -208,9 +208,17 @@ viewFunctionName :: String -> String -> QName
viewFunctionName entityName viewFunction =
(viewModuleName entityName, viewFunction ++ entityName ++ "View")
--- The type of view blocks, i.e., `[BaseHtml]`.
viewBlockType :: CTypeExpr
viewBlockType = listType (baseType (html "HtmlExp"))
viewBlockType = listType (baseType (html "BaseHtml"))
-- Attach the type class `HTML` with type variable to a type expression.
withHTMLContext :: CTypeExpr -> CQualTypeExpr
withHTMLContext = CQualType (CContext [(html "HTML", htmlTVar)])
-- The type variable `h` used to `HTML` types in type expressions.
htmlTVar :: CTypeExpr
htmlTVar = CTVar (0,"h")
attrType :: Attribute -> CTypeExpr
attrType (Attribute _ t k False) =
......
......@@ -16,7 +16,7 @@ import Spicey.Scaffolding
systemBanner :: String
systemBanner =
let bannerText = "Spicey Web Framework (Version " ++ packageVersion ++
" of 31/07/20)"
" of 26/09/20)"
bannerLine = take (length bannerText) (repeat '-')
in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine
......
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