module MFlow.Forms.Widgets (
autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..), lazy
,datePicker, getSpinner, wautocomplete, wdialog,
userFormOrName,maybeLogout, wlogin,
wEditList,wautocompleteList
, wautocompleteEdit,
delEdited, getEdited, setEdited, prependWidget,appendWidget,setWidget
,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey
,mFieldEd, mField
,insertForm, readtField, writetField
) where
import MFlow
import MFlow.Forms
import MFlow.Forms.Internals
import Data.Monoid
import Data.ByteString.Lazy.UTF8 as B hiding (length,span)
import Data.ByteString.Lazy.Char8 (unpack)
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
import Control.Exception
import MFlow.Forms.Cache
--jqueryScript1="//code.jquery.com/jquery-1.9.1.js"
jqueryScript= getConfig "cjqueryScript" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
jqueryCSS= getConfig "cjqueryCSS" "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
jqueryUI= getConfig "cjqueryUI" "//code.jquery.com/ui/1.10.3/jquery-ui.js"
nicEditUrl= getConfig "cnicEditUrl" "//js.nicedit.com/nicEdit-latest.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)])
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
deriving Typeable
#else
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
#endif
wlogin :: (MonadIO m,Functor m,FormInput v) => View v m ()
wlogin= wform $ do
username <- getCurrentUser
if username /= anonymous
then do
private; noCache;noStore
return username
else do
name <- getString Nothing <! hint "login name"
<! size (9 :: Int)
<++ 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++ " ")
++> pageFlow "logout" (submitButton "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
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Typeable v, Typeable a, Typeable m1, MonadState (MFlowState view) m) =>
#else
:: (Typeable v, Typeable a, MonadState (MFlowState view) m) =>
#endif
B.ByteString -> m [View v m1 a]
getEdited id= do
r <- getEdited1 id
let (_,ws)= unzip r
return ws
delEdited
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Typeable v, Typeable a, MonadIO m, Typeable m1,
#else
:: (Typeable v, Typeable a, MonadIO m,
#endif
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)
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v, Typeable Identity, Typeable m)
#else
modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)
#endif
=> 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 form
return . FormElm mempty . Just $ selector <> "." <> modifier <> "('" <> elem <> "');"
where
typ :: View v m a -> a
typ = undefined
prependWidget
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m)
#else
:: (Typeable a, MonadIO m, Executable m, FormInput v)
#endif
=> B.ByteString
-> View v Identity a
-> View v m B.ByteString
prependWidget sel w= modifyWidget sel "prepend" w
appendWidget
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) =>
#else
:: (Typeable a, MonadIO m, Executable m, FormInput v) =>
#endif
B.ByteString -> View v Identity a -> View v m B.ByteString
appendWidget sel w= modifyWidget sel "append" w
setWidget
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) =>
#else
:: (Typeable a, MonadIO m, Executable m, FormInput v) =>
#endif
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
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
,Functor m,MonadIO m, Executable m, Typeable m, Typeable Identity)
#else
,Functor m,MonadIO m, Executable m)
#endif
=> (view ->view)
-> (Maybe a -> View view Identity a)
-> [a]
-> String
-> View view m [a]
wEditList holderview w xs addId = pageFlow addId $ do
let ws= map (w . Just) xs
wn= w Nothing
id1<- genNewId
let sel= "$('#" <> fromString 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
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= "$('#"<>fromString text1<>"').autocomplete({ source: " <> fromString( show us) <> " });"
wautocompleteEdit
:: (Typeable a, MonadIO m,Functor m, Executable m
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
, FormInput v, Typeable m, Typeable Identity)
#else
, FormInput v)
#endif
=> 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= "$('#" <> fromString 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= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> " });"
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
deriving instance Typeable Identity
#endif
wautocompleteList
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Functor m, MonadIO m, Executable m, FormInput v, Typeable m, Typeable Identity) =>
#else
:: (Functor m, MonadIO m, Executable m, FormInput v) =>
#endif
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) = content
deserialKey k content= TField k 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) -> if v /= mempty then return $ fromStrNoEncode $ toString v else return text
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){\
\if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\
\bkLib.onDomLoaded(function() {\
\var myNicEditor = new nicEditor({buttonList : buttons});\
\myNicEditor.panelInstance(name);\
\})};\n"
install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"
requires [JScript installHtmlField ,JScriptFile nicEditUrl [install]]
w <! [("id",id)]
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= "installEditField('"++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)]
us <- getCurrentUser
when(us== muser) noCache
(ftag "div" mempty `attrs` [("id",ipanel)]) ++>
notValid (ftag "span" content `attrs` [("id", name)])
installEditField=
"\nfunction installEditField(muser,cookieuser,name,ipanel){\
\if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1){\
\var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {\
\ajaxSendText(id,content);\
\myNicEditor.removeInstance(name);\
\myNicEditor.removePanel(ipanel);\
\}});\
\myNicEditor.addInstance(name);\
\myNicEditor.setPanel(ipanel);\
\}};\n"
ajaxSendText = "\nfunction ajaxSendText(id,content){\
\var arr= id.split('-');\
\var k= arr[1];\
\$.ajax({\
\type: 'POST',\
\url: '/_texts',\
\data: k + '='+ encodeURIComponent(content),\
\success: function (resp) {},\
\error: function (xhr, status, error) {\
\var msg = $('<div>' + xhr + '</div>');\
\id1.html(msg);\
\}\
\});\
\return false;\
\};\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
notValid content
mFieldEd muser k content= do
lang <- getLang
tFieldEd muser (k ++ ('-':lang)) content
mField k= do
lang <- getLang
tField $ k ++ ('-':lang)
data IteratedId = IteratedId String String deriving (Typeable, Show)
witerate
:: (MonadIO m, Functor m, FormInput v) =>
View v m a -> View v m a
witerate w= do
name <- genNewId
setSessionData $ IteratedId name mempty
st <- get
let t= mfkillTime st
let installAutoEval=
"$(document).ready(function(){\
\autoEvalLink('"++name++"',0);\
\autoEvalForm('"++name++"');\
\})\n"
let r = lookup ("auto"++name) $ mfEnv st
w'= w `wcallback` (const $ do
setSessionData $ IteratedId name mempty
modify $ \s -> s{mfPagePath=mfPagePath st
,mfSequence= mfSequence st
,mfHttpHeaders=[]}
w)
ret <- case r of
Nothing -> do
requires [JScript autoEvalLink
,JScript autoEvalForm
,JScript $ timeoutscript t
,JScriptFile jqueryScript [installAutoEval]
,JScript setId]
(ftag "div" <<< w') <! [("id",name)]
Just sind -> refresh $ View $ do
FormElm _ mr <- runView w'
IteratedId _ render <- getSessionData `onNothing` return (IteratedId name mempty)
return $ FormElm (fromStrNoEncode render) mr
delSessionData $ IteratedId name mempty
return ret
autoEvalLink = "\nfunction autoEvalLink(id,ind){\
\var id1= $('#'+id);\
\var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\
\ida.off('click');\
\ida.click(function () {\
\if (hadtimeout == true) return true;\
\var pdata = $(this).attr('data-value');\
\var actionurl = $(this).attr('href');\
\var dialogOpts = {\
\type: 'GET',\
\url: actionurl+'?auto'+id+'='+ind,\
\data: pdata,\
\success: function (resp) {\
\eval(resp);\
\autoEvalLink(id,ind);\
\autoEvalForm(id);\
\},\
\error: function (xhr, status, error) {\
\var msg = $('<div>' + xhr + '</div>');\
\id1.html(msg);\
\}\
\};\
\$.ajax(dialogOpts);\
\return false;\
\});\
\}\n"
autoEvalForm = "\nfunction autoEvalForm(id) {\
\var buttons= $('#'+id+' input[type=\"submit\"]');\
\var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\
\buttons.off('click');\
\buttons.click(function(event) {\
\if ($(this).attr('class') != '_noAutoRefresh'){\
\event.preventDefault();\
\if (hadtimeout == true) return true;\
\var $form = $(this).closest('form');\
\var url = $form.attr('action');\
\pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\
\postForm(id,url,pdata);\
\return false;\
\}else {\
\noajax= true;\
\return true;\
\}\
\})\
\\n\
\var noajax;\
\idform.submit(function(event) {\
\if(noajax) {noajax=false; return true;}\
\event.preventDefault();\
\var $form = $(this);\
\var url = $form.attr('action');\
\var pdata = 'auto'+id+'=true&' + $form.serialize();\
\postForm(id,url,pdata);\
\return false;})\
\}\
\function postForm(id,url,pdata){\
\var id1= $('#'+id);\
\$.ajax({\
\type: 'POST',\
\url: url,\
\data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\
\success: function (resp) {\
\eval(resp);\
\autoEvalLink(id,0);\
\autoEvalForm(id);\
\},\
\error: function (xhr, status, error) {\
\var msg = $('<div>' + xhr + '</div>');\
\id1.html(msg);\
\}\
\});\
\}"
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 render mx <- runView w
st <- get
let env = mfEnv st
IteratedId name scripts <- getSessionData `onNothing` return (IteratedId noid mempty)
let r = lookup ("auto"++name) env
if r == Nothing || (name == noid && newAsk st== True)
then return $ FormElm((ftag "span" render) `attrs` [("id",id)]) mx
else do
setSessionData $ IteratedId name $ scripts <> "setId('"++id++"','" ++ toString (toByteString $ render)++"');"
return $ FormElm mempty mx
noid= "noid"
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= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
requires [JScript installEditField
,JScriptFile nicEditUrl [install]
,JScript ajaxSendText
,JScriptFile jqueryScript []
,ServerProc ("_texts", transient getTexts)]
us <- getCurrentUser
when(us== muser) noCache
FormElm text mx <- runView w
content <- liftIO $ readtField 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
:: (MonadIO m, FormInput v, Typeable a) =>
Key -> View v m a -> View v m a
template k w= View $ do
FormElm text mx <- runView w
let content= unsafePerformIO $ readtField text k
return $ FormElm content mx
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() {\
\$('#"++id++"').dialog "++ conf ++";\
\var idform= $('#"++id++" form');\
\idform.submit(function(){$(this).dialog(\"close\")})\
\});"
modify $ \st -> st{needForm= HasForm}
requires
[CSSFile jqueryCSS
,JScriptFile jqueryScript []
,JScriptFile jqueryUI [setit]]
(ftag "div" <<< insertForm w) <! [("id",id),("title", title)]
autoRefresh
:: (MonadIO m,
FormInput v)
=> View v m a
-> View v m a
autoRefresh = update "html"
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)
=> String
-> View v m a
-> View v m a
update method w= do
id <- genNewId
st <- get
let t = mfkillTime st 1
installscript=
"$(document).ready(function(){\
\ajaxGetLink('"++id++"');\
\ajaxPostForm('"++id++"');\
\});"
st <- get
let insync = inSync st
let env= mfEnv st
let r= lookup ("auto"++id) env
if r == Nothing
then do
requires [JScript $ timeoutscript t
,JScript ajaxGetLink
,JScript ajaxPostForm
,JScriptFile jqueryScript [installscript]]
(ftag "div" <<< insertForm w) <! [("id",id)]
else refresh $ fromStr (method <> " ") ++> insertForm w
where
ajaxGetLink = "\nfunction ajaxGetLink(id){\
\var id1= $('#'+id);\
\var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\
\ida.off('click');\
\ida.click(function () {\
\if (hadtimeout == true) return true;\
\var pdata = $(this).attr('data-value');\
\var actionurl = $(this).attr('href');\
\var dialogOpts = {\
\type: 'GET',\
\url: actionurl+'?auto'+id+'=true',\
\data: pdata,\
\success: function (resp) {\
\var ind= resp.indexOf(' ');\
\var dat= resp.substr(ind);\
\var method= resp.substr(0,ind);\
\if(method== 'html')id1.html(dat);\
\else if (method == 'append') id1.append(dat);\
\else if (method == 'prepend') id1.prepend(dat);\
\else $(':root').html(resp);\
\ajaxGetLink(id);\
\ajaxPostForm(id);\
\},\
\error: function (xhr, status, error) {\
\var msg = $('<div>' + xhr + '</div>');\
\id1.html(msg);\
\}\
\};\
\$.ajax(dialogOpts);\
\return false;\
\});\
\}\n"
ajaxPostForm = "\nfunction ajaxPostForm(id) {\
\var buttons= $('#'+id+' input[type=\"submit\"]');\
\var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\
\buttons.off('click');\
\buttons.click(function(event) {\
\if ($(this).attr('class') != '_noAutoRefresh'){\
\event.preventDefault();\
\if (hadtimeout == true) return true;\
\var $form = $(this).closest('form');\
\var url = $form.attr('action');\
\pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\
\postForm(id,url,pdata);\
\return false;\
\}else {\
\noajax= true;\
\return true;\
\}\
\})\
\\n\
\var noajax;\
\idform.submit(function(event) {\
\if(noajax) {noajax=false; return true;}\
\event.preventDefault();\
\var $form = $(this);\
\var url = $form.attr('action');\
\var pdata = 'auto'+id+'=true&' + $form.serialize();\
\postForm(id,url,pdata);\
\return false;})\
\}\
\function postForm(id,url,pdata){\
\var id1= $('#'+id);\
\$.ajax({\
\type: 'POST',\
\url: url,\
\data: pdata,\
\success: function (resp) {\
\var ind= resp.indexOf(' ');\
\var dat = resp.substr(ind);\
\var method= resp.substr(0,ind);\
\if(method== 'html')id1.html(dat);\
\else if (method == 'append') id1.append(dat);\
\else if (method == 'prepend') id1.prepend(dat);\
\else $(':root').html(resp);\
\ajaxGetLink(id);\
\ajaxPostForm(id);\
\},\
\error: function (xhr, status, error) {\
\var msg = $('<div>' + xhr + '</div>');\
\id1.html(msg);\
\}\
\});\
\};"
timeoutscript t=
"\nvar hadtimeout=false;\
\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
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=runFlow . transientNav . ask $ w'
requires [ServerProc (procname, proc),
JScript $ ajaxPush procname,
JScriptFile jqueryScript [installscript]]
(ftag "div" <<< noWidget) <! [("id",id)]
<++ ftag "div" mempty `attrs` [("id",id++"status")]
where
w' = do
modify $ \s -> s{inSync= True,newAsk=True}
w
ajaxPush procname=" function ajaxPush(id,waititime){\
\var cnt=0; \
\var id1= $('#'+id);\
\var idstatus= $('#'+id+'status');\
\var ida= $('#'+id+' a');\
\var actionurl='/"++procname++"';\
\var dialogOpts = {\
\cache: false,\
\type: 'GET',\
\url: actionurl,\
\data: '',\
\success: function (resp) {\
\idstatus.html('');\
\cnt=0;\
\id1."++method++"(resp);\
\ajaxPush1();\
\},\
\error: function (xhr, status, error) {\
\cnt= cnt + 1;\
\if (false) \
\idstatus.html('no more retries');\
\else {\
\idstatus.html('waiting');\
\setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\
\}\
\}\
\};\
\function ajaxPush1(){\
\$.ajax(dialogOpts);\
\return false;\
\}\
\ajaxPush1();\
\}"
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() {\
\var spinner = $( '#"++id++"' ).spinner "++conf++";\
\spinner.spinner( \"enable\" );\
\});"
requires
[CSSFile jqueryCSS
,JScriptFile jqueryScript []
,JScriptFile jqueryUI [setit]]
getTextBox mv <! [("id",id)]
lazy :: (FormInput v,Functor m,MonadIO m) => v -> View v m a -> View v m a
lazy v w= do
id <- genNewId
st <- get
let path = currentPath st
env = mfEnv st
r= lookup ("auto"++id) env
t = mfkillTime st 1
installscript = "$(document).ready(function(){\
\function lazyexec(){lazy('"++id++"','"++ path ++"',lazyexec)};\
\$(window).one('scroll',lazyexec);\
\$(window).trigger('scroll');\
\});"
if r == Nothing then View $ do
requires [JScript lazyScript
,JScriptFile jqueryScript [installscript,scrollposition]]
reqs <- gets mfRequirements
FormElm _ mx <- runView w
modify $ \st-> st{mfRequirements= reqs}
return $ FormElm (ftag "div" v `attrs` [("id",id)]) mx
else refresh w
where
scrollposition= "$.fn.scrollposition= function(){\
\var pos= $(this).position();\
\if (typeof(pos)==='undefined') {return 1;}\
\else{\
\return pos.top - $( window ).scrollTop() - $( window ).height();\
\}};"
lazyScript= "function lazy (id,actionurl,f) {\
\var now = new Date().getTime(),\
\id1= $('#'+id),\
\lastCall= 0;\
\diff = now - lastCall;\
\if (diff < 5000) {\
\$(window).one('scroll',f);}\
\else {\
\lastCall = now;\
\if(id1.scrollposition() > 0){\
\$(window).one('scroll',f);}\
\else{\
\var dialogOpts = {\
\type: 'GET',\
\url: actionurl+'?auto'+id+'=true',\
\success: function (resp) {\
\id1.html(resp);\
\$(window).trigger('scroll');\
\},\
\error: function (xhr, status, error) {\
\var msg = $('<div>' + xhr + '</div>');\
\id1.html(msg);\
\}\
\};\
\$.ajax(dialogOpts);\
\}}};"
refresh w= View $ do
resetCachePolicy
modify $ \st -> st{mfAutorefresh=True,inSync= True}
FormElm form mx <- runView w
setCachePolicy
st' <- get
let t= mfToken st'
reqs <- installAllRequirements
let HttpData ctype c s= toHttpData $ toByteString form
liftIO . sendFlush t $ HttpData (ctype ++
mfHttpHeaders st') (mfCookies st' ++ c)
$ s <> toByteString reqs
return $ FormElm mempty mx