implementation module HtmlUtil import HTML, JSON, Text, HTTP, Map import StdList, StdBool embeddedStyle :: HtmlTag embeddedStyle = StyleTag [TypeAttr "text/css"] [RawText css] where css = "body { background: #fff; font-family: Verdana, Arial, sans-serif; font-size: 12px;} th { text-align: left; } " +++ ".field-error em {color: #f00; font-weight: bold} .field-error input {border-color: #f00;} " +++ "#main {margin: 20px; background: #d1dded; border: solid 2px #3a81ad; -moz-border-radius: 5px; background: -moz-linear-gradient(bottom, #d1dded, #fff);} " +++ "#content { padding: 10px; } " +++ ".buttons { padding: 5px; background-color: #3a81ad; } " +++ ".section { margin: 10px; padding: 5px; overflow: auto;} " +++ ".description { margin: 0px 15px 0px 15px; } " +++ ".parameters th, { width: 150px; } " +++ ".json { font-family: Courier, monotype; font-size: 12px;} " +++ ".json ul { padding-left: 15px;} " +++ "h1 { margin: 10px 15px 10px 15px; font-weight: normal; font-size: 24px;} " +++ "h2 { margin: 5px 5px 5px 0px; font-weight: bold; font-size: 14px; border: solid #999; border-width: 0px 0px 1px 0px;} " +++ "p { margin: 0px 0px 10px 0px; } " +++ "button {-moz-border-radius: 3px; }" pageLayout :: !String !String ![HtmlTag] -> HtmlTag pageLayout title description content = HtmlTag [] [head,body] where head = HeadTag [] [TitleTag [] [Text title], embeddedStyle] body = BodyTag [] [DivTag [IdAttr "main"] (header ++ content)] header = [H1Tag [] [Text title],PTag [] [DivTag [ClassAttr "description"] [RawText description]]] servicePage :: !String !String !String ![(String,String,Bool)] !JSONNode -> HtmlTag servicePage title description url params json = pageLayout title description [parameters, message, alternatives] where parameters = pageSection "Parameters" [FormTag [ActionAttr url,MethodAttr "get"] [TableTag [ClassAttr "parameters"] (rows ++ send)]] rows = [TrTag [] [ThTag [] [Text n : if o [Text "*:"] [Text ":"]], TdTag [] [InputTag [NameAttr n, ValueAttr v]]] \\ (n,v,o) <- params] send = [TrTag [] [TdTag [ColspanAttr "4"] [ButtonTag [TypeAttr "submit"] [Text "Send"]]]] message = pageSection "Data" [DivTag [ClassAttr "json"] (formatJSON json)] jsonurl = replaceSubString "services/html" "services/json" url alternatives= pageSection "Alternative representations" [PTag [] [Text "JSON: ", ATag [HrefAttr jsonurl] [Text jsonurl]]] serviceResponse :: !Bool !String !String !String ![(String,String,Bool)] !JSONNode -> HTTPResponse serviceResponse html title description url params json = if html {newHTTPResponse & rsp_data = toString (servicePage title description url params json)} { newHTTPResponse //Content-Type for JSON should be "application/json", see http://www.ietf.org/rfc/rfc4627.txt & rsp_headers = put "Content-Type" "application/json" (newHTTPResponse.rsp_headers) , rsp_data = toString json } formatJSON :: !JSONNode -> [HtmlTag] formatJSON (JSONNull) = [Text "null"] formatJSON (JSONBool True) = [Text "true"] formatJSON (JSONBool False) = [Text "false"] formatJSON (JSONInt i) = [Text (toString i)] formatJSON (JSONReal r) = [Text (toString r)] formatJSON (JSONString s) = [Text "\"", Text s, Text "\""] formatJSON (JSONArray items) = [UlTag [] [LiTag [] (formatJSON node) \\ node <- items] ] formatJSON (JSONObject fields) = [UlTag [] [LiTag [] [Text label,Text ": " :formatJSON node] \\(label,node) <- fields ] ] formatJSON (JSONRaw r) = [PreTag [] [Text (toString r)]] formatJSON _ = [] overviewPage :: HtmlTag overviewPage = pageLayout "Services" description [application,sessions,workflows,tasks,users,documents,stencils] where description = "This application can be accessed through a RESTful JSON API.
Below is an overview of the available service urls." application = pageSection "application" [ATag [HrefAttr "html/application"] [Text "General information information about this application"]] sessions = pageSection "sessions" [ATag [HrefAttr "html/sessions"] [Text "Authentication and session management"]] workflows = pageSection "workflows" [ATag [HrefAttr "html/workflows"] [Text "A catalogue of available workflows"]] tasks = pageSection "tasks" [ATag [HrefAttr "html/tasks"] [Text "Listing of and working on tasks"]] users = pageSection "users" [ATag [HrefAttr "html/users"] [Text "User management"]] documents = pageSection "documents" [ATag [HrefAttr "html/documents"] [Text "Upload/download of binary files"]] stencils = pageSection "stencils" [ATag [HrefAttr "html/stencils"] [Text "Catalogue of stencils for use in graphical workflow diagrams"]] overviewResponse :: HTTPResponse overviewResponse = {newHTTPResponse & rsp_data = toString overviewPage} appStartPage :: !String -> HtmlTag appStartPage appName = HtmlTag [] [head,body] where head = HeadTag [] [TitleTag [] [Text "Loading..."]: styles ++ scripts] body = BodyTag [] [] styles = [LinkTag [RelAttr "stylesheet", HrefAttr file, TypeAttr "text/css"] [] \\ file <- stylefiles] scripts = [ScriptTag [SrcAttr file, TypeAttr "text/javascript"] [] \\ file <- scriptfiles] stylefiles = ["/lib/ext-4.0.2a/resources/css/ext-all-gray.css" ,"/src/static/skins/default/main.css" ,appName +++ ".css"] scriptfiles = ["/lib/ext-4.0.2a/ext-debug.js","src/app.js"] /** * Creates an HTTP response of the start page */ appStartResponse :: !String -> HTTPResponse appStartResponse appName = {newHTTPResponse & rsp_data = toString (appStartPage appName)} redirectResponse :: !String -> HTTPResponse redirectResponse url = {HTTPResponse | rsp_headers = fromList [("Status","302 - Found"),("Location",url)], rsp_data = ""} notFoundPage :: !HTTPRequest -> HtmlTag notFoundPage req = pageLayout "404 - Not Found" "" message where message = [DivTag [IdAttr "content"] [Text "The resource you tried to access ",StrongTag [] [Text req.req_path], Text " could not be found."]] notFoundResponse :: !HTTPRequest -> HTTPResponse notFoundResponse req = {HTTPResponse | rsp_headers = fromList [("Status","404 - Not Found")], rsp_data = toString (notFoundPage req)} pageSection :: !String ![HtmlTag] -> HtmlTag pageSection title content = DivTag [ClassAttr "section"] [H2Tag [] [Text title]:content] paramValue :: !String !HTTPRequest -> String paramValue name req = case get name req.arg_post of Just val = val Nothing = case get name req.arg_get of Just val = val Nothing = "" NEWLINE :== "\n" nl2br :: !String -> HtmlTag nl2br str = html [[Text line,BrTag []] \\ line <- split NEWLINE str] html2text :: !String -> String html2text s # s = replaceSubString "
" NEWLINE s # s = replaceSubString "
" NEWLINE s # s = replaceSubString "
" NEWLINE s # s = replaceSubString "
" NEWLINE s # s = replaceSubString "" NEWLINE s # s = stripHtmlTags s # s = replaceSubString " " " " s # s = replaceSubString "<" "<" s # s = replaceSubString ">" ">" s # s = replaceSubString "&" "&" s = s where stripHtmlTags s # fstOpen = indexOf "<" s # fstClose = indexOf ">" s | fstOpen <> -1 && fstClose <> -1 && fstOpen < fstClose = stripHtmlTags (subString 0 fstOpen s +++ subString (fstClose + 1) (textSize s - fstClose) s) | otherwise = s