...
 
Commits (5)
Installation of smap at
Installation of Smap at
=======================
http://www-ps.informatik.uni-kiel.de/smap/
http://smap.informatik.uni-kiel.de/
--------------------------------------
Installation directory: /var/www/smap
Old installation:
-----------------
http://www-ps.informatik.uni-kiel.de/smap/ (forwarded to actual installation)
The old implementation based on html1 is still available at
http://www-ps.informatik.uni-kiel.de/smap/smap1
(only for testing purposes, without actual data)
- Installation directory on giscours (alias www-ps):
/srv/sites/informatik.uni-kiel.de/www-ps/htdocs/smap
......
# Generic Makefile for Spicey applications
# Definition of the root of the Curry system to be used:
SYSTEM=/home/mh/pakcs
#SYSTEM=/opt/kics2/kics2
# 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:
WEBSERVERDIR=$(HOME)/public_html/smap
# Definition of the Curry installation bin directory to be used:
export CURRYBIN=/opt/pakcs/bin
#export CURRYBIN=/opt/kics2/bin
# Executable of the Curry Package Manager CPM:
CPM := $(CURRYBIN)/cypm
# 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)
# Executable of the curry2cgi:
CURRY2CGI := $(shell which curry2cgi)
############################################################################
......@@ -34,15 +33,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
......@@ -66,12 +59,21 @@ run:
.PHONY: deploy
deploy: checkdeploy
mkdir -p $(WEBSERVERDIR)
$(CPM) exec $(MAKECGI) --standalone -m main -o $(WEBSERVERDIR)/smap.cgi Main.curry
$(MAKE) $(WEBSERVERDIR)/smap.cgi
# copy other files (style sheets, images,...)
cp -r public/* $(WEBSERVERDIR)
chmod -R go+rX $(WEBSERVERDIR)
mkdir -p $(WEBSERVERDIR)/data # create private data dir
chmod 700 $(WEBSERVERDIR)/data
cp -p data/htaccess $(WEBSERVERDIR)/data/.htaccess # and make it private
chmod -R go+rX $(WEBSERVERDIR)
$(WEBSERVERDIR)/smap.cgi: src/*.curry src/*/*.curry
$(CPM) exec $(CURRY2CGI) --system="$(SYSTEM)" \
-i Controller.Admin \
-i Controller.AuthN \
-i Controller.Browser \
-i Controller.SmapIE \
-o $@ Main.curry
# clean up generated the package directory
.PHONY: clean
......@@ -82,4 +84,4 @@ clean:
# database files first!)
.PHONY: cleanall
cleanall: clean
/bin/rm -rf $(WEBSERVERDIR)
/bin/rm -f $(WEBSERVERDIR)/smap.cgi*
Some things to be done for Smap:
- Admin can
- see/edit users
- edit users
{
"name": "Smap",
"version": "1.0.0",
"version": "1.1.0",
"author": "Lasse Kristopher Meyer, Michael Hanus <mh@informatik.uni-kiel.de>",
"maintainer": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Web application 'Smap' generated by Spicey",
......@@ -8,12 +8,11 @@
"dependencies": {
"base" : ">= 1.0.0, < 2.0.0",
"cdbi" : ">= 2.0.0",
"html" : ">= 2.1.0",
"html2" : ">= 0.0.1",
"mail-utils" : ">= 2.0.0",
"random" : ">= 0.0.1",
"setfunctions" : ">= 0.0.1",
"socket" : ">= 0.0.1",
"wui" : ">= 2.0.0"
"socket" : ">= 0.0.1"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0, < 3.0.0",
......
......@@ -561,6 +561,7 @@ label {
position: absolute;
}
.dropdown-menu > li > input,
.dropdown-menu > li > button {
border: none;
display: block;
......@@ -577,6 +578,7 @@ label {
/* -- Rendering submit buttons in dropdown menus as hyperlinks -- */
.dropdown-menu > li > input:hover,
.dropdown-menu > li > button:hover,
.dropdown-menu > li > button:focus {
background-color: #e8e8e8;
......@@ -587,6 +589,7 @@ label {
text-decoration: none;
}
.dropdown-menu > .active > input,
.dropdown-menu > .active > button,
.dropdown-menu > .active > button:hover,
.dropdown-menu > .active > button:focus {
......@@ -599,6 +602,7 @@ label {
text-decoration: none;
}
.dropdown-menu > .disabled > input,
.dropdown-menu > .disabled > button,
.dropdown-menu > .disabled > button:hover,
.dropdown-menu > .disabled > button:focus {
......@@ -1072,4 +1076,4 @@ label {
margin-bottom: 0;
}
/* -------------------------------------------------------------------------- */
\ No newline at end of file
/* -------------------------------------------------------------------------- */
......@@ -10,7 +10,7 @@ or keywords occurring in the title, decsription, or tags.
<p>
</p>
Once you found an interesting program, you can open it
in the browser or with [SmapIE](help-02) in order to execute and play with them.
in the browser or with [SmapIE](help-02) in order to execute and play with it.
If you open a program in the browser, you see more details
like a short description or the source code.
<p>
......
......@@ -18,13 +18,13 @@ languages, Smap currently supports the following languages:
For PAKCS, you can select between two systems: one computes
all values of the initial expression <tt>main</tt> and the other one
computes only the first value of the initial expression.
KiCS2 always computes all values of the initial expression
<tt>main</tt>.
KiCS2 can be used in a similar manner but has long execution
times (which might cause a time out).
Note that initial expressions of type <tt>IO</tt>
are not allowed in all systems.
</li>
<li>
<b>Haskell</b>: Functionnal programs written in Haskell are executed by
<b>Haskell</b>: Functional programs written in Haskell are executed by
<tt>runghc</tt>, which is part of the Glasgow Haskell Compiler.
Note that initial expressions <tt>main</tt> of type <tt>IO</tt>
are not allowed.
......@@ -37,5 +37,5 @@ languages, Smap currently supports the following languages:
</ul>
<p>
If you are are interested in the support for other languages,
please contact the Smap administrator.
please contact the Smap maintainer.
</p>
......@@ -4,7 +4,7 @@ What is Smap?
Smap (a portmanteau for "<b>sma</b>ll <b>p</b>rograms") is primarily
an interactive source code editor that lets you write programs and
execute them online in various programming languages. In addition, Smap
allows you to save and manage your creations and make them available
allows you to save and manage your programs and make them available
to other users.
For these purposes Smap provides two core components:
the [SmapIE](help-02) and the [Browser](help-03).
......
......@@ -25,7 +25,7 @@ main = runServiceAsCGI executeWithGHC
--- Paths to required binaries.
runghc :: String
runghc = "/opt/ghc/8.4.3/bin/runghc"
runghc = "/opt/ghc/bin/runghc"
timeout :: String
timeout = "/usr/bin/timeout"
......@@ -51,7 +51,7 @@ timeLimit = "5"
executeWithGHC :: String -> String -> IO String
executeWithGHC urlparam inputprog = do
pid <- getPID
let execDir = "tmpGHCEXEC_"++show pid
let execDir = "tmpGHCEXEC_" ++ show pid
prog = if null inputprog && not (null urlparam)
then urlencoded2string urlparam
else inputprog
......@@ -59,8 +59,8 @@ executeWithGHC urlparam inputprog = do
fileName = maybe "Prog" id modName ++ ".hs"
moduleHeader = maybe "module Prog where\n\n" (const "") modName
mainProg = let mname = maybe "Prog" id modName
in "import qualified "++mname++
"\n\nmain = print "++mname++".main\n"
in "import qualified " ++ mname ++
"\n\nmain = print " ++ mname ++ ".main\n"
currDir <- getCurrentDirectory
setEnviron "HOME" currDir -- since GHC requires HOME for getAppUserDataDirectory
createDirectoryIfMissing True execDir
......@@ -73,7 +73,7 @@ executeWithGHC urlparam inputprog = do
[timeLimit,runghc,"Main.hs"]
""
setCurrentDirectory currDir
system $ "/bin/rm -r "++execDir
system $ "/bin/rm -r " ++ execDir
return $ parseResult result
......@@ -82,11 +82,11 @@ executeWithGHC urlparam inputprog = do
--- @param result - exit status, stdin content and stderr content
parseResult :: (Int,String,String) -> String
parseResult (exit,out,err)
| exit == 0 = show exit++"\n"++out -- ++err
| exit == 1 = "1\n"++out++err
| exit == 124 = "124\nTIME OUT (after "++timeLimit++" seconds)!"
| otherwise = show exit++"\n"++
"ERROR (exit code: "++show exit++")\n"++out++err
| exit == 0 = show exit ++ "\n" ++ out -- ++ err
| exit == 1 = "1\n" ++ out ++ err
| exit == 124 = "124\nTIME OUT (after " ++ timeLimit ++ " seconds)!"
| otherwise = show exit ++ "\n" ++
"ERROR (exit code: " ++ show exit ++ ")\n" ++ out ++ err
--- Finds the module name from a Haskell program if present.
--- @param prog - the Curry program
......
......@@ -51,7 +51,7 @@ timeLimit = "5"
executeWithSWI :: String -> String -> IO String
executeWithSWI urlparam inputprog = do
pid <- getPID
let execDir = "tmpSWIEXEC_"++show pid
let execDir = "tmpSWIEXEC_" ++ show pid
filename = "test.pl"
prog = if null inputprog && not (null urlparam)
then urlencoded2string urlparam
......@@ -61,10 +61,10 @@ executeWithSWI urlparam inputprog = do
setCurrentDirectory execDir
writeFile filename prog
result <- evalCmd timeout
([timeLimit,swi]++swiParams)
("compile('../safeload'). safe_exec('"++filename++"').")
([timeLimit,swi] ++ swiParams)
("compile('../safeload'). safe_exec('" ++ filename ++ "').")
setCurrentDirectory currDir
system $ "/bin/rm -r "++execDir
system $ "/bin/rm -r " ++ execDir
return $ parseResult result
......@@ -73,9 +73,9 @@ executeWithSWI urlparam inputprog = do
--- @param result - exit status, stdin content and stderr content
parseResult :: (Int,String,String) -> String
parseResult (exit,out,err)
| exit == 0 = show exit++"\n"++out -- ++err
| exit == 124 = "124\nTIME OUT (after "++timeLimit++" seconds)!"
| otherwise = show exit++"\n"++
"ERROR (exit code: "++show exit++")\n"++out++err
| exit == 0 = show exit ++ "\n" ++ out -- ++ err
| exit == 124 = "124\nTIME OUT (after " ++ timeLimit ++ " seconds)!"
| otherwise = show exit ++ "\n" ++
"ERROR (exit code: " ++ show exit ++ ")\n" ++ out ++ err
--------------------------------------------------------------------------------
This diff is collapsed.
------------------------------------------------------------------------------
--- Library for constraint programming with arithmetic constraints over reals.
---
--- @author Michael Hanus
--- @version December 2016
--- @category general
------------------------------------------------------------------------------
module CLP.R(CFloat,minimumFor,minimize,maximumFor,maximize) where
-- The operator declarations are similar to the standard arithmetic operators.
infixl 7 *., /.
infixl 6 +., -.
infix 4 <., >., <=., >=.
--- Abstract type to represent floats used in constraints.
data CFloat = CF Float
instance Eq CFloat where
(CF f1) == (CF f2) = f1 == f2
instance Ord CFloat where
compare (CF f1) (CF f2) = compare f1 f2
x < y = x <. y
x > y = x >. y
x <= y = x <=. y
x >= y = x >=. y
instance Show CFloat where
show (CF f) = show f
instance Num CFloat where
x + y = x +. y
x - y = x -. y
x * y = x *. y
negate (CF x) = CF (negateFloat x)
abs x | x >= 0 = x
| otherwise = negate x
signum x | x > 0 = 1
| x == 0 = 0
| otherwise = -1
fromInt x = i2f x
instance Fractional CFloat where
x / y = x /. y
fromFloat x = CF x
--- Addition on floats in arithmetic constraints.
(+.) :: CFloat -> CFloat -> CFloat
(CF x) +. (CF y) = CF ((prim_CLPR_plus $! y) $! x)
prim_CLPR_plus :: Float -> Float -> Float
prim_CLPR_plus external
--- Subtraction on floats in arithmetic constraints.
(-.) :: CFloat -> CFloat -> CFloat
(CF x) -. (CF y) = CF ((prim_CLPR_minus $! y) $! x)
prim_CLPR_minus :: Float -> Float -> Float
prim_CLPR_minus external
--- Multiplication on floats in arithmetic constraints.
(*.) :: CFloat -> CFloat -> CFloat
(CF x) *. (CF y) = CF ((prim_CLPR_times $! y) $! x)
prim_CLPR_times :: Float -> Float -> Float
prim_CLPR_times external
--- Division on floats in arithmetic constraints.
(/.) :: CFloat -> CFloat -> CFloat
(CF x) /. (CF y) = CF ((prim_CLPR_div $! y) $! x)
prim_CLPR_div :: Float -> Float -> Float
prim_CLPR_div external
--- "Less than" constraint on floats.
(<.) :: CFloat -> CFloat -> Bool
(CF x) <. (CF y) = (prim_CLPR_le $! y) $! x
prim_CLPR_le :: Float -> Float -> Bool
prim_CLPR_le external
--- "Greater than" constraint on floats.
(>.) :: CFloat -> CFloat -> Bool
(CF x) >. (CF y) = (prim_CLPR_ge $! y) $! x
prim_CLPR_ge :: Float -> Float -> Bool
prim_CLPR_ge external
--- "Less than or equal" constraint on floats.
(<=.) :: CFloat -> CFloat -> Bool
(CF x) <=. (CF y) = (prim_CLPR_leq $! y) $! x
prim_CLPR_leq :: Float -> Float -> Bool
prim_CLPR_leq external
--- "Greater than or equal" constraint on floats.
(>=.) :: CFloat -> CFloat -> Bool
(CF x) >=. (CF y) = (prim_CLPR_geq $! y) $! x
prim_CLPR_geq :: Float -> Float -> Bool
prim_CLPR_geq external
--- Conversion function from integers to floats.
--- Rigid in the first argument, i.e., suspends until the first argument
--- is ground.
i2f :: Int -> CFloat
i2f x = CF (prim_CLPR_i2f $# x)
prim_CLPR_i2f :: Int -> Float
prim_CLPR_i2f external
--- Computes the minimum with respect to a given constraint.
--- (minimumFor g f) evaluates to x if (g x) is satisfied and
--- (f x) is minimal. The evaluation fails if such a minimal value
--- does not exist. The evaluation suspends if it contains
--- unbound non-local variables.
minimumFor :: (a -> Bool) -> (a -> Float) -> a
minimumFor external
--- Minimization constraint.
--- (minimize g f x) is satisfied if (g x) is satisfied and
--- (f x) is minimal. The evaluation suspends if it contains
--- unbound non-local variables.
minimize :: (a -> Bool) -> (a -> Float) -> a -> Bool
minimize g f x = minimumFor g f =:= x
--- Computes the maximum with respect to a given constraint.
--- (maximumFor g f) evaluates to x if (g x) is satisfied and
--- (f x) is maximal. The evaluation fails if such a maximal value
--- does not exist. The evaluation suspends if it contains
--- unbound non-local variables.
maximumFor :: (a -> Bool) -> (a -> Float) -> a
maximumFor external
--- Maximization constraint.
--- (maximize g f x) is satisfied if (g x) is satisfied and
--- (f x) is maximal. The evaluation suspends if it contains
--- unbound non-local variables.
maximize :: (a -> Bool) -> (a -> Float) -> a -> Bool
maximize g f x = maximumFor g f =:= x
-- end of CLP.R
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="prim_CLPR_plus" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_plus</entry>
</primitive>
<primitive name="prim_CLPR_minus" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_minus</entry>
</primitive>
<primitive name="prim_CLPR_times" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_times</entry>
</primitive>
<primitive name="prim_CLPR_div" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_div</entry>
</primitive>
<primitive name="prim_CLPR_le" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_le</entry>
</primitive>
<primitive name="prim_CLPR_ge" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_ge</entry>
</primitive>
<primitive name="prim_CLPR_leq" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_leq</entry>
</primitive>
<primitive name="prim_CLPR_geq" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_geq</entry>
</primitive>
<primitive name="prim_CLPR_i2f" arity="1">
<library>prim_clpr</library>
<entry>prim_CLPR_i2f</entry>
</primitive>
<primitive name="minimumFor" arity="2">
<library>prim_clpr</library>
<entry>prim_minimumFor[raw]</entry>
</primitive>
<primitive name="maximumFor" arity="2">
<library>prim_clpr</library>
<entry>prim_maximumFor[raw]</entry>
</primitive>
</primitives>
This diff is collapsed.
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="prim_FD_plus" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_plus</entry>
</primitive>
<primitive name="prim_FD_minus" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_minus</entry>
</primitive>
<primitive name="prim_FD_times" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_times</entry>
</primitive>
<primitive name="prim_FD_equal" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_equal</entry>
</primitive>
<primitive name="prim_FD_notequal" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_notequal</entry>
</primitive>
<primitive name="prim_FD_le" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_le</entry>
</primitive>
<primitive name="prim_FD_leq" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_leq</entry>
</primitive>
<primitive name="prim_FD_ge" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_ge</entry>
</primitive>
<primitive name="prim_solve_reify" arity="1">
<library>prim_clpfd</library>
<entry>prim_FD_solve_reify</entry>
</primitive>
<primitive name="prim_FD_geq" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_geq</entry>
</primitive>
<primitive name="prim_domain" arity="3">
<library>prim_clpfd</library>
<entry>prim_FD_domain</entry>
</primitive>
<primitive name="prim_sum" arity="3">
<library>prim_clpfd</library>
<entry>prim_FD_sum</entry>
</primitive>
<primitive name="prim_scalarProduct" arity="4">
<library>prim_clpfd</library>
<entry>prim_FD_scalar_product</entry>
</primitive>
<primitive name="prim_count" arity="4">
<library>prim_clpfd</library>
<entry>prim_FD_count</entry>
</primitive>
<primitive name="prim_allDifferent" arity="1">
<library>prim_clpfd</library>
<entry>prim_FD_all_different</entry>
</primitive>
<primitive name="prim_indomain" arity="1">
<library>prim_clpfd</library>
<entry>prim_FD_indomain</entry>
</primitive>
<primitive name="prim_labeling" arity="2">
<library>prim_clpfd</library>
<entry>prim_FD_labeling</entry>
</primitive>
</primitives>
------------------------------------------------------------------------------
--- Library for constraint programming with arithmetic constraints over reals.
---
--- @category general
------------------------------------------------------------------------------
module CLPR((+.),(-.),(*.),(/.),(<.),(>.),(<=.),(>=.),i2f,
minimumFor,minimize,maximumFor,maximize) where
-- The operator declarations are similar to the standard arithmetic operators.
infixl 7 *., /.
infixl 6 +., -.
infix 4 <., >., <=., >=.
--- Addition on floats in arithmetic constraints.
(+.) :: Float -> Float -> Float
x +. y = (prim_CLPR_plus $! y) $! x
prim_CLPR_plus :: Float -> Float -> Float
prim_CLPR_plus external
--- Subtraction on floats in arithmetic constraints.
(-.) :: Float -> Float -> Float
x -. y = (prim_CLPR_minus $! y) $! x
prim_CLPR_minus :: Float -> Float -> Float
prim_CLPR_minus external
--- Multiplication on floats in arithmetic constraints.
(*.) :: Float -> Float -> Float
x *. y = (prim_CLPR_times $! y) $! x
prim_CLPR_times :: Float -> Float -> Float
prim_CLPR_times external
--- Division on floats in arithmetic constraints.
(/.) :: Float -> Float -> Float
x /. y = (prim_CLPR_div $! y) $! x
prim_CLPR_div :: Float -> Float -> Float
prim_CLPR_div external
--- "Less than" constraint on floats.
(<.) :: Float -> Float -> Bool
x <. y = (prim_CLPR_le $! y) $! x
prim_CLPR_le :: Float -> Float -> Bool
prim_CLPR_le external
--- "Greater than" constraint on floats.
(>.) :: Float -> Float -> Bool
x >. y = (prim_CLPR_ge $! y) $! x
prim_CLPR_ge :: Float -> Float -> Bool
prim_CLPR_ge external
--- "Less than or equal" constraint on floats.
(<=.) :: Float -> Float -> Bool
x <=. y = (prim_CLPR_leq $! y) $! x
prim_CLPR_leq :: Float -> Float -> Bool
prim_CLPR_leq external
--- "Greater than or equal" constraint on floats.
(>=.) :: Float -> Float -> Bool
x >=. y = (prim_CLPR_geq $! y) $! x
prim_CLPR_geq :: Float -> Float -> Bool
prim_CLPR_geq external
--- Conversion function from integers to floats.
--- Rigid in the first argument, i.e., suspends until the first argument
--- is ground.
i2f :: Int -> Float
i2f x = prim_CLPR_i2f $# x
prim_CLPR_i2f :: Int -> Float
prim_CLPR_i2f external
--- Computes the minimum with respect to a given constraint.
--- (minimumFor g f) evaluates to x if (g x) is satisfied and
--- (f x) is minimal. The evaluation fails if such a minimal value
--- does not exist. The evaluation suspends if it contains
--- unbound non-local variables.
minimumFor :: (a -> Bool) -> (a -> Float) -> a
minimumFor external
--- Minimization constraint.
--- (minimize g f x) is satisfied if (g x) is satisfied and
--- (f x) is minimal. The evaluation suspends if it contains
--- unbound non-local variables.
minimize :: (a -> Bool) -> (a -> Float) -> a -> Bool
minimize g f x = minimumFor g f =:= x
--- Computes the maximum with respect to a given constraint.
--- (maximumFor g f) evaluates to x if (g x) is satisfied and
--- (f x) is maximal. The evaluation fails if such a maximal value
--- does not exist. The evaluation suspends if it contains
--- unbound non-local variables.
maximumFor :: (a -> Bool) -> (a -> Float) -> a
maximumFor external
--- Maximization constraint.
--- (maximize g f x) is satisfied if (g x) is satisfied and
--- (f x) is maximal. The evaluation suspends if it contains
--- unbound non-local variables.
maximize :: (a -> Bool) -> (a -> Float) -> a -> Bool
maximize g f x = maximumFor g f =:= x
-- end of CLPR
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="prim_CLPR_plus" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_plus</entry>
</primitive>
<primitive name="prim_CLPR_minus" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_minus</entry>
</primitive>
<primitive name="prim_CLPR_times" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_times</entry>
</primitive>
<primitive name="prim_CLPR_div" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_div</entry>
</primitive>
<primitive name="prim_CLPR_le" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_le</entry>
</primitive>
<primitive name="prim_CLPR_ge" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_ge</entry>
</primitive>
<primitive name="prim_CLPR_leq" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_leq</entry>
</primitive>
<primitive name="prim_CLPR_geq" arity="2">
<library>prim_clpr</library>
<entry>prim_CLPR_geq</entry>
</primitive>
<primitive name="prim_CLPR_i2f" arity="1">
<library>prim_clpr</library>
<entry>prim_CLPR_i2f</entry>
</primitive>
<primitive name="minimumFor" arity="2">
<library>prim_clpr</library>
<entry>prim_minimumFor[raw]</entry>
</primitive>
<primitive name="maximumFor" arity="2">
<library>prim_clpr</library>
<entry>prim_maximumFor[raw]</entry>
</primitive>
</primitives>
......@@ -55,6 +55,7 @@ getRoutes = return
,(Exact "passwd" ,AuthNController )
,(Exact "languages",AdminController )
,(Exact "systems" ,AdminController )
,(Exact "users" ,AdminController )
,(Exact "new" ,SmapIEController )
,(Exact "upload" ,SmapIEController )
,(Always ,SmapIEController )]
......
......@@ -12,3 +12,7 @@ smapDataDir = "data"
--- Location of the database.
smapDB :: String
smapDB = smapDataDir </> "Smap.db"
--- Email address of mail sender.
smapEmail :: String
smapEmail = "smap@curry-lang.org"
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -23,22 +23,22 @@ import View.SmapIE(removeCRs)
--- The download controller delegates its work to the `showDownloadPage`
--- controller.
downloadController :: Url -> IO HtmlForm
downloadController :: Url -> IO HtmlPage
downloadController url@(path,_) =
case path of
["download",progKey] ->
maybe (showInvalidUrlErrorPage url >>= getForm)
maybe (showInvalidUrlErrorPage url >>= getPage)
(\k -> showDownloadPage k >>= toAnswer)
(readProgramKeyAndVersionNumber (progKey,"0"))
["download",progKey,versNum] ->
maybe (showInvalidUrlErrorPage url >>= getForm)
maybe (showInvalidUrlErrorPage url >>= getPage)
(\k -> showDownloadPage k >>= toAnswer)
(readProgramKeyAndVersionNumber (progKey,versNum))
_ -> showInvalidUrlErrorPage url >>= getForm
_ -> showInvalidUrlErrorPage url >>= getPage
where
toAnswer hexps = case hexps of
[HtmlText s] -> return $ HtmlAnswer "text/plain" (removeCRs s)
_ -> getForm hexps
_ -> getPage hexps
-- Shows a specific version of an existing program as HtmlText. Returns
-- an error page if no program exists for the given key or if the version
......
......@@ -95,6 +95,7 @@ doUpdateProgramMetadata (successCtrl,mSuccessAlert) prog =
(showTransactionErrorPage programEditingFailedErr)
transRes
programEditingFailedErr :: String
programEditingFailedErr =
"The program update failed due to an unexpected internal error. See the "++
"internal error message for additional details."
......
This diff is collapsed.
......@@ -56,6 +56,7 @@ readHelpFile fname = do
return (key,title,tail txt)
-- The list of help text files (stored in public/static):
helpTextFiles :: [String]
helpTextFiles =
map (\t -> "help"++t++".txt")
map (\t -> "help" ++ t ++ ".txt")
["Smap","SmapIE","Browser","SignIn","Languages"]
......@@ -203,7 +203,9 @@ addToAttr (HtmlStruct tag ats hexps) (n,v) =
addToAttr' ((n',v'):ats') | n' == n = (n',v'++" "++v):ats'
| otherwise = (n',v'):(addToAttr' ats')
addToAttr (HtmlCRef hexp cref) at = HtmlCRef (addToAttr hexp at) cref
addToAttr (HtmlEvent hexp hdlr) at = HtmlEvent (addToAttr hexp at) hdlr
addToAttr (HtmlEvent hexp cref hdlr) at =
HtmlEvent (addToAttr hexp at) cref hdlr
addToAttr (HtmlAction act) _ = HtmlAction act
addToClass :: HtmlExp -> String -> HtmlExp
addToClass hexp cvalue = addToAttr hexp ("class",cvalue)
......
......@@ -6,19 +6,21 @@
--- association with classes, e.g. for Bootstrap elements). In addition, it
--- provides some helper functions for assigning attributes to HTML elements.
---
--- @author Lasse Kristopher Meyer
--- @version July 2014
--- @author Lasse Kristopher Meyer, Michael Hanus
--- @version July 2020
--------------------------------------------------------------------------------
module HTML.Html5 (
module HTML.Base,HtmlAttr,
module HTML.Base, HtmlAttr,
text,empty,
a,article,aside,b,br,button,code,div,em,fieldset,figcaption,figure,footer,
form,h1,h2,h3,h4,h5,h6,header,hr,i,img,input,label,li,meta,nav,ol,option,p,
script,section,select,small,span,strong,text,textarea,ul,
{-form,-}h1,h2,h3,h4,h5,h6,header,hr,i,
img,input,label,li,meta,nav,ol,option,p,
script,section,select,selectNoRef,small,span,strong,
text,textArea,textAreaNoRef,ul,
alt,autofocus,checked,classA,cols,content,disabled,href,id,lang,name,onclick,
placeholder,rel,role,rows,src,style,tabindex,target,targetBlank,title,value,
buttonButton,resetButton,submitButton,selectInput,
buttonButton,resetButton,submitButton,formSubmitButton,selectInput,
ariaHidden,ariaLabelledby,readonly,addId,
consAttrs,consAttr,consClass,addToAttr,addToClass,setAttr,deleteAttr,
......@@ -28,9 +30,10 @@ module HTML.Html5 (
import Char
import List ( findIndex )
import HTML.Base hiding ( button, code, footer, form, h1, h2, h3, h4, h5
, header, href, nav, section, strong, style, textarea )
import qualified HTML.Base ( textarea )
import HTML.Base hiding ( button, resetButton, code, footer {-, form-}
, h1, h2, h3, h4, h5, h6
, header, href, nav, section, strong, style, textArea )
import qualified HTML.Base ( textArea, button )
infixl 9 `withClass`,`withAddClass`,`withId`
infixl 0 `addToAttr`,`addToClass`,`setAttr`,`deleteAttr`,`addId`
......@@ -94,8 +97,8 @@ figure = HtmlStruct "figure"
footer :: [HtmlAttr] -> [HtmlExp] -> HtmlExp
footer = HtmlStruct "footer"
form :: [HtmlAttr] -> [HtmlExp] -> HtmlExp
form = HtmlStruct "form"
--form :: [HtmlAttr] -> [HtmlExp] -> HtmlExp
--form = HtmlStruct "form"
h1 :: [HtmlAttr] -> [HtmlExp] -> HtmlExp
h1 = HtmlStruct "h1"
......@@ -159,9 +162,9 @@ section = HtmlStruct "section"
select :: [HtmlAttr] -> CgiRef -> [(String,String)] -> String -> HtmlExp
select attrs cRef selMenu initSelVal =
HTML.Base.selectionInitial cRef selMenu 0 `addAttrs` attrs
HTML.Base.selectionInitial cRef selMenu initSel `addAttrs` attrs
where
initSel = maybe 0 Prelude.id (findIndex (==initSelVal) (map fst selMenu))
initSel = maybe 0 Prelude.id (findIndex (==initSelVal) (map snd selMenu))
{- OLD:
select attrs cRef selMenu initSelVal | cRef =:= CgiRef ref =
HtmlCRef (HtmlStruct "select" ((name ref):attrs) options) cRef
......@@ -171,6 +174,22 @@ select attrs cRef selMenu initSelVal | cRef =:= CgiRef ref =
mSel val = if val==initSelVal then [selected] else []
-}
selectNoRef :: [HtmlAttr] -> [(String,String)] -> String -> HtmlExp
selectNoRef attrs selMenu initSelVal =
sI selMenu initSel `addAttrs` attrs
where
initSel = maybe 0 Prelude.id (findIndex (==initSelVal) (map snd selMenu))
sI :: [(String,String)] -> Int -> HtmlExp
sI sellist sel = HtmlStruct "select" [] (selOption sellist sel)
where
selOption [] _ = []
selOption ((n,v):nvs) i =
HtmlStruct "option"
([("value",v)] ++ if i==0 then [("selected","selected")] else [])
[htxt n] : selOption nvs (i-1)
small :: [HtmlAttr] -> [HtmlExp] -> HtmlExp
small = HtmlStruct "small"
......@@ -180,15 +199,24 @@ span = HtmlStruct "span"
strong :: [HtmlAttr] -> [HtmlExp] -> HtmlExp
strong = HtmlStruct "strong"
textarea :: [HtmlAttr] -> CgiRef -> String -> HtmlExp
textarea attrs cRef cont =
deleteAttr (deleteAttr (HTML.Base.textarea cRef (80,10) cont) "rows") "cols"
textArea :: [HtmlAttr] -> CgiRef -> String -> HtmlExp
textArea attrs cRef cont =
deleteAttr (deleteAttr (HTML.Base.textArea cRef (80,10) cont) "rows") "cols"
`addAttrs` attrs
{- OLD:
HtmlCRef (HtmlStruct "textarea" ((name ref):attrs) [text cont]) cRef
where ref free
-}
textAreaNoRef :: [HtmlAttr] -> String -> HtmlExp
textAreaNoRef attrs cont =
deleteAttr (deleteAttr (tA (80,10) cont) "rows") "cols"
`addAttrs` attrs
where
tA (height,width) contents =
HtmlStruct "textarea" [("rows",show height),("cols",show width)]
[htxt contents]
ul :: [HtmlAttr] -> [HtmlExp] -> HtmlExp
ul = HtmlStruct "ul"
......@@ -203,8 +231,17 @@ resetButton :: [HtmlAttr] -> [HtmlExp] -> HtmlExp
resetButton attrs = button $ ("type","reset"):attrs
submitButton :: [HtmlAttr] -> HtmlHandler -> [HtmlExp] -> HtmlExp
submitButton attrs hdlr btnLabel =
HtmlEvent (button (("type","submit"):(name "EVENT"):attrs) btnLabel) hdlr
submitButton attrs hdlr btnLabel
| idOfCgiRef cref =:= ref -- instantiate cref argument
= HtmlEvent
(HtmlStruct "input" (("type","submit") : (name ref) : attrs) btnLabel)
cref hdlr
where
cref,ref free
formSubmitButton :: [HtmlAttr] -> String -> HtmlHandler -> HtmlExp
formSubmitButton attrs btnLabel hdlr =
consAttrs attrs (HTML.Base.button btnLabel hdlr)
selectInput :: [HtmlAttr] -> CgiRef -> [(String,String)] -> Int -> HtmlExp
selectInput attrs cref sels initSel =
......@@ -318,7 +355,9 @@ consAttrs nats (HtmlStruct tag ((n,v):ats) hexps)
| n == "type" = HtmlStruct tag ((n,v):nats++ats) hexps -- skip type attribute
| otherwise = HtmlStruct tag (nats++(n,v):ats) hexps
consAttrs nats (HtmlCRef hexp cref) = HtmlCRef (consAttrs nats hexp) cref
consAttrs nats (HtmlEvent hexp hdlr) = HtmlEvent (consAttrs nats hexp) hdlr
consAttrs nats (HtmlEvent hexp cref hdlr) =
HtmlEvent (consAttrs nats hexp) cref hdlr
consAttrs _ (HtmlAction act) = HtmlAction act
consAttr :: (String,String) -> HtmlExp -> HtmlExp
consAttr nat = consAttrs [nat]
......@@ -334,7 +373,9 @@ addToAttr (HtmlStruct tag ats hexps) (n,v) =
addToAttr' ((n',v'):ats') | n' == n = (n',v'++" "++v):ats'
| otherwise = (n',v'):(addToAttr' ats')
addToAttr (HtmlCRef hexp cref) at = HtmlCRef (addToAttr hexp at) cref
addToAttr (HtmlEvent hexp hdlr) at = HtmlEvent (addToAttr hexp at) hdlr
addToAttr (HtmlEvent hexp cref hdlr) at =
HtmlEvent (addToAttr hexp at) cref hdlr
addToAttr (HtmlAction act) _ = HtmlAction act
addToClass :: HtmlExp -> String -> HtmlExp
addToClass hexp cvalue = addToAttr hexp ("class",cvalue)
......@@ -346,8 +387,9 @@ setAttr (HtmlStruct tag ats hexps) (n,v) =
where setAttr' [] = [(n,v)]
setAttr' ((n',v'):ats') | n' == n = ((n,v):ats')
| otherwise = (n',v'):(setAttr' ats')
setAttr (HtmlCRef hexp cref) at = HtmlCRef (setAttr hexp at) cref
setAttr (HtmlEvent hexp hdlr) at = HtmlEvent (setAttr hexp at) hdlr
setAttr (HtmlCRef hexp cref) at = HtmlCRef (setAttr hexp at) cref
setAttr (HtmlEvent hexp cref hdlr) at = HtmlEvent (setAttr hexp at) cref hdlr
setAttr (HtmlAction act) _ = HtmlAction act
deleteAttr :: HtmlExp -> String -> HtmlExp
deleteAttr (HtmlText txt) _ = HtmlText txt
......@@ -357,7 +399,9 @@ deleteAttr (HtmlStruct tag ats hexps) n =
deleteAttr' ((n',v):ats') | n' == n = ats'
| otherwise = (n',v):(deleteAttr' ats')
deleteAttr (HtmlCRef hexp cref) at = HtmlCRef (deleteAttr hexp at) cref
deleteAttr (HtmlEvent hexp hdlr) at = HtmlEvent (deleteAttr hexp at) hdlr
deleteAttr (HtmlEvent hexp cref hdlr) at =
HtmlEvent (deleteAttr hexp at) cref hdlr
deleteAttr (HtmlAction act) _ = HtmlAction act
toValidAttrValue :: String -> String
......
......@@ -20,13 +20,13 @@ import System.Url
--------------------------------------------------------------------------------
--- The main function! Calls the dispatcher.
main :: IO HtmlForm
main :: IO HtmlPage
main = dispatcher
--- The dispatcher function. Gets the current URL and the associated controller
--- reference (see `RoutesData`), maps the reference to an actual controller and
--- returns the form.
dispatcher :: IO HtmlForm
dispatcher :: IO HtmlPage
dispatcher = do
url <- getUrl
case url of
......@@ -34,7 +34,7 @@ dispatcher = do
_ -> do controller <- getControllerReference url
>>= maybe (showInvalidUrlErrorPage url)
(getController url)
form <- getForm controller
form <- getPage controller
return form
--------------------------------------------------------------------------------
......@@ -55,12 +55,12 @@ alert = global emptySessionStore Temporary
--- Sets the alert of the current session.
--- @param nAlert - the next alert
setAlert :: Alert -> IO ()
setAlert nAlert = putSessionData nAlert alert
setAlert nAlert = putSessionData alert nAlert
--- Gets the current alert and deletes it from the session.
getAlert :: IO (Maybe Alert)
getAlert =
do mAlert <- getSessionData alert
do mAlert <- getSessionMaybeData alert
removeSessionData alert
return mAlert
......
......@@ -40,13 +40,13 @@ sessionAuthNData =
--- Gets the current authentication data from the session store.
getSessionAuthNData :: IO (Maybe AuthNData)
getSessionAuthNData = getSessionData sessionAuthNData
getSessionAuthNData = getSessionMaybeData sessionAuthNData
--- Stores new authentication data in the current session (after the user
--- authentication).
--- @param authNData - authentication data of the user
signInToSession :: AuthNData -> IO ()
signInToSession authNData = putSessionData authNData sessionAuthNData
signInToSession authNData = putSessionData sessionAuthNData authNData
--- Removes authentication data from the current session.
signOutFromSession :: IO ()
......
......@@ -7,7 +7,7 @@
--- elements on views.
---
--- @author Lasse Kristopher Meyer (with changes by Michael Hanus)
--- @version July 2014
--- @version July 2020
--------------------------------------------------------------------------------
module System.AuthorizedOperations (
......@@ -250,7 +250,7 @@ authNOperation accessType authzData =
--- is one of the following.
--- @cons CreateLanguage - creates a new language entity
--- @cons CreateSystem - creates a new system entity
data AdminAccessType = CreateLanguage | CreateSystem
data AdminAccessType = CreateLanguage | CreateSystem | EditUser
--- Checks the authorization of administrational operations.
--- @param authzData - the current authorization data
......
......@@ -14,7 +14,7 @@ module System.Controllers (
showInvalidUrlErrorPage,showTransactionErrorPage,
showNotYetImplementedErrorPage,stdErrorPageTitle,
validateKeyAndApply,validateKeyAndApplyOn,next,nextFor,
getForm
getPage
) where
import KeyDatabase
......@@ -158,19 +158,19 @@ validateKeyAndApplyOn mKey url getentity applyController =
mKey
--- @param controller - the controller that will be executed
next :: Controller -> IO HtmlForm
next :: Controller -> IO HtmlPage
next controller =
do view <- controller
getForm view
getPage view
--- Runs the action of a controller which takes an additional argument and
--- delivers the HTML form.
--- @param controller - the controller that will be executed
--- @param arg - the additional argument
nextFor :: (a -> Controller) -> a -> IO HtmlForm
nextFor :: (a -> Controller) -> a -> IO HtmlPage
nextFor controller arg =
do view <- controller arg
getForm view
getPage view
--------------------------------------------------------------------------------
-- Building the HTML form --
......@@ -180,31 +180,30 @@ nextFor controller arg =
--- form parameters and the basic layout (including the navigation bar and
--- sticky footer).
--- @param view - the view returned by the last active controller
getForm :: [HtmlExp] -> IO HtmlForm
getForm view =
do cookie <- sessionCookie
body <- addLayoutToView
langs <- getAllLanguages
return $ HtmlForm "Smap"
([viewportMetaTag,cookie,favicon,MultipleHandlers]
++(jsHeadIncludes $ map languageName langs)
++cssIncludes)
(body++jsBodyIncludes)
where
addLayoutToView =
do url <- getUrl
langs <- getAllLanguages
mAuthNData <- getSessionAuthNData
mAlert <- getAlert
return $
[wrap styleAttrs $
[renderNavbar url langs mAuthNData]
++[maybe empty renderAlert mAlert]
++view]++
[stickyFooter]
styleAttrs = case view of -- adds styles for specific pages
[HtmlStruct "input" [("type","hidden"),("value","smap-ie")] [],_] ->
[style "height: 100%;"]
_ -> []
getPage :: [HtmlExp] -> IO HtmlPage
getPage view = do
body <- addLayoutToView
langs <- getAllLanguages
withSessionCookieInfo $ HtmlPage "Smap"
([viewportMetaTag, favicon] ++
(jsHeadIncludes $ map languageName langs) ++
cssIncludes)
(body ++ jsBodyIncludes)
where
addLayoutToView =
do url <- getUrl
langs <- getAllLanguages
mAuthNData <- getSessionAuthNData
mAlert <- getAlert
return $
[wrap styleAttrs $
[renderNavbar url langs mAuthNData] ++
[maybe empty renderAlert mAlert] ++
view] ++
[stickyFooter]
styleAttrs = case view of -- adds styles for specific pages
HtmlStruct "input" [("type","hidden"),("value","smap-ie")] [] : _ ->
[style "height: 100%;"]
_ -> []
--------------------------------------------------------------------------------
\ No newline at end of file
This diff is collapsed.
......@@ -3,7 +3,7 @@
--- the basic layout, WUI forms and views.
---
--- @author Lasse Kristopher Meyer (with changes by Michael Hanus)
--- @version November 2018
--- @version July 2020
--------------------------------------------------------------------------------
module System.SmapHtml (
......@@ -16,7 +16,7 @@ module System.SmapHtml (
smTextInput,
greyLinkBtn,blueLinkBtn,smBlueLinkBtn,smGreenLinkBtn,xsDefaultLinkBtn,
greenLinkBtn,orangeLinkBtn,linkLinkBtn,
blueSubmitBtn,orangeSubmitBtn,linkSubmitBtn,greyCancelBtn,
blueSubmitBtn,greenSubmitBtn,orangeSubmitBtn,linkSubmitBtn,greyCancelBtn,
aboutIcon,addIcon,browserIcon,codeIcon,commentIcon,createdIcon,dashboardIcon,
deleteIcon,descriptionIcon,downloadIcon,uploadIcon,
executionIcon,execErrorIcon,
......@@ -44,19 +44,19 @@ import System.Url
--------------------------------------------------------------------------------
--- The viewport meta tag (http://getbootstrap.com/css/#overview-mobile).
viewportMetaTag :: FormParam
viewportMetaTag = HeadInclude $
viewportMetaTag :: PageParam
viewportMetaTag = PageHeadInclude $
meta [name "viewport",content "width=device-width, initial-scale=1.0"]
--- The favicon.
favicon :: FormParam
favicon = HeadInclude $
favicon :: PageParam
favicon = PageHeadInclude $
HtmlStruct "link" [rel "shortcut icon",href "favicon.ico"] []
--- JavaScript files to be included in the head (especially CodeMirror modes).
--- @param langNames - the names of all languages in the database
jsHeadIncludes :: [String] -> [FormParam]
jsHeadIncludes langNames = map (\file -> FormJScript $ "js/"++file++".js") $
jsHeadIncludes :: [String] -> [PageParam]
jsHeadIncludes langNames = map (\file -> PageJScript $ "js/"++file++".js") $
["codemirror/codemirror"
,"codemirror/addons/active-line"
,"codemirror/addons/closebrackets"
......@@ -64,8 +64,8 @@ jsHeadIncludes langNames = map (\file -> FormJScript $ "js/"++file++".js") $
++map (\langName -> "codemirror/modes/"++map toLower langName) langNames
--- CSS files to be included in the head.
cssIncludes :: [FormParam]
cssIncludes = map (\file -> FormCSS $ "css/"++file++".css")
cssIncludes :: [PageParam]
cssIncludes = map (\file -> PageCSS $ "css/"++file++".css")
["bootstrap/bootstrap.min"
,"bootstrap/bootstrap-theme.min"
,"codemirror/codemirror"
......@@ -198,7 +198,10 @@ renderNavbar url langNames mAuthNData =
[addIcon,text " Add system"]]
,li []
[a [href "?systems/list"]
[modifiedIcon,text " Edit systems"]]]
[modifiedIcon,text " Edit systems"]]
,li []
[a [href "?users/list"]
[browserIcon,text " Show users"]]]
mAdmin b = if b then " admin" else ""
navbarSearchTooltip =
"Search all programs on Smap that contain the given keyword in either t"++
......@@ -219,7 +222,7 @@ stickyFooter =
(div [] `withId` "sticky-footer")
[container
[p [classA "text-muted"]
[text "&copy; 2014, Lasse Kristopher Meyer &bull; "
[text "&copy; 2014-2020, Lasse Kristopher Meyer, Michael Hanus &bull; "
,a [href "?about"] [text " About"]]]]
-- A panel with a width (in columns between 2 and 12), title, body, and footer.
......@@ -353,22 +356,28 @@ linkLinkBtn url = a [href url,classA "btn btn-link"]
-- Submit buttons
--- A submit button rendered as a blue button.
--- @param hdlr - the HTML handler
--- @param label - label HTML expressions
blueSubmitBtn :: HtmlHandler -> [HtmlExp] -> HtmlExp
blueSubmitBtn = submitButton [classA "btn btn-primary"]
--- @param label - the button label
--- @param hdlr - the handler
blueSubmitBtn :: String -> HtmlHandler -> HtmlExp
blueSubmitBtn = formSubmitButton [classA "btn btn-primary"]
--- A submit button rendered as a blue button.
--- @param label - the button label
--- @param hdlr - the handler
greenSubmitBtn :: String -> HtmlHandler -> HtmlExp
greenSubmitBtn = formSubmitButton [classA "btn btn-success"]
--- A submit button rendered as a orange button.
--- @param hdlr - the HTML handler
--- @param label - label HTML expressions
orangeSubmitBtn :: HtmlHandler -> [HtmlExp] -> HtmlExp
orangeSubmitBtn = submitButton [classA "btn btn-warning"]
orangeSubmitBtn :: String -> HtmlHandler -> HtmlExp
orangeSubmitBtn = formSubmitButton [classA "btn btn-warning"]
--- A submit button rendered as a link button.
--- @param hdlr - the HTML handler
--- @param label - label HTML expressions
linkSubmitBtn :: HtmlHandler -> [HtmlExp] -> HtmlExp
linkSubmitBtn = submitButton [classA "btn btn-link"]
linkSubmitBtn :: String -> HtmlHandler -> HtmlExp
linkSubmitBtn = formSubmitButton [classA "btn btn-link"]
-- Standard buttons
......
......@@ -10,16 +10,15 @@
--- `WUI` where error renderings are allowed instead of just error messages. The
--- modified module can be found in `../lib`)
---
--- @author Lasse Kristopher Meyer
--- @version January 2014
--- @author Lasse Kristopher Meyer, Michael Hanus
--- @version July 2020
--------------------------------------------------------------------------------
module System.SmapWui (
module WUI,
wSmapConstant,wSmapString,wSmapTextarea,wSmapSelect,wSmapSelectBool,wSmapPair,
wSmapTriple,wSmap4Tuple,wSmap5Tuple,wSmap6Tuple,wSmap7Tuple,
isRequired,
greyWuiBtn,blueWuiBtn
isRequired
) where
import HTML.Bootstrap3
......@@ -250,22 +249,4 @@ smapTupleRendering = div [classA "form-widget"]
isRequired :: String -> Bool
isRequired = not . null
--------------------------------------------------------------------------------
-- WUI form submit buttons --
--------------------------------------------------------------------------------
--- A WUI submit button rendered as a grey button.
--- @param wHdlr - the WUI handler
--- @param label - the button label
greyWuiBtn :: WuiHandler -> [HtmlExp] -> HtmlExp
greyWuiBtn (WHandler hdlr) label =
submitButton [classA "btn btn-default"] hdlr label
--- A WUI submit button rendered as a blue button.
--- @param wHdlr - the WUI handler
--- @param label - the button label
blueWuiBtn :: WuiHandler -> [HtmlExp] -> HtmlExp
blueWuiBtn (WHandler hdlr) label =
submitButton [classA "btn btn-primary"] hdlr label
--------------------------------------------------------------------------------
\ No newline at end of file
......@@ -45,8 +45,8 @@ showUrl url = showPath url ++ showQueryString url
showPath :: Url -> String
showPath (path,_) =
if null path
then ""
else "?"++(intercalate "/" path)
then ""
else "?" ++ intercalate "/" path
--- Turns the query string component of a given URL into its string
--- representation. Also adds the question mark at the beginning.
......
......@@ -4,13 +4,12 @@
--- imported by all controller modules, given that it also exports the general
--- type synonym for views.
---
--- @author Lasse Kristopher Meyer
--- @version March 2014
--- @author Lasse Kristopher Meyer, Michael Hanus
--- @version July 2020
--------------------------------------------------------------------------------
module System.Views (
View,wuiWithErrorFormToHtml,wuiFrameToForm,
renderWuiForm,withConfirmation
View, withConfirmation, renderWui
) where
import Prelude hiding (div)
......@@ -22,7 +21,7 @@ import System.SmapWui
--------------------------------------------------------------------------------
--- A view is a list of HTML expressions that will be framed by the general
--- layout of the HTML page (see `getForm` in `Controllers`) and contains the
--- layout of the HTML page (see `getPage` in `Controllers`) and contains the
--- viewable content of a HTML page.
type View = [HtmlExp]
......@@ -36,22 +35,22 @@ type View = [HtmlExp]
--- are used in one view each of it must get a unique id
--- @param trigger - the element that will trigger the dialog box
--- @param message - the confirmation message shown in the dialog box
--- @param hdlr - the HTML handler that fires the confirmed action
--- @param acturl - the URL of the confirmed action
--- @return a pair containing the given trigger element with its actual
--- functionality added and the confirmation dialog box as a HTML expression;
--- the first component should be used in place of the given trigger element
--- and the second component must be inserted somewhere in the HTML form to
--- actually show up when the returned trigger element is clicked
withConfirmation :: Int -> HtmlExp -> String -> HtmlHandler -> (HtmlExp,HtmlExp)
withConfirmation dialogId trigger message hdlr =
withConfirmation :: Int -> HtmlExp -> String -> String -> (HtmlExp,HtmlExp)
withConfirmation dialogId trigger message acturl =
(trigger `addAttrs` [modalToggle,targetId modalId]
,stdModal modalId labelId
[glyphicon "question-sign",text " Do you really want to proceed?"]
[text message]
[buttonButton [classA "btn btn-default",modalDismiss]
[text "Cancel"]
,submitButton [classA "btn btn-success"] hdlr
[glyphicon "ok",text " Confirm"]]
,greenLinkBtn acturl [glyphicon "ok", htxt "Confirm"]
]
`addToClass` "confirmation-dialog-box")
where
modalId = "confirmation-dialog-box-"++show dialogId
......@@ -61,65 +60,37 @@ withConfirmation dialogId trigger message hdlr =
-- General WUI forms and WUI components --
--------------------------------------------------------------------------------
--- Standard rendering for WUI forms. Defines holes for a header, an info line,
--- Standard rendering for WUI forms.
--- It has parameters for a header, an info line,
--- the submit button label, additional navigation elements and a panel footer.
--- Also takes initial data to be prefilled in the form and the controller that
--- handles the form submission.
--- @param wuiSpec - the associated WUI specification
--- @param init - initial data to be prefilled in the form
--- @param ctrl - the controller that handles the submission
--- @param header - header HTML expressions
--- @param info - info line HTML expressions
--- @param label - submit button label HTML expressions
--- @param label - label for submit button
--- @param addNav - additional navigation elements (placed right to the submit
--- button)
--- @param footer - footer HTML expressions
renderWuiForm
:: WuiSpec a -> a -> (a -> Controller) -> [HtmlExp] -> [HtmlExp] -> [HtmlExp]
-> [HtmlExp] -> [HtmlExp] -> [HtmlExp]
renderWuiForm wuiSpec init ctrl header info label addNav footer =
wuiFrame hExp wHdlr
where
(hExp,wHdlr) = wuiWithErrorFormToHtml wuiSpec
init
ctrl
(wuiFrameToForm wuiFrame)
wuiFrame hExp' wHdlr' =
--- @param hexp - the HTML expression representing the WUI form
--- @param handler - the handler for submitting data
renderWui :: [HtmlExp] -> [HtmlExp] -> String -> [HtmlExp] -> [HtmlExp]
-> HtmlExp -> (CgiEnv -> IO [HtmlExp]) -> [HtmlExp]
renderWui header info label addNav footer hexp hdlr =
[(container `withId` "wui-form")
[row
[col [Xs 6,XsOffset 3]
[col [Xs 6, XsOffset 3]
[panelDefault
[panelBody $
[(pageHeader `withId` "header")
header
,mInfo
,hExp']
++[div [classA "pull-left"]
[blueWuiBtn wHdlr' label,greyCancelBtn]
,hexp] ++
[div [classA "pull-left"]
[ blueSubmitBtn label (\env -> hdlr env >>= getPage)
, greyCancelBtn]
,div [classA "pull-right"]
addNav]
,panelFooter
footer]]]]]
mInfo = if null info then empty else div [classA "info"] info
--- Adapts the `wuiWithErrorForm` function to Spicey's controller concept.
--- @param wuiSpec - the associated WUI specification
--- @param initial - initial data to be prefilled in the form
--- @param controller - the controller that handles the submission
--- @param errorForm - the form for the error case
wuiWithErrorFormToHtml
:: WuiSpec a -> a -> (a -> Controller) -> (HtmlExp -> WuiHandler
-> IO HtmlForm) -> (HtmlExp,WuiHandler)
wuiWithErrorFormToHtml wuiSpec initial controller errorForm =
wuiWithErrorForm wuiSpec initial (nextFor controller) errorForm
--- Builds the HTML form from a given WUI form.
--- @param wuiFrame - the frame for the WUI form
--- @param hexp - HTML expressions specifying the WUI form
--- @param whdlr - the associated WUI handler
wuiFrameToForm
:: (HtmlExp -> WuiHandler -> [HtmlExp]) -> HtmlExp -> WuiHandler
-> IO HtmlForm
wuiFrameToForm wuiFrame hexp whdlr = getForm (wuiFrame hexp whdlr)
where
mInfo = if null info then empty else div [classA "info"] info
--------------------------------------------------------------------------------
\ No newline at end of file
......@@ -2,12 +2,14 @@
--- This modules provides views for the module `AdminController` and primarily
--- exports pages with WUI forms for entity creation (languages and systems).
---
--- @author Lasse Kristopher Meyer
--- @version November 2018
--- @author Lasse Kristopher Meyer, Michael Hanus
--- @version July 2020
--------------------------------------------------------------------------------
module View.Admin (
languageCreationForm,systemCreationForm,listSystemView,editSystemView
languageCreationRendering, systemCreationRendering, editSystemRendering,
listSystemView, listUserView,
wLanguage, wSystem, wSystemType
) where
import Prelude hiding (div)
......@@ -25,28 +27,34 @@ import Model.Smap
-- Exported views --
--------------------------------------------------------------------------------
--- Supplies a WUI form to create a new language.
--- @param createLang - the controller that handles the language creation
languageCreationForm :: ((String,String,String) -> Controller) -> View
languageCreationForm createLang =
renderWuiForm wLanguage ("","","") createLang
[h3 [] [addIcon,text " Add a new language to Smap"]]
--- A rendering for a WUI form to create a new language.
languageCreationRendering :: HtmlExp -> (CgiEnv -> IO [HtmlExp]) -> View
languageCreationRendering =
renderWui
[h3 [] [addIcon, text " Add a new language to Smap"]]
[]
[text "Add to Smap!"]
"Add to Smap!"
[]
[]
--- Supplies a WUI form to create a new system.
--- @param createSystem - the comntroller that handles the system creation
systemCreationForm :: [Language] -> ((String,String,Language) -> Controller) -> View
systemCreationForm langs createSystem =
renderWuiForm (wSystem langs) ("","",head langs) createSystem
[h3 [] [addIcon,text " Add a new system to Smap"]]
--- A rendering for a WUI form to create a new system.
systemCreationRendering :: HtmlExp -> (CgiEnv -> IO [HtmlExp]) -> View
systemCreationRendering =
renderWui
[h3 [] [addIcon, text " Add a new system to Smap"]]
[]
[text "Add to Smap!"]
"Add to Smap!"
[]
[]
--- Supplies a WUI form to edit the given System entity.
--- Takes also associated entities and a list of possible associations
--- for every associated entity type.
editSystemRendering :: HtmlExp -> (CgiEnv -> IO [HtmlExp]) -> View
editSystemRendering =
renderWui [text "Edit System"] [] "Change!" [] []
--- Compares two System entities. This order is used in the list view.
leqSystem :: System -> System -> Bool
leqSystem x1 x2 =
......@@ -75,15 +83,33 @@ listSystemView systems =
systemToListView system =
[[text (systemName system)],[text (systemExecUrl system)]]
--- Supplies a WUI form to edit the given System entity.
--- Takes also associated entities and a list of possible associations
--- for every associated entity type.
editSystemView
:: System -> Language -> [Language]
-> (System -> Controller) -> [HtmlExp]
editSystemView system relatedLanguage possibleLanguages controller =
renderWuiForm (wSystemType system relatedLanguage possibleLanguages)
system controller [text "Edit System"] [] [text "Change!"] [] []
--- Supplies a list view for a given list of User entities.
listUserView :: [User] -> [HtmlExp]
listUserView users =
[panelWith 10
[text "Users in Smap"]
[spTable ([[[b [] [text "Name"]],[b [] [text "Email"]]
,[b [] [text "Is admin?"]]]] ++
map listUser (sortBy leqUser users))] []]
where
listUser :: User -> [[HtmlExp]]
listUser user =
userToListView user ++ []
--[[smBlueLinkBtn ("?users/edit/" ++ showUserKey user)
-- [modifiedIcon, htxt " edit"]]
--,[smBlueLinkBtn ("?users/delete/" ++ showUserKey user)
-- [deleteIcon, htxt " delete"]]
--]
userToListView :: User -> [[HtmlExp]]
userToListView user =
[[text (userName user)]
,[text (userEmail user)]
,[text (if userIsAdmin user then "X" else " ")]]
--- Compares two User entities. This order is used in the list view.
leqUser :: User -> User -> Bool
leqUser x1 x2 = userName x1 <= userName x2
--------------------------------------------------------------------------------
-- WUI components --
......
......@@ -2,12 +2,13 @@
--- This module provides all views for authentication related pages (WUI forms
--- for signing in, signing up and password requests).
---
--- @author Lasse Kristopher Meyer
--- @version January 2014
--- @author Lasse Kristopher Meyer, Michael Hanus
--- @version July 2020
--------------------------------------------------------------------------------
module View.AuthN (
signUpPage,signInPage,forgotPasswordPage,changePasswordForm
signInRenderer, forgotPasswordRenderer,
wSignUpData, wSignInData, wNewPasswordData, wChgPasswords
) where
import Prelude hiding (div)
......@@ -21,112 +22,44 @@ import System.Views
-- Exported views --
--------------------------------------------------------------------------------
--- Supplies a WUI form to sign up for Smap by creating a new user with an
--- username, an email address and a password.
--- @param signUp - the controller which handles the user creation
signUpPage
:: (String,String,String,String)
-> ((String,String,String,String) -> Controller)
-> View
signUpPage initCreationData signUp =
renderWuiForm wSignUpData initCreationData signUp
[h3 [] [signUpIcon,text " Sign up for Smap"]]
[]
[text "Sign up"]
[]
[text "Already have an account? "
,a [href "?signin"] [text "Sign in &raquo;"]]
--- Supplies a WUI form to sign in to Smap with a user name and a password. If
--- A rendering to sign in to Smap with a user name and a password. If
--- given, an initial user name is set.
--- @param mUsername - an possibly given initial user name
--- @param signIn - the controller which handles the sign in process
signInPage :: Maybe String -> ((String,String) -> Controller) -> View
signInPage mUsername signIn = wuiFrame hExp wHdlr
where
initUsername = maybe "" id mUsername
focusUsername = maybe True (\_ -> False) mUsername
(hExp,wHdlr) = wuiWithErrorFormToHtml (wSignInData focusUsername)
(initUsername,"")
signIn
(wuiFrameToForm wuiFrame)
wuiFrame hExp' wHdlr' =
[(container `withId` "sign-in-page")
[row
[col [Xs 4,XsOffset 4]
[panelDefault
[panelBody
[pageHeader
[h3 [] [signInIcon,text " Sign in to Smap"]]
,hExp'
,hr []
,blueWuiBtn wHdlr' [text "Sign in"]
,a [href "?forgot"] [text "Forgot password?"]]
,panelFooter
[text "New to Smap? "
,a [href "?signup"] [text "Sign up &raquo;"]]]]]]]
--- Supplies a WUI form to send a new password to an user with a given email
signInRenderer :: HtmlExp -> (CgiEnv -> IO [HtmlExp]) -> [HtmlExp]
signInRenderer hexp hdlr =
[(container `withId` "sign-in-page")
[row
[col [Xs 4,XsOffset 4]
[panelDefault
[panelBody
[pageHeader
[h3 [] [signInIcon,text " Sign in to Smap"]]
,hexp
,hr []