{- | Some dynamic widgets, widgets that dynamically edit content in other widgets, widgets for templating, content management and multilanguage. And some primitives to create other active widgets. -} {-# LANGUAGE UndecidableInstances,ExistentialQuantification , FlexibleInstances, OverlappingInstances, FlexibleContexts , OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables #-} module MFlow.Forms.Widgets ( -- * Ajax refreshing of widgets autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..), lazy -- * JQueryUi widgets ,datePicker, getSpinner, wautocomplete, wdialog, -- * User Management userFormOrName,maybeLogout, wlogin, -- * Active widgets wEditList,wautocompleteList , wautocompleteEdit, -- * Editing widgets delEdited, getEdited, setEdited, prependWidget,appendWidget,setWidget -- * Content Management ,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey -- * Multilanguage ,mFieldEd, mField -- * utility ,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 --jqueryScript= "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js" --jqueryScript1="//code.jquery.com/jquery-1.9.1.js" -- --jqueryCSS1= "//code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css" --jqueryCSS= "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css" -- --jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js" --jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.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" ------- User Management ------ -- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented. -- The paremeters and the behaviour are the same as 'userWidget'. -- Only the display is different userFormOrName mode wid= userWidget mode wid `wmodify` f <** maybeLogout where f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input" f felem Nothing = do us <- getCurrentUser -- getEnv cookieuser if us == anonymous then return (felem, Nothing) else return([fromStr us], Just us) -- | Display a logout link if the user is logged. Nothing otherwise 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")) 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 -- | If not logged, it present a page flow which askm for the user name, then the password if not logged -- -- If logged, it present the user name and a link to logout -- -- normally to be used with autoRefresh and pageFlow when used with other widgets. wlogin :: (MonadIO m,Functor m,FormInput v) => View v m () wlogin= do username <- getCurrentUser if username /= anonymous then do private; noCache;noStore return username else do name <- getString Nothing notValid msg Nothing -> login name >> (return name) `wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name++ " ") ++> pageFlow "logout" (submitButton "logout")) -- 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 -- | Return the list of edited widgets (added by the active widgets) for a given identifier 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 -- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter delEdited :: (Typeable v, Typeable a, MonadIO m, MonadState (MFlowState view) m) => B.ByteString -- ^ identifier -> [View v m1 a] -> m () -- ^ withess 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 ([] `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 ++ 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 Identity a -> a typ = undefined -- | Return the javascript to be executed on the browser to prepend a widget to the location -- identified by the selector (the bytestring parameter), The selector must have the form of a jquery expression -- . It stores the added widgets in the edited list, that is accessed with 'getEdited' -- -- The resulting string can be executed in the browser. 'ajax' will return the code to -- execute the complete ajax roundtrip. This code returned by ajax must be in an eventhabdler. -- -- This example will insert a widget in the div when the element with identifier -- /clickelem/ is clicked. when the form is sbmitted, the widget values are returned -- and the list of edited widgets are deleted. -- -- > id1<- genNewId -- > let sel= "$('#" <> fromString id1 <> "')" -- > callAjax <- ajax . const $ prependWidget sel wn -- > let installevents= "$(document).ready(function(){\ -- > \$('#clickelem').click(function(){"++callAjax "''"++"});})" -- > -- > requires [JScriptFile jqueryScript [installevents] ] -- > ws <- getEdited sel -- > r <- (div <<< manyOf ws) delEdited sel ws' -- > return r prependWidget :: (Typeable a, MonadIO m, Executable m, FormInput v) => B.ByteString -- ^ jquery selector -> View v Identity a -- ^ widget to prepend -> View v m B.ByteString -- ^ string returned with the jquery string to be executed in the browser prependWidget sel w= modifyWidget sel "prepend" w -- | Like 'prependWidget' but append the widget instead of prepend. 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 -- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element 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 -- | Inside a tag, it add and delete widgets of the same type. When the form is submitted -- or a wlink is pressed, this widget return the list of validated widgets. -- the event for adding a new widget is attached , as a click event to the element of the page with the identifier /wEditListAdd/ -- that the user will choose. -- -- This example add or delete editable text boxes, with two initial boxes with -- /hi/, /how are you/ as values. Tt uses blaze-html: -- -- > r <- ask $ addLink -- > ++> br -- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid" -- > <++ br -- > <** submitButton "send" -- > -- > ask $ p << (show r ++ " returned") -- > ++> wlink () (p << text " back to menu") -- > mainmenu -- > where -- > addLink = a ! At.id "addid" -- > ! href "#" -- > $ text "add" -- > delBox = input ! type_ "checkbox" -- > ! checked "" -- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)" -- > getString1 mx= El.div <<< delBox ++> getString mx <++ br wEditList :: (Typeable a,Read a ,FormInput view ,Functor m,MonadIO m, Executable m) => (view ->view) -- ^ The holder tag -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string -> [String] -- ^ The initial list of values. -> String -- ^ The id of the button or link that will create a new list element when clicked -> View view m [a] wEditList holderview w xs 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 <<< (allOf $ ws' ++ map changeMonad ws)) Maybe String -- ^ Initial value -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings -> 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 [] -- [events] ,CSSFile jqueryCSS ,JScriptFile jqueryUI []] getString mv fromString text1<>"').autocomplete({ source: " <> fromString( show us) <> " });" -- | Produces a text box. It gives a autocompletion list to the textbox. When return -- is pressed in the textbox, the box content is used to create a widget of a kind defined -- by the user, which will be situated above of the textbox. When submitted, the result is the content -- of the created widgets (the validated ones). -- -- 'wautocompleteList' is an specialization of this widget, where -- the widget parameter is fixed, with a checkbox that delete the eleement when unselected -- . This fixed widget is as such (using generic 'FormElem' class tags): -- -- > ftag "div" <<< ftag "input" mempty -- > `attrs` [("type","checkbox") -- > ,("checked","") -- > ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")] -- > ++> ftag "span" (fromStr $ fromJust x ) -- > ++> whidden( fromJust x) wautocompleteEdit :: (Typeable a, MonadIO m,Functor m, Executable m , FormInput v) => String -- ^ the initial text of the box -> (String -> IO [String]) -- ^ the autocompletion procedure: receives a prefix, return a list of options. -> (Maybe String -> View v Identity a) -- ^ the widget to add, initialized with the string entered in the box -> [String] -- ^ initial set of values -> View v m [a] -- ^ resulting widget 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)] ++> allOf (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) <> " });" -- | A specialization of 'wutocompleteEdit' which make appear each chosen option with -- a checkbox that deletes the element when uncheched. The result, when submitted, is the list of selected elements. 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) ------- Templating and localization --------- 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 -- applyDeserializers [des1,des2] k bs 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 -- | Creates a rich text editor aroun a text field or a text area widget. -- This code: -- -- > page $ p "Insert the text" -- > ++> htmlEdit ["bold","italic"] "" -- > (getMultilineText "" <** submitButton "enter" -- -- Creates a rich text area with bold and italic buttons. The buttons are the ones alled -- in the nicEdit editor. 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 [JScriptFile nicEditUrl [installHtmlField,install]] w 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 -- ,JScriptFile jqueryScript [] ,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)\ \bkLib.onDomLoaded(function() {\ \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 = $('