module MFlow.Forms.Widgets (
userFormOrName,maybeLogout,
wEditList,wautocomplete,wautocompleteList
, wautocompleteEdit,
delEdited, getEdited
,prependWidget,appendWidget,setWidget
,tField, tFieldEd, tFieldGen
,mFieldEd, mField
) 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)}};"
jqueryScript= "http://ajax.googleapis.com/ajax/libs/jquery/1.8.3/jquery.min.js"
jqueryCSS= "http://code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"
jqueryUI= "http://code.jquery.com/ui/1.9.1/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 (k,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
(ks,ws) <- return . unzip =<< getEdited1 id
return $ ws `asTypeOf` witness
mapM (liftIO . flushCached) ks
setEdited id ([] `asTypeOf` (zip (repeat "") witness))
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
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 <> "');"
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
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
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) => Maybe String -> View v m (Int,Int,Int)
datePicker jd= do
id <- genNewId
let setit= "$(function() {\
\$( '"++id++"' ).datepicker();\
\});"
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)