{- | 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 , TemplateHaskell #-} module MFlow.Forms.Widgets ( -- * Ajax refreshing of widgets autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..) -- * 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 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 --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= cjqueryScript config jqueryCSS= cjqueryCSS config jqueryUI= cjqueryUI config nicEditUrl= cnicEditUrl config ------- 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 -- | 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 return username else do name <- getString Nothing notValid msg Nothing -> login name >> (return name) `wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name++ " ") ++> 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 $ mconcat form return . FormElm [] . 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)) -- (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= "$('#" <> fromString 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 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 -- where -- des1 _ bs= -- let s= B.unpack bs -- read . B.unpack -- in case s of -- ('T':'F':'i':'e':'l':'d':' ':s) -> -- let -- [(k,rest)] = readsPrec 0 s -- [(content,_)] = readsPrec 0 $ tail rest -- in TField k (fromString content) -- _ -> error "not match" setPersist = \_ -> Just filePersist --applyDeserializers [] k str = x where -- x= error $ "can not deserialize "++ B.unpack str++" to type: "++ show (typeOf x) -- --applyDeserializers (d:ds) k str= unsafePerformIO $ -- (return $! d k str) `catch` (\(_ :: SomeException)-> return (applyDeserializers ds k str)) 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){\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 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)] (ftag "div" mempty `attrs` [("id",ipanel)]) ++> notValid (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 = $('