module MFlow.Forms.Ajax (ajaxCommand,ajaxHead) where
import MFlow
import MFlow.Forms
import Text.XHtml
import Control.Monad.Trans
import Data.RefSerialize (newContext,addrHash)
import Data.IORef
import System.IO.Unsafe
import Data.Maybe
import Control.Monad.State
import Data.Map (keys)
import qualified Data.CaseInsensitive as CI
context= unsafePerformIO newContext
ajaxCommand :: MonadIO m
=> String
-> (String -> IO String)
-> m (String)
ajaxCommand jsparam serverProc = do
r <- liftIO $ addrHash context serverProc
servname <- case r of
Left h -> do
let servname= "ajax"++ show h
liftIO $ addMessageFlows [( servname, serverp)]
return servname
Right h -> return $ "ajax"++ show h
return $ "doServer("++"'" ++ servname++"',"++jsparam++")"
where
serverp = stateless $ \env -> do
let c = lookup "ajax" env `justify` (error "not found ajax command")
serverProc c
justify = flip fromMaybe
ajaxHead :: Html -> Html
ajaxHead html=
(header << (script ![thetype "text/javascript"] << (
"function loadXMLObj()\n" ++
"{\n" ++
"var xmlhttp;\n" ++
"if (window.XMLHttpRequest)\n" ++
" {\n// code for IE7+, Firefox, Chrome, Opera, Safari\n" ++
" xmlhttp=new XMLHttpRequest();\n" ++
" }\n" ++
"else\n" ++
" {\n// code for IE6, IE5\n\n" ++
" xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');\n" ++
" }\n" ++
"return xmlhttp\n" ++
"}\n" ++
" xmlhttp= loadXMLObj()\n" ++
" noparam= ''\n"++
"\n"++
"function doServer (servproc,param){\n" ++
" xmlhttp.open('GET',servproc+'?ajax='+param,true);\n" ++
" xmlhttp.send();}\n" ++
"\n"++
"xmlhttp.onreadystatechange=function()\n" ++
" {\n" ++
" if (xmlhttp.readyState + xmlhttp.status==204)\n" ++
" { \n" ++
" eval(xmlhttp.responseText);\n" ++
" }\n" ++
" }\n" ++
"\n" )))
+++ body << html