module MFlow.Forms.Widgets (
autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..)
,datePicker, getSpinner, wautocomplete, wdialog,
userFormOrName,maybeLogout, wlogin,
wEditList,wautocompleteList
, wautocompleteEdit,
delEdited, getEdited,prependWidget,appendWidget,setWidget
,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey
,mFieldEd, mField
,insertForm
) where
import MFlow
import MFlow.Forms
import MFlow.Forms.Internals
import Data.Monoid
import qualified Data.ByteString.Lazy.Char8 as B
import Control.Monad.Trans
import Data.Typeable
import Data.List
import System.IO.Unsafe
import Control.Monad.State
import Data.TCache
import Data.TCache.Defs
import Data.TCache.Memoization
import Data.RefSerialize hiding ((<|>))
import qualified Data.Map as M
import Data.IORef
import MFlow.Cookies
import Data.Maybe
import Data.Char
import Control.Monad.Identity
import Control.Workflow(killWF)
import Unsafe.Coerce
readyJQuery="ready=function(){if(!window.jQuery){return setTimeout(ready,100)}};"
jqueryScript1= "http://ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
jqueryScript="http://code.jquery.com/jquery-1.9.1.js"
jqueryCSS1= "http://code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"
jqueryCSS= "http://code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
jqueryUI1= "http://code.jquery.com/ui/1.9.1/jquery-ui.js"
jqueryUI= "http://code.jquery.com/ui/1.10.3/jquery-ui.js"
userFormOrName mode wid= userWidget mode wid `wmodify` f <** maybeLogout
where
f _ justu@(Just u) = return ([fromStr u], justu)
f felem Nothing = do
us <- getCurrentUser
if us == anonymous
then return (felem, Nothing)
else return([fromStr us], Just us)
maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m ()
maybeLogout= do
us <- getCurrentUser
if us/= anonymous
then do
cmd <- ajax $ const $ return "window.location=='/'" --refresh
fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout
else noWidget
data Medit view m a = Medit (M.Map B.ByteString [(String,View view m a)])
instance (Typeable view, Typeable a)
=>Typeable (Medit view m a) where
typeOf= \v -> mkTyConApp (mkTyCon3 "MFlow" "MFlow.Forms.Widgets" "Medit" )
[typeOf (tview v)
,typeOf (ta v)]
where
tview :: Medit v m a -> v
tview= undefined
tm :: Medit v m a -> m a
tm= undefined
ta :: Medit v m a -> a
ta= undefined
wlogin :: (MonadIO m,Functor m,FormInput v) => View v m ()
wlogin= do
username <- getCurrentUser
if username /= anonymous
then return username
else do
name <- getString Nothing <! hint "login name" <! size 9 <++ ftag "br" mempty
pass <- getPassword <! hint "password" <! size 9
<++ ftag "br" mempty
<** submitButton "login"
val <- userValidate (name,pass)
case val of
Just msg -> notValid msg
Nothing -> login name >> return name
`wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name)
++> wlink ("logout" :: String) (ftag "b" $ fromStr " logout"))
`wcallback` const (logout >> wlogin)
focus = [("onload","this.focus()")]
hint s= [("placeholder",s)]
size n= [("size",show n)]
getEdited1 id= do
Medit stored <- getSessionData `onNothing` return (Medit M.empty)
return $ fromMaybe [] $ M.lookup id stored
getEdited
:: (Typeable v, Typeable a, MonadState (MFlowState view) m) =>
B.ByteString -> m [View v m1 a]
getEdited id= do
r <- getEdited1 id
let (_,ws)= unzip r
return ws
delEdited
:: (Typeable v, Typeable a, MonadIO m,
MonadState (MFlowState view) m)
=> B.ByteString
-> [View v m1 a] -> m ()
delEdited id witness=do
Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
let (ks, ws)= unzip $ fromMaybe [] $ M.lookup id stored
return $ ws `asTypeOf` witness
liftIO $ mapM flushCached ks
let stored'= M.delete id stored
setSessionData . Medit $ stored'
setEdited id ws= do
Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
let stored'= M.insert id ws stored
setSessionData . Medit $ stored'
addEdited id w= do
ws <- getEdited1 id
setEdited id (w:ws)
modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)
=> B.ByteString -> B.ByteString -> View v Identity a -> View v m B.ByteString
modifyWidget selector modifier w = View $ do
ws <- getEdited selector
let n = length (ws `asTypeOf` [w])
let key= "widget"++ show selector ++ show n ++ show (typeOf $ typ w)
let cw = wcached key 0 w
addEdited selector (key,cw)
FormElm form _ <- runView cw
let elem= toByteString $ mconcat form
return . FormElm [] . Just $ selector <> "." <> modifier <>"('" <> elem <> "');"
where
typ :: View v Identity a -> a
typ = undefined
prependWidget
:: (Typeable a, MonadIO m, Executable m, FormInput v)
=> B.ByteString
-> View v Identity a
-> View v m B.ByteString
prependWidget sel w= modifyWidget sel "prepend" w
appendWidget
:: (Typeable a, MonadIO m, Executable m, FormInput v) =>
B.ByteString -> View v Identity a -> View v m B.ByteString
appendWidget sel w= modifyWidget sel "append" w
setWidget
:: (Typeable a, MonadIO m, Executable m, FormInput v) =>
B.ByteString -> View v Identity a -> View v m B.ByteString
setWidget sel w= modifyWidget sel "html" w
wEditList :: (Typeable a,Read a
,FormInput view
,Functor m,MonadIO m, Executable m)
=> (view ->view)
-> (Maybe String -> View view Identity a)
-> [String]
-> String
-> View view m [a]
wEditList holderview w xs addId = do
let ws= map (w . Just) xs
wn= w Nothing
id1<- genNewId
let sel= "$('#" <> B.pack id1 <> "')"
callAjax <- ajax . const $ prependWidget sel wn
let installevents= "$(document).ready(function(){\
\$('#"++addId++"').click(function(){"++callAjax "''"++"});})"
requires [JScriptFile jqueryScript [installevents] ]
ws' <- getEdited sel
r <- (holderview <<< (manyOf $ ws' ++ map changeMonad ws)) <! [("id",id1)]
delEdited sel ws'
return r
--wpush
wautocomplete
:: (Show a, MonadIO m, FormInput v)
=> Maybe String
-> (String -> IO a)
-> View v m String
wautocomplete mv autocomplete = do
text1 <- genNewId
ajaxc <- ajax $ \u -> do
r <- liftIO $ autocomplete u
return $ jaddtoautocomp text1 r
requires [JScriptFile jqueryScript []
,CSSFile jqueryCSS
,JScriptFile jqueryUI []]
getString mv <! [("type", "text")
,("id", text1)
,("oninput",ajaxc $ "$('#"++text1++"').attr('value')" )
,("autocomplete", "off")]
where
jaddtoautocomp text1 us= "$('#"<>B.pack text1<>"').autocomplete({ source: " <> B.pack( show us) <> " });"
wautocompleteEdit
:: (Typeable a, MonadIO m,Functor m, Executable m
, FormInput v)
=> String
-> (String -> IO [String])
-> (Maybe String -> View v Identity a)
-> [String]
-> View v m [a]
wautocompleteEdit phold autocomplete elem values= do
id1 <- genNewId
let textx= id1++"text"
let sel= "$('#" <> B.pack id1 <> "')"
ajaxc <- ajax $ \(c:u) ->
case c of
'f' -> prependWidget sel (elem $ Just u)
_ -> do
r <- liftIO $ autocomplete u
return $ jaddtoautocomp textx r
requires [JScriptFile jqueryScript [events textx ajaxc]
,CSSFile jqueryCSS
,JScriptFile jqueryUI []]
ws' <- getEdited sel
r<- (ftag "div" mempty `attrs` [("id", id1)]
++> manyOf (ws' ++ (map (changeMonad . elem . Just) values)))
<++ ftag "input" mempty
`attrs` [("type", "text")
,("id", textx)
,("placeholder", phold)
,("oninput", ajaxc $ "'n'+$('#"++textx++"').val()" )
,("autocomplete", "off")]
delEdited sel ws'
return r
where
events textx ajaxc=
"$(document).ready(function(){ \
\ $('#"++textx++"').keydown(function(){ \
\ if(event.keyCode == 13){ \
\ var v= $('#"++textx++"').val(); \
\ if(event.preventDefault) event.preventDefault();\
\ else if(event.returnValue) event.returnValue = false;" ++
ajaxc "'f'+v"++";"++
" $('#"++textx++"').val('');\
\ }\
\ });\
\});"
jaddtoautocomp textx us= "$('#"<>B.pack textx<>"').autocomplete({ source: " <> B.pack( show us) <> " });"
wautocompleteList
:: (Functor m, MonadIO m, Executable m, FormInput v) =>
String -> (String -> IO [String]) -> [String] -> View v m [String]
wautocompleteList phold serverproc values=
wautocompleteEdit phold serverproc wrender1 values
where
wrender1 x= ftag "div" <<< ftag "input" mempty
`attrs` [("type","checkbox")
,("checked","")
,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
++> ftag "span" (fromStr $ fromJust x )
++> whidden( fromJust x)
data TField = TField {tfieldKey :: Key, tfieldContent :: B.ByteString} deriving (Read, Show,Typeable)
instance Indexable TField where
key (TField k _)= k
defPath _= "texts/"
instance Serializable TField where
serialize (TField k content) = B.pack $ "TField "++show k ++ " " ++ show (B.unpack content)
deserialize bs=
let ('T':'F':'i':'e':'l':'d':' ':s)= B.unpack bs
[(k,rest)] = readsPrec 0 s
[(content,_)] = readsPrec 0 $ tail rest
in TField k (B.pack content)
setPersist = \_ -> Just filePersist
writetField k s= atomically $ writeDBRef (getDBRef k) $ TField k $ toByteString s
readtField text k= atomically $ do
let ref = getDBRef k
mr <- readDBRef ref
case mr of
Just (TField k v) -> return $ fromStrNoEncode $ B.unpack v
Nothing -> return text
htmlEdit :: (Monad m, FormInput v) => [String] -> UserStr -> View v m a -> View v m a
htmlEdit buttons jsuser w = do
id <- genNewId
let installHtmlField=
"\nfunction installHtmlField(muser,cookieuser,name,buttons){\n\
\if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\n\
\ bkLib.onDomLoaded(function() {\n\
\ var myNicEditor = new nicEditor({buttonList : buttons});\n\
\ myNicEditor.panelInstance(name);\n\
\})};\n"
install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"
requires [JScriptFile nicEditUrl [installHtmlField,install]]
w <! [("id",id)]
nicEditUrl= "http://js.nicedit.com/nicEdit-latest.js"
tFieldEd
:: (Functor m, MonadIO m, Executable m,
FormInput v) =>
UserStr -> Key -> v -> View v m ()
tFieldEd muser k text= wfreeze k 0 $ do
content <- liftIO $ readtField text k
nam <- genNewId
let ipanel= nam++"panel"
name= nam++"-"++k
install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
getTexts :: (Token -> IO ())
getTexts token = do
let (k,s):_ = tenv token
liftIO $ do
writetField k $ (fromStrNoEncode s `asTypeOf` text)
flushCached k
sendFlush token $ HttpData [] [] ""
return()
requires [JScriptFile nicEditUrl [install]
,JScript ajaxSendText
,JScript installEditField
,ServerProc ("_texts", transient getTexts)]
(ftag "div" mempty `attrs` [("id",ipanel)]) ++>
wraw (ftag "span" content `attrs` [("id", name)])
installEditField=
"\nfunction installEditField(muser,cookieuser,name,ipanel){\n\
\if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\n\
\ bkLib.onDomLoaded(function() {\n\
\ var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {\
\ ajaxSendText(id,content);\n\
\ myNicEditor.removeInstance(name);\n\
\ myNicEditor.removePanel(ipanel);\n\
\ }});\n\
\ myNicEditor.addInstance(name);\n\
\ myNicEditor.setPanel(ipanel);\n\
\})};\n"
ajaxSendText = "\nfunction ajaxSendText(id,content){\n\
\var arr= id.split('-');\n\
\var k= arr[1];\n\
\$.ajax({\n\
\ type: 'POST',\n\
\ url: '/_texts',\n\
\ data: k + '='+ encodeURIComponent(content),\n\
\ success: function (resp) {},\n\
\ error: function (xhr, status, error) {\n\
\ var msg = $('<div>' + xhr + '</div>');\n\
\ id1.html(msg);\n\
\ }\n\
\ });\n\
\return false;\n\
\};\n"
tField :: (MonadIO m,Functor m, Executable m, FormInput v)
=> Key
-> View v m ()
tField k = wfreeze k 0 $ do
content <- liftIO $ readtField (fromStrNoEncode "not found") k
wraw content
mFieldEd muser k content= do
lang <- getLang
tFieldEd muser (k ++ ('-':lang)) content
mField k= do
lang <- getLang
tField $ k ++ ('-':lang)
newtype IteratedId= IteratedId String deriving Typeable
witerate
:: (MonadIO m, Functor m, FormInput v) =>
View v m a -> View v m a
witerate w= do
name <- genNewId
setSessionData $ IteratedId name
st <- get
let index= mfPIndex st
let t= mfkillTime st
let installAutoEval=
"$(document).ready(function(){\n\
\autoEvalLink('"++name++"','"++ show index ++"');\
\autoEvalForm('"++name++"');\
\})\n"
let r = lookup ("auto"++name) $ mfEnv st
ret <- case r of
Nothing -> do
requires [JScript autoEvalLink
,JScript autoEvalForm
,JScript setId
,JScript $ timeoutscript t
,JScriptFile jqueryScript [installAutoEval]]
(ftag "div" <<< insertForm w) <! [("id",name)]
Just sind -> View $ do
let t= mfToken st
let index= read sind
put st{mfPIndex= index}
modify $ \s -> s{mfRequirements=[]}
FormElm _ mr <- runView w
reqs <- return . map ( \(Requirement r) -> unsafeCoerce r) =<< gets mfRequirements
let js = jsRequirements reqs
liftIO . sendFlush t $ HttpData
(("Cache-Control", "no-cache, no-store"):mfHttpHeaders st)
(mfCookies st) (B.pack js)
modify $ \st -> st{mfAutorefresh=True,inSync=True}
return $ FormElm [] mr
delSessionData $ IteratedId name
return ret
autoEvalLink = "\nfunction autoEvalLink(id,ind){\n\
\var id1= $('#'+id);\n\
\var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\n\
\ida.click(function () {\n\
\ if (hadtimeout == true) return true;\n\
\ var pdata = $(this).attr('data-value');\n\
\ var actionurl = $(this).attr('href');\n\
\ var dialogOpts = {\n\
\ type: 'GET',\n\
\ url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'='+ind,\n\
\ data: pdata,\n\
\ success: function (resp) {\n\
\ eval(resp);\n\
\ },\n\
\ error: function (xhr, status, error) {\n\
\ var msg = $('<div>' + xhr + '</div>');\n\
\ id1.html(msg);\n\
\ }\n\
\ };\n\
\ $.ajax(dialogOpts);\n\
\ return false;\n\
\});\n\
\}\n"
autoEvalForm = "\nfunction autoEvalForm(id) {\n\
\var id1= $('#'+id);\n\
\var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\n\
\idform.submit(function (event) {\n\
\if (hadtimeout == true) return true;\n\
\event.preventDefault();\n\
\var $form = $(this);\n\
\var url = $form.attr('action');\n\
\var pdata = $form.serialize();\n\
\$.ajax({\n\
\type: 'POST',\n\
\url: url,\n\
\data: 'auto'+id+'=true&'+pdata,\n\
\success: function (resp) {\n\
\eval(resp);\n\
\},\n\
\error: function (xhr, status, error) {\n\
\var msg = $('<div>' + xhr + '</div>');\n\
\id1.html(msg);\n\
\}\n\
\});\n\
\});\n\
\return false;\n\
\}\n"
setId= "function setId(id,v){document.getElementById(id).innerHTML= v;};\n"
dField
:: (Monad m, FormInput view) =>
View view m b -> View view m b
dField w= View $ do
id <- genNewId
FormElm vs mx <- runView w
let render = mconcat vs
st <- get
let env = mfEnv st
IteratedId name <- getSessionData `onNothing` return (IteratedId noid)
let r = lookup ("auto"++name) env
if r == Nothing || (name == noid && newAsk st== True) then do
requires [JScriptFile jqueryScript ["$(document).ready(function() {setId('"++id++"','" ++ B.unpack (toByteString $ render)++"')});\n"]]
return $ FormElm[(ftag "span" render) `attrs` [("id",id)]] mx
else do
requires [JScript $ "setId('"++id++"','" ++ B.unpack (toByteString $ render)++"');\n"]
return $ FormElm mempty mx
noid= "noid"
--edTemplateList
edTemplate
:: (MonadIO m, FormInput v, Typeable a) =>
UserStr -> Key -> View v m a -> View v m a
edTemplate muser k w= View $ do
nam <- genNewId
let ipanel= nam++"panel"
name= nam++"-"++k
install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
requires [JScriptFile nicEditUrl [install]
,JScript ajaxSendText
,JScript installEditField
,JScriptFile jqueryScript []
,ServerProc ("_texts", transient getTexts)]
FormElm text mx <- runView w
content <- liftIO $ readtField (mconcat text) k
return $ FormElm [ftag "div" mempty `attrs` [("id",ipanel)]
,ftag "span" content `attrs` [("id", name)]]
mx
where
getTexts :: (Token -> IO ())
getTexts token= do
let (k,s):_ = tenv token
liftIO $ do
writetField k $ (fromStrNoEncode s `asTypeOf` viewFormat w)
flushCached k
sendFlush token $ HttpData [] [] ""
return()
viewFormat :: View v m a -> v
viewFormat= undefined
template k w= View $ do
FormElm text mx <- runView w
let content= unsafePerformIO $ readtField (mconcat text) k
return $ FormElm [content] mx
--edTemplateList
jsInsertList =
"\nfunction insert(id,vs){\n\
\$('[_holder=\"'+id+'\"]').each(function(n,it) {\n\
\ $(it).html(vs[n]);\n\
\})};\n"
datePicker :: (Monad m, FormInput v) => String -> Maybe String -> View v m (Int,Int,Int)
datePicker conf jd= do
id <- genNewId
let setit= "$(document).ready(function() {\
\$( '#"++id++"' ).datepicker "++ conf ++";\
\});"
requires
[CSSFile jqueryCSS
,JScriptFile jqueryScript []
,JScriptFile jqueryUI [setit]]
s <- getString jd <! [("id",id)]
let (month,r) = span (/='/') s
let (day,r2)= span(/='/') $ tail r
return (read day,read month, read $ tail r2)
wdialog :: (Monad m, FormInput v) => String -> String -> View v m a -> View v m a
wdialog conf title w= do
id <- genNewId
let setit= "$(document).ready(function() {\n\
\$('#"++id++"').dialog "++ conf ++";\n\
\var idform= $('#"++id++" form');\n\
\idform.submit(function(){$(this).dialog(\"close\")})\n\
\});"
modify $ \st -> st{needForm= False}
requires
[CSSFile jqueryCSS
,JScriptFile jqueryScript []
,JScriptFile jqueryUI [setit]]
(ftag "div" <<< insertForm w) <! [("id",id),("title", title)]
insertForm w=View $ do
FormElm forms mx <- runView w
st <- get
cont <- case needForm st of
True -> do
frm <- formPrefix (mfPIndex st) (twfname $ mfToken st ) st forms False
return frm
_ -> return $ mconcat forms
put st{needForm= False}
return $ FormElm [cont] mx
autoRefresh
:: (MonadIO m,
FormInput v)
=> View v m a
-> View v m a
autoRefresh w= update "html" w
noAutoRefresh= [("class","_noAutoRefresh")]
appendUpdate :: (MonadIO m,
FormInput v)
=> View v m a
-> View v m a
appendUpdate= update "append"
prependUpdate :: (MonadIO m,
FormInput v)
=> View v m a
-> View v m a
prependUpdate= update "prepend"
update :: (MonadIO m,
FormInput v)
=> B.ByteString
-> View v m a
-> View v m a
update method w= do
id <- genNewId
st <- get
let t = mfkillTime st 1
let installscript=
"$(document).ready(function(){\n"
++ "ajaxGetLink('"++id++"');"
++ "ajaxPostForm('"++id++"');"
++ "})\n"
let r= lookup ("auto"++id) $ mfEnv st
case r of
Nothing -> do
requires [JScript $ timeoutscript t
,JScript ajaxGetLink
,JScript ajaxPostForm
,JScriptFile jqueryScript [installscript]]
(ftag "div" <<< insertForm w) <! [("id",id)]
Just sind -> View $ do
let t= mfToken st
FormElm form mr <- runView $ insertForm w
st <- get
let HttpData ctype c s= toHttpData $ method <> " " <> toByteString (mconcat form)
liftIO . sendFlush t $ HttpData (ctype ++ ("Cache-Control", "no-cache, no-store"):mfHttpHeaders st) (mfCookies st ++ c) s
put st{mfAutorefresh=True,inSync=True}
return $ FormElm [] mr
where
ajaxGetLink = "\nfunction ajaxGetLink(id){\n\
\var id1= $('#'+id);\n\
\var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\n\
\ida.click(function () {\n\
\if (hadtimeout == true) return true;\n\
\var pdata = $(this).attr('data-value');\n\
\var actionurl = $(this).attr('href');\n\
\var dialogOpts = {\n\
\ type: 'GET',\n\
\ url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'=true',\n\
\ data: pdata,\n\
\ success: function (resp) {\n\
\ var ind= resp.indexOf(' ');\n\
\ var dat = resp.substr(ind);\n\
\ var method= resp.substr(0,ind);\n\
\ if(method== 'html')id1.html(dat);\n\
\ else if (method == 'append') id1.append(dat);\n\
\ else id1.prepend(dat);\n\
\ ajaxGetLink(id);\n\
\ },\n\
\ error: function (xhr, status, error) {\n\
\ var msg = $('<div>' + xhr + '</div>');\n\
\ id1.html(msg);\n\
\ }\n\
\ };\n\
\$.ajax(dialogOpts);\n\
\return false;\n\
\});\n\
\}\n"
ajaxPostForm = "\nfunction ajaxPostForm(id) {\n\
\var id1= $('#'+id);\n\
\var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\n\
\idform.submit(function (event) {\n\
\if (hadtimeout == true) return true;\n\
\event.preventDefault();\n\
\var $form = $(this);\n\
\var url = $form.attr('action');\n\
\var pdata = $form.serialize();\n\
\$.ajax({\n\
\type: 'POST',\n\
\url: url,\n\
\data: 'auto'+id+'=true&'+pdata,\n\
\success: function (resp) {\n\
\ var ind= resp.indexOf(' ');\n\
\ var dat = resp.substr(ind);\n\
\ var method= resp.substr(0,ind);\n\
\ if(method== 'html')id1.html(dat);\n\
\ else if (method == 'append') id1.append(dat);\n\
\ else id1.prepend(dat);\n\
\ ajaxPostForm(id);\n\
\},\n\
\error: function (xhr, status, error) {\n\
\var msg = $('<div>' + xhr + '</div>');\n\
\id1.html(msg);\n\
\}\n\
\});\n\
\});\n\
\return false;\n\
\}\n"
timeoutscript t=
"\nvar hadtimeout=false;\n\
\if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n"
data UpdateMethod= Append | Prepend | Html deriving Show
push :: FormInput v
=> UpdateMethod
-> Int
-> View v IO ()
-> View v IO ()
push method' wait w= push' . map toLower $ show method'
where
push' method= do
id <- genNewId
st <- get
let token= mfToken st
dat= mfData st
procname= "_push" ++ tind token ++ id
installscript=
"$(document).ready(function(){\n"
++ "ajaxPush('"++id++"',"++show wait++");"
++ "})\n"
new <- gets newAsk
when new $ do
killWF procname token{twfname= procname}
let proc= transient . runFlow . ask $ w' dat
requires [ServerProc (procname, proc),
JScript $ ajaxPush procname,
JScriptFile jqueryScript [installscript]]
(ftag "div" <<< noWidget) <! [("id",id)]
<++ ftag "div" mempty `attrs` [("id",id++"status")]
where
w' dat= do
modify $ \s -> s{inSync= True,newAsk=True,mfData=dat}
w
ajaxPush procname=" function ajaxPush(id,waititime){\n\
\var cnt=0; \n\
\var id1= $('#'+id);\n\
\var idstatus= $('#'+id+'status');\n\
\var ida= $('#'+id+' a');\n\
\ var actionurl='/"++procname++"';\n\
\ var dialogOpts = {\n\
\ cache: false,\n\
\ type: 'GET',\n\
\ url: actionurl,\n\
\ data: '',\n\
\ success: function (resp) {\n\
\ idstatus.html('')\n\
\ cnt=0;\n\
\ id1."++method++"(resp);\n\
\ ajaxPush1();\n\
\ },\n\
\ error: function (xhr, status, error) {\n\
\ cnt= cnt + 1;\n\
\ if (cnt > 6)\n\
\ idstatus.html('no more retries');\n\
\ else {\n\
\ idstatus.html('waiting');\n\
\ setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\n\
\ }\n\
\ }\n\
\ };\n\
\function ajaxPush1(){\n\
\ $.ajax(dialogOpts);\n\
\ return false;\n\
\ }\n\
\ ajaxPush1();\n\
\}"
getSpinner
:: (MonadIO m, Read a,Show a, Typeable a, FormInput view) =>
String -> Maybe a -> View view m a
getSpinner conf mv= do
id <- genNewId
let setit= "$(document).ready(function() {\n\
\var spinner = $( '#"++id++"' ).spinner "++conf++";\n\
\spinner.spinner( \"enable\" );\n\
\});"
requires
[CSSFile jqueryCSS
,JScriptFile jqueryScript []
,JScriptFile jqueryUI [setit]]
getTextBox mv <! [("id",id)]