implementation module Setup
import StdList,StdBool, StdInt
import Http, HttpServer
import Html, HtmlUtil
import Config
import Engine, Util
setupHandler :: !(Config -> [(String -> Bool, (HTTPRequest *World -> *(!HTTPResponse,!HTTPServerControl,!*World)))]) !HTTPRequest !*World -> (!HTTPResponse, !HTTPServerControl, !*World)
setupHandler handlers req world
# (appName,world) = determineAppName world
# (finished,world) = configFileAvailable appName world
| finished
= finishPage appName world
# (config,world) = if (isEmpty req.arg_post) (initialConfig world) (postedConfig req, world)
# (errors,world) = checkConfig config world
= case req.req_path of
"/edit" = editConfigPage appName config errors world
"/save"
| noErrors errors = saveConfigPage appName config (handlers config) world
| otherwise = editConfigPage appName config errors world
_ = choicePage appName config errors world
//Initial config of the form
initialConfig :: !*World -> (!Config,!*World)
initialConfig world
# (clientPath,world) = findClientPath 10 "Client" world
= ({defaultConfig & clientPath = clientPath},world)
where
findClientPath 0 path world = (".",world)
findClientPath i path world
# (ok,world) = checkClientPath path world
| ok = (path,world)
# buildpath = path +++ "\\build"
# (ok,world) = checkClientPath buildpath world
| ok = (buildpath,world)
= findClientPath (dec i) ("..\\" +++ path) world
postedConfig :: !HTTPRequest -> Config
postedConfig req =
{ clientPath = http_getValue "clientPath" req.arg_post ""
, staticPath = http_getValue "staticPath" req.arg_post ""
, rootPassword = http_getValue "rootPassword" req.arg_post ""
, rootEmail = http_getValue "rootEmail" req.arg_post ""
, sessionTime = toInt (http_getValue "sessionTime" req.arg_post "0")
, serverPort = toInt (http_getValue "serverPort" req.arg_post "0")
, serverPath = http_getValue "serverPath" req.arg_post "0"
, debug = http_getValue "debug" req.arg_post "false" <> "false"
, smtpServer = http_getValue "smtpServer" req.arg_post ""
, generalWorkflows = http_getValue "generalWorkflows" req.arg_post "false" <> "false"
}
checkConfig :: !Config !*World -> (![Maybe String],!*World)
checkConfig config world
# (clientPathOk,world) = checkClientPath config.clientPath world
= ([if clientPathOk Nothing (Just CLIENT_ERROR)
,Nothing
,Nothing
,Nothing
,if (config.sessionTime < 60) (Just "Session time should be at least 60 seconds") Nothing
,if ((config.serverPort < 0) || (config.serverPort > 60000)) (Just "Server port should be between 1 and 60000") Nothing
,Nothing
,Nothing
,Nothing
,Nothing
],world)
CLIENT_ERROR :== "The client framework could not be found at this location.
"
+++ "Please fill in the full path where the client framework can be found.
"
+++ "It can normally be found in the \"Client\\build\" folder of the SDK. For example C:\\iTasks-SDK\\Client\\build."
checkClientPath :: !String !*World -> (!Bool,!*World)
checkClientPath clientPath world
# (index,world) = readfile (clientPath +++ "\\index.html") world
= (index <> "",world)
configFileAvailable :: !String !*World -> (!Bool,!*World)
configFileAvailable appName world
# (config,world) = readfile (appName +++ "-config.json") world
= (config <> "",world)
noErrors :: [(Maybe String)] -> Bool
noErrors errors = not (or (map isJust errors))
page :: !String ![HtmlTag] !*World -> (!HTTPResponse,!HTTPServerControl, !*World)
page appName content world = ({http_emptyResponse & rsp_data = toString (pageLayout (appName +++ " setup") "" content)}, HTTPServerContinue, world)
choicePage :: !String !Config ![Maybe String] !*World -> (!HTTPResponse,!HTTPServerControl,!*World)
choicePage appName config errors world = page appName [DivTag [IdAttr "content"] [instructions,showConfig config errors],buttons] world
where
instructions
= PTag []
[Text "Welcome, you are running ",StrongTag [] [Text appName],Text " for the first time.", BrTag[]
,Text "You may run this application with the following default configuration, or edit it first"
]
buttons = DivTag [ClassAttr "buttons"]
[ButtonTag [TypeAttr "submit",OnclickAttr "window.location = '/save';"] [Text "Use this default configuration"]
,ButtonTag [TypeAttr "submit",OnclickAttr "window.location = '/edit';"] [Text "Edit the configuration first"]
]
editConfigPage :: !String !Config ![Maybe String] !*World -> (!HTTPResponse,!HTTPServerControl,!*World)
editConfigPage appName config errors world = page appName [form] world
where
form = FormTag [MethodAttr "post",ActionAttr "/save"] [DivTag [IdAttr "content"] [editConfig config errors],submit]
submit = DivTag [ClassAttr "buttons"] [ButtonTag [TypeAttr "submit"] [Text "Save configuration and restart"]]
instructions
= PTag [] [Text "Please confirm the configuration settings below and save them."]
saveConfigPage :: !String !Config ![(String -> Bool, (HTTPRequest *World -> *(!HTTPResponse,!HTTPServerControl,!*World)))] !*World -> (!HTTPResponse,!HTTPServerControl,!*World)
saveConfigPage appName config handlers world
# world = storeConfig appName config world
# options = [HTTPServerOptPort config.serverPort, HTTPServerOptDebug config.debug]
# redirectUrl = if (config.serverPort == 80) "http://localhost/" ("http://localhost:" +++ toString config.serverPort +++ "/")
= ({http_emptyResponse & rsp_headers = [("Status","302"),("Location",redirectUrl)]}, HTTPServerRestart options handlers, world)
finishPage :: !String !*World -> (!HTTPResponse, !HTTPServerControl, !*World)
finishPage appName world = page appName [instructions] world
where
instructions
= DivTag [IdAttr "content"] [Text "The configuration file has been written.",BrTag []
,Text "Please restart the server to start ",StrongTag [] [Text appName]]
showConfig :: Config [Maybe String] -> HtmlTag
showConfig config errors = TableTag []
[TrTag [ClassAttr (errclass error)] [ThTag [] [Text label,Text":"],TdTag [] [Text setting],TdTag [] (errmsg error) ] \\ (label,setting) <- fields & error <- errors]
where
fields = [("Client path", config.clientPath)
,("Static path", config.staticPath)
,("Root password", config.rootPassword)
,("Root e-mail", config.rootEmail)
,("Session time", toString config.sessionTime)
,("Server port", toString config.serverPort)
,("Server path", config.serverPath)
,("Debug", toString config.debug)
,("Smtp server", config.smtpServer)
,("Enable general workflows", toString config.generalWorkflows)
]
editConfig :: !Config ![Maybe String] -> HtmlTag
editConfig config errors = TableTag []
[TrTag [ClassAttr (errclass error)] [ThTag [] [Text label,Text":"],TdTag [] [input],TdTag [] (errmsg error)] \\ (label,input) <- fields & error <- errors]
where
fields = [("Client path",InputTag [TypeAttr "text",NameAttr "clientPath", ValueAttr config.clientPath])
,("Static path",InputTag [TypeAttr "text",NameAttr "staticPath", ValueAttr config.staticPath])
,("Root password",InputTag [TypeAttr "text",NameAttr "rootPassword", ValueAttr config.rootPassword])
,("Root e-mail",InputTag [TypeAttr "text",NameAttr "rootEmail", ValueAttr config.rootEmail])
,("Session time",InputTag [TypeAttr "text",NameAttr "sessionTime",SizeAttr "2", ValueAttr (toString config.sessionTime)])
,("Server port",InputTag [TypeAttr "text",NameAttr "serverPort",SizeAttr "2", ValueAttr (toString config.serverPort)])
,("Server path",InputTag [TypeAttr "text",NameAttr "serverPath", ValueAttr config.serverPath])
,("Debug",InputTag [TypeAttr "checkbox",NameAttr "debug":if config.debug [CheckedAttr] [] ])
,("Smtp server",InputTag [TypeAttr "text",NameAttr "smtpServer", ValueAttr config.smtpServer])
,("Enable general workflows",InputTag [TypeAttr "checkbox",NameAttr "generalWorkflows":if config.generalWorkflows [CheckedAttr] [] ])
]
errclass error = if (isNothing error) "field-ok" "field-error"
errmsg Nothing = []
errmsg (Just msg) = [EmTag [] [RawText msg]]