module MFlow.Forms.Widgets (
datePicker, getSpinner, wautocomplete, wdialog,
userFormOrName,maybeLogout,
wEditList,wautocompleteList
, wautocompleteEdit,
delEdited, getEdited
,prependWidget,appendWidget,setWidget
,tField, tFieldEd, tFieldGen
,mFieldEd, mField
,autoRefresh
) 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 Control.Monad.Identity
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
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
:: (Typeable a,
FormInput v) =>
(v -> v)
-> String
-> String
-> String
-> (String -> View v IO a)
-> View v IO a
wpush holder modifier addId expr w = do
id1<- genNewId
let sel= "$('#" <> B.pack id1 <> "')"
callAjax <- ajax $ \s -> appendWidget sel ( changeMonad $ w s)
let installevents= "$(document).ready(function(){\
\$('#"++addId++"').click(function(){"++callAjax expr ++ "});})"
requires [JScriptFile jqueryScript [installevents] ]
ws <- getEdited sel
r <- holder <<< firstOf 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
ajaxc <- ajax $ \u -> do
r <- liftIO $ autocomplete u
return $ jaddtoautocomp r
requires [JScriptFile jqueryScript []
,CSSFile jqueryCSS
,JScriptFile jqueryUI []]
getString mv <! [("type", "text")
,("id", "text1")
,("oninput",ajaxc "$('#text1').attr('value')" )
,("autocomplete", "off")]
where
jaddtoautocomp us= "$('#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 sel= "$('#" <> B.pack id1 <> "')"
ajaxc <- ajax $ \(c:u) ->
case c of
'f' -> prependWidget sel (elem $ Just u)
_ -> do
r <- liftIO $ autocomplete u
return $ jaddtoautocomp r
requires [JScriptFile jqueryScript [events 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", "text1")
,("placeholder", phold)
,("oninput",ajaxc "'n'+$('#text1').attr('value')" )
,("autocomplete", "off")]
delEdited sel ws'
return r
where
events ajaxc=
"$(document).ready(function(){ \
\ $('#text1').keydown(function(){ \
\ if(event.keyCode == 13){ \
\ var v= $('#text1').attr('value'); \
\ if(event.preventDefault) event.preventDefault();\
\ else if(event.returnValue) event.returnValue = false;" ++
ajaxc "'f'+v"++";"++
" $('#text1').val('');\
\ }\
\ });\
\});"
jaddtoautocomp us= "$('#text1').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)
writetField k s= atomically $ writetFieldSTM k s
writetFieldSTM k s= do
phold <- readDBRef tFields `onNothing` return (M.fromList [])
let r= M.insert k (toByteString s) phold
writeDBRef tFields r
readtField text k= atomically $ do
hs<- readDBRef tFields `onNothing` return (M.fromList [])
let mp= M.lookup k hs
case mp of
Just c -> return $ fromStrNoEncode $ B.unpack c
Nothing -> writetFieldSTM k text >> return text
type TFields = M.Map String B.ByteString
instance Indexable TFields where
key _= "texts"
defPath _= "texts/"
tFields :: DBRef TFields
tFields = getDBRef "texts"
type Key= String
tFieldEd
:: (Functor m, MonadIO m, Executable m,
FormInput v) =>
Key -> v -> View v m ()
tFieldEd k text=
tFieldGen k (readtField text) writetField
tFieldGen :: (MonadIO m,Functor m, Executable m
,FormInput v)
=> Key
-> (Key -> IO v)
-> (Key ->v -> IO())
-> View v m ()
tFieldGen k getcontent create = wfreeze k 0 $ do
content <- liftIO $ getcontent k
admin <- getAdminName
ajaxjs <- ajax $ \str -> do
let (k,s)= break (==',') str !> str
liftIO . create k $ fromStrNoEncode (tail s)
liftIO $ flushCached k
return "alert('saved')"
attribs <- do
name <- genNewId
let ifUserAdmin= "if(document.cookie.search('"++cookieuser++"="++admin++"') != -1)"
nikeditor= "var myNicEditor = new nicEditor();"
callback=ifUserAdmin ++
"bkLib.onDomLoaded(function() {\
\ myNicEditor.addInstance('"++name++"');\
\});"
param= ("'"++k ++ "'+','+ document.getElementById('"++name++"').innerHTML")
requires [JScriptFile "http://js.nicedit.com/nicEdit-latest.js" [nikeditor, callback]]
return [("id", name),("ondblclick", ifUserAdmin ++ ajaxjs param)]
wraw $ (ftag "span" content `attrs` attribs)
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 k content= do
lang <- getLang
tFieldEd (k ++ ('-':lang)) content
mField k= do
lang <- getLang
tField $ k ++ ('-':lang)
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= do
id <- genNewId
let installscript=
"$(document).ready(function(){\n"
++ "ajaxGetLink('"++id++"');"
++ "ajaxPostForm('"++id++"');"
++ "})\n"
st <- get
r <- getParam1 ("auto"++id) $ mfEnv st
case r of
NoParam -> do
requires [JScript ajaxGetLink
,JScript ajaxPostForm
,JScriptFile jqueryScript [installscript]]
(ftag "div" <<< insertForm w) <! [("id",id)]
Validated (x :: String) -> View $ do
let t= mfToken st
FormElm form mr <- runView $ insertForm w
st <- get
let HttpData ctype c s= toHttpData $ mconcat form
liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st) (mfCookies st ++ c) s
put st{mfAutorefresh=True}
return $ FormElm [] mr
where
ajaxGetLink = "function ajaxGetLink(id){\n\
\var id1= $('#'+id);\n\
\var ida= $('#'+id+' a');\n\
\ida.click(function () {\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\
\ id1.html(resp);\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\
\}"
ajaxPostForm = "function ajaxPostForm(id) {\n\
\var id1= $('#'+id);\n\
\var idform= $('#'+id+' form');\n\
\idform.submit(function (event) {\n\
\event.preventDefault();\n\
\var $form = $(this);\n\
\var url = $form.attr('action');\n\
\var pdata = $form.serialize();\n\
\$.ajax({\n\
\type: 'GET',\n\
\url: url,\n\
\data: 'auto'+id+'=true&'+pdata,\n\
\success: function (resp) {\n\
\id1.html(resp);\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\
\}"
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)]