implementation module Engine import StdMisc, StdArray, StdList, StdChar, StdFile, StdBool from StdFunc import o from StdLibMisc import qualified ::Date{..}, ::Time{..} from Directory import qualified pd_StringToPath, createDirectory, getFileInfo, ::DirError(..), ::FileInfo(..), ::PI_FileInfo(..), instance == DirError import Store, UserDB, ProcessDB, SessionDB import Text, Util, HtmlUtil import CommandLine import TuningCombinators import Http, HttpUtil from HttpServer import :: HTTPServerControl(..), :: HTTPServerOption(..) import Setup import ApplicationService, SessionService, WorkflowService, TaskService, UserService, DocumentService import Config, TSt from UserAdmin import manageUsers from Messages import manageMessages from Lists import manageLists from Groups import manageGroups PATH_SEP :== "\\" // The iTasks engine consist of a set of HTTP request handlers engine :: !(Maybe Config) [Workflow] -> [(!String -> Bool, HTTPRequest *World -> (!HTTPResponse, !HTTPServerControl, !*World))] engine mbConfig userWorkflows = case mbConfig of Just config = handlers config Nothing = [(\_ -> True, setupHandler handlers)] where handlers config # flows = adminWorkflows ++ (if config.generalWorkflows generalWorkflows [] ) ++ userWorkflows = [ // Handler to stop the server nicely ((==) "/stop", handleStopRequest) // Webservices ,(startsWith config.serverPath, serviceDispatch config flows) ,(\_ -> True, handleStaticResourceRequest config) ] adminWorkflows = [restrictedWorkflow "Admin/Users" "Manage system users" ["admin"] manageUsers] generalWorkflows = [workflow "Messages" "Send and receive messages" manageMessages ,workflow "Lists" "Create and manage various lists" manageLists ,workflow "Groups" "Manage user groups" manageGroups ] serviceDispatch config flows req world # tst = initTSt req config flows world # reqpath = (http_urldecode req.req_path) # reqpath = reqpath % (size config.serverPath, size reqpath) # (response,tst) = case (split "/" reqpath) of [""] = (redirectResponse (req.req_path +++ "/html"), tst) ["","html"] = (overviewResponse, tst) ["",format:path] # html = format == "html" # json = format == "json" | html || json = case path of ["application":path] = applicationService req.req_path html path req tst ["sessions":path] = sessionService req.req_path html path req tst ["workflows":path] = workflowService req.req_path html path req tst ["tasks":path] = taskService req.req_path html path req tst ["users":path] = userService req.req_path html path req tst ["documents":path] = documentService req.req_path html path req tst _ = (notFoundResponse req, tst) | otherwise = (notFoundResponse req, tst) _ = (notFoundResponse req, tst) # tst = flushStore tst = (response, HTTPServerContinue, finalizeTSt tst) workflow :: !String !String !(Task a) -> Workflow | iTask a workflow path description task = { Workflow | path = path , roles = [] , thread = createThread (task <<@ Subject name) , description = description } where name = last (split "/" path) restrictedWorkflow :: !String !String ![Role] !(Task a) -> Workflow | iTask a restrictedWorkflow path description roles task = { Workflow | path = path , roles = roles , thread = createThread (task <<@ Subject name) , description = description } where name = last (split "/" path) config :: !*World -> (!Maybe Config,!*World) config world # (appName,world) = determineAppName world = loadConfig appName world // Request handler which serves static resources from the application directory, // or a system wide default directory if it is not found locally. // This request handler is used for serving system wide javascript, css, images, etc... handleStaticResourceRequest :: !Config !HTTPRequest *World -> (!HTTPResponse,!HTTPServerControl,!*World) handleStaticResourceRequest config req world # path = if (req.req_path == "/") "/index.html" req.req_path # filename = config.clientPath +++ filePath path # (type, world) = http_staticFileMimeType filename world # (ok, content, world) = http_staticFileContent filename world | ok = ({rsp_headers = [("Status","200 OK"), ("Content-Type", type), ("Content-Length", toString (size content))] ,rsp_data = content}, HTTPServerContinue, world) # filename = config.staticPath +++ filePath path # (type, world) = http_staticFileMimeType filename world # (ok, content, world) = http_staticFileContent filename world | ok = ({rsp_headers = [("Status","200 OK"), ("Content-Type", type), ("Content-Length", toString (size content)) ] ,rsp_data = content}, HTTPServerContinue, world) = (notFoundResponse req,HTTPServerContinue,world) where //Translate a URL path to a filesystem path filePath path = ((replaceSubString "/" PATH_SEP) o (replaceSubString ".." "")) path handleStopRequest :: HTTPRequest *World -> (!HTTPResponse,!HTTPServerControl,!*World) handleStopRequest req world = ({http_emptyResponse & rsp_data = "Server stopped..."},HTTPServerStop, world) initTSt :: !HTTPRequest !Config ![Workflow] !*World -> *TSt initTSt request config flows world # (appName,world) = determineAppName world # (pathstr,world) = determineAppPath world # ((ok, path),world) = 'Directory'.pd_StringToPath (pathstr) world | not ok = abort "Cannot find the executable." # ((err,info),world) = 'Directory'.getFileInfo path world | err <> 'Directory'.NoDirError = abort "Cannot get executable info." # (date,time) = info.'Directory'.pi_fileInfo.'Directory'.lastModified # datestr = (toString date.'StdLibMisc'.Date.'StdLibMisc'.year)+++"."+++ (padZero date.'StdLibMisc'.Date.'StdLibMisc'.month)+++"."+++ (padZero date.'StdLibMisc'.Date.'StdLibMisc'.day)+++"-"+++ (padZero time.'StdLibMisc'.Time.'StdLibMisc'.hours)+++"."+++ (padZero time.'StdLibMisc'.Time.'StdLibMisc'.minutes)+++"."+++ (padZero time.'StdLibMisc'.Time.'StdLibMisc'.seconds ) # ((ok,datapath),world) = 'Directory'.pd_StringToPath appName world # (err,world) = 'Directory'.createDirectory datapath world | err <> 'Directory'.NoDirError && err <> 'Directory'.AlreadyExists = abort "Cannot create data directory" = mkTSt appName config request flows (createStore (appName +++ "\\" +++ datestr)) world where padZero number = (if (number < 10) "0" "") +++ toString number finalizeTSt :: !*TSt -> *World finalizeTSt tst=:{TSt|iworld={IWorld|world}} = world // Determines the server executables path determineAppPath :: !*World -> (!String, !*World) determineAppPath world # (args,world) = getCommandLine world = (hd args,world) // Determines the server executables name determineAppName :: !*World -> (!String,!*World) determineAppName world # (args,world) = getCommandLine world = (strip (hd args),world) where strip path = let executable = last (split PATH_SEP path) in executable % (0, size executable - 5)