MFlow 0.4.5.3 → 0.4.5.4
raw patch · 5 files changed
+188/−112 lines, 5 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- MFlow: Config1 :: (Map String String) -> Config
- MFlow: newtype Config
- MFlow: setConfig :: String -> String -> IO ()
- MFlow.Forms: installRequirements :: (Requirements a, Monad m, FormInput view) => [a] -> m view
+ MFlow.Forms: installRequirements :: (Requirements a, Monad m, FormInput view) => Bool -> [a] -> m view
- MFlow.Forms: setEncryptedCookie :: (Show a, MonadState (MFlowState view) m) => String -> String -> String -> Maybe a -> m ()
+ MFlow.Forms: setEncryptedCookie :: MonadState (MFlowState view) m => String -> String -> String -> Maybe Integer -> m ()
- MFlow.Forms: setParanoidCookie :: (Show a, MonadState (MFlowState view) m) => String -> String -> String -> Maybe a -> m ()
+ MFlow.Forms: setParanoidCookie :: MonadState (MFlowState view) m => String -> String -> String -> Maybe Integer -> m ()
- MFlow.Forms.Internals: installRequirements :: (Requirements a, Monad m, FormInput view) => [a] -> m view
+ MFlow.Forms.Internals: installRequirements :: (Requirements a, Monad m, FormInput view) => Bool -> [a] -> m view
- MFlow.Forms.Internals: installWebRequirements :: (Monad m, FormInput view) => [WebRequirement] -> m view
+ MFlow.Forms.Internals: installWebRequirements :: (Monad m, FormInput view) => Bool -> [WebRequirement] -> m view
- MFlow.Forms.Internals: jsRequirements :: [WebRequirement] -> [Char]
+ MFlow.Forms.Internals: jsRequirements :: Bool -> [WebRequirement] -> [Char]
- MFlow.Forms.Internals: setEncryptedCookie :: (Show a, MonadState (MFlowState view) m) => String -> String -> String -> Maybe a -> m ()
+ MFlow.Forms.Internals: setEncryptedCookie :: MonadState (MFlowState view) m => String -> String -> String -> Maybe Integer -> m ()
- MFlow.Forms.Internals: setParanoidCookie :: (Show a, MonadState (MFlowState view) m) => String -> String -> String -> Maybe a -> m ()
+ MFlow.Forms.Internals: setParanoidCookie :: MonadState (MFlowState view) m => String -> String -> String -> Maybe Integer -> m ()
Files
- MFlow.cabal +4/−5
- src/MFlow.hs +1/−1
- src/MFlow/Forms.hs +6/−6
- src/MFlow/Forms/Internals.hs +89/−66
- src/MFlow/Forms/Widgets.hs +88/−34
MFlow.cabal view
@@ -1,5 +1,5 @@ name: MFlow-version: 0.4.5.3+version: 0.4.5.4 cabal-version: >=1.8 build-type: Simple license: BSD3@@ -44,14 +44,13 @@ . Bindings for hack, and hsp >= 0.8, are not compiled by Hackage, and do not appear, but are included in the package files. To use them, add then to the exported modules and execute cabal install .- NOTE: compatibility with GHC 7.8: you will have compilation errors related with Typeable.- Follow the instruction in the open issues in the git repository.+ The version 0.4.5.4 add compatibility with ghc 7.8 . The version 0.4.5 composable HTTP caching, lazy load, caching datasets in the browser HTTP cache . The version 0.4.0 add encrypted cookies, secure sessions, add REST web services, fixes UTF8 errors, pageFlow fixes, add onBacktrack, compensate .- Thes version 0.3.3 run with wai 2.0+ The version 0.3.3 run with wai 2.0 . The version 0.3.2 add runtime templates. It also add witerate and dField, two modifiers for single page development. dField creates a placeholder for a widget that is updated via implicit AJAX by witerate.@@ -129,7 +128,7 @@ -- hamlet , shakespeare, monadloc , aws , network , hscolour , -- persistent-template , persistent-sqlite , persistent , -- conduit , http-conduit , monad-logger , safecopy ,--- time, monadloc-pp+-- time -- main-is: demos-blaze.hs -- buildable: True -- hs-source-dirs: Demos
src/MFlow.hs view
@@ -72,7 +72,7 @@ , userRegister, setAdminUser, getAdminName, Auth(..),getAuthMethod, setAuthMethod -- * static files -- * config-,Config(..), config, getConfig, setConfig +,config, getConfig ,setFilesPath -- * internal use ,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow
src/MFlow/Forms.hs view
@@ -1040,9 +1040,9 @@ -- it is set for each page -- if it does not exist then it comes from a state recovery, backtrack (to fill-in the field) let pagepath = mfPagePath st1- if null pagepath then fail ""+ if null pagepath then fail "" -- !> "null pagepath" -- if exist and it is not prefix of the current path being navigated to, backtrack- else if not $ pagepath `isPrefixOf` mfPath st1 then fail "" -- !> ("pagepath fail with "++ show (mfPath st1))+ else if not $ pagepath `isPrefixOf` mfPath st1 then fail "" -- !> ("pagepath fail with "++ show (mfPath st1)) else do let st= st1{needForm= NoElems, inSync= False, mfRequirements= [], linkMatched= False} @@ -1055,14 +1055,14 @@ else case mx of Just x -> do - put st'{newAsk= True , mfEnv=[]} + put st'{newAsk= True, mfEnv=[]} breturn x -- !> ("BRETURN "++ show (mfPagePath st') ) Nothing -> if not (inSync st') && not (newAsk st') -- !> ("insync="++show (inSync st')) -- !> ("newask="++show (newAsk st')) - then fail "" -- !> "FAIL**********" + then fail "" -- !> "FAIL sync" else if mfAutorefresh st' then do resetState st st' -- !> ("EN AUTOREFRESH" ++ show [ mfPagePath st,mfPath st,mfPagePath st']) -- modify $ \st -> st{mfPagePath=mfPagePath st'} !> "REPEAT"@@ -1075,7 +1075,7 @@ t= mfToken st' cont <- case (needForm1 st') of True -> do - frm <- formPrefix st' forms False + frm <- formPrefix st' forms False -- !> ("formPrefix="++ show(mfPagePath st')) return . header $ reqs <> frm _ -> return . header $ reqs <> forms @@ -1094,7 +1094,7 @@ ,mfToken= mfToken st' ,mfPageFlow= mfPageFlow st' ,mfAjax= mfAjax st' - ,mfSeqCache= mfSeqCache st' +-- ,mfSeqCache= mfSeqCache st' ,mfData= mfData st' }
src/MFlow/Forms/Internals.hs view
@@ -52,7 +52,6 @@ import Data.Maybe(isJust) import Control.Concurrent.STM import Data.TCache.Memoization---import Data.String -- ---- for traces @@ -61,7 +60,8 @@ import Control.Exception as CE import Control.Concurrent import Control.Monad.Loc - ++-- debug --import Debug.Trace --(!>) = flip trace @@ -317,7 +317,7 @@ (_,Just _) -> path2 _ -> path if hasform then put s2{needForm= HasForm,mfPagePath= path3}- else put s2{mfPagePath=path3} + else put s2{mfPagePath=path3} return $ FormElm mix (k <|> x) @@ -776,9 +776,21 @@ SB.fromString v, SB.fromString p, fmap (SB.fromString . show) me)):mfCookies st } - ++setParanoidCookie :: MonadState (MFlowState view) m + => String -- ^ name + -> String -- ^ value + -> String -- ^ path + -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie+ -> m () setParanoidCookie n v p me = setEncryptedCookie' n v p me paranoidEncryptCookie - ++setEncryptedCookie :: MonadState (MFlowState view) m + => String -- ^ name + -> String -- ^ value + -> String -- ^ path + -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie+ -> m () setEncryptedCookie n v p me = setEncryptedCookie' n v p me encryptCookie setEncryptedCookie' n v p me encFunc= @@ -911,8 +923,7 @@ let s''= s{inSync = inSync s2 ,mfRequirements=mfRequirements s2 ,mfPath= mfPath s2- ,mfPagePath= mfPagePath s2--- ,mfPendingPath=mfPendingPath s2 + ,mfPagePath= mfPagePath s2 ,needForm= needForm s2 ,mfPageFlow= mfPageFlow s2 ,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec}@@ -1259,53 +1270,56 @@ let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) return $ NotValidated str err ----- Requirements - --- | Requirements are javascripts, Stylesheets or server processes (or any instance of the 'Requirement' class) that are included in the --- Web page or in the server when a widget specifies this. @requires@ is the --- procedure to be called with the list of requirements. --- Various widgets in the page can require the same element, MFlow will install it once. -requires rs =do - st <- get - let l = mfRequirements st --- let rs'= map Requirement rs \\ l - put st {mfRequirements= l ++ map Requirement rs} - - - -data Requirement= forall a.(Show a,Typeable a,Requirements a) => Requirement a deriving Typeable - -class Requirements a where - installRequirements :: (Monad m,FormInput view) => [a] -> m view - -instance Show Requirement where - show (Requirement a)= show a ++ "\n" - -installAllRequirements :: ( Monad m, FormInput view) => WState view m view -installAllRequirements= do - rs <- gets mfRequirements - installAllRequirements1 mempty rs - where - - installAllRequirements1 v []= return v - installAllRequirements1 v rs= do - let typehead= case head rs of {Requirement r -> typeOf r} - (rs',rs'')= partition1 typehead rs - v' <- installRequirements2 rs' - installAllRequirements1 (v `mappend` v') rs'' - where - installRequirements2 []= return $ fromStrNoEncode "" - installRequirements2 (Requirement r:rs)= installRequirements $ r:unmap rs - unmap []=[] - unmap (Requirement r:rs)= unsafeCoerce r:unmap rs - partition1 typehead xs = foldr select ([],[]) xs - where - select x ~(ts,fs)= - let typer= case x of Requirement r -> typeOf r - in if typer== typehead then ( x:ts,fs) - else (ts, x:fs) - +---- Requirements+++-- | Requirements are javascripts, Stylesheets or server processes (or any instance of the 'Requirement' class) that are included in the+-- Web page or in the server when a widget specifies this. @requires@ is the+-- procedure to be called with the list of requirements.+-- Various widgets in the page can require the same element, MFlow will install it once.+requires rs =do+ st <- get+ let l = mfRequirements st+-- let rs'= map Requirement rs \\ l+ put st {mfRequirements= l ++ map Requirement rs}++++data Requirement= forall a.(Show a,Typeable a,Requirements a) => Requirement a deriving Typeable++class Requirements a where+ installRequirements :: (Monad m,FormInput view) => Bool -> [a] -> m view++instance Show Requirement where+ show (Requirement a)= show a ++ "\n"++installAllRequirements :: ( Monad m, FormInput view) => WState view m view+installAllRequirements= do+ st <- get+ let rs = mfRequirements st+ auto = mfAutorefresh st+ installAllRequirements1 auto mempty rs+ where++ installAllRequirements1 _ v []= return v+ installAllRequirements1 auto v rs= do+ let typehead= case head rs of {Requirement r -> typeOf r}+ (rs',rs'')= partition1 typehead rs+ v' <- installRequirements2 rs'+ installAllRequirements1 auto (v `mappend` v') rs''+ where+ installRequirements2 []= return $ fromStrNoEncode ""+ installRequirements2 (Requirement r:rs)= installRequirements auto $ r:unmap rs+ unmap []=[]+ unmap (Requirement r:rs)= unsafeCoerce r:unmap rs+ partition1 typehead xs = foldr select ([],[]) xs+ where+ select x ~(ts,fs)=+ let typer= case x of Requirement r -> typeOf r+ in if typer== typehead then ( x:ts,fs)+ else (ts, x:fs)+ -- Web requirements --- loadjsfile filename lcallbacks= let name= addrStr filename in@@ -1364,31 +1378,40 @@ -installWebRequirements :: (Monad m,FormInput view) =>[WebRequirement] -> m view -installWebRequirements rs= do - let s = jsRequirements $ sort rs +installWebRequirements :: (Monad m,FormInput view) => Bool -> [WebRequirement] -> m view +installWebRequirements auto rs= do + let s = jsRequirements auto $ sort rs return $ ftag "script" (fromStrNoEncode s) -jsRequirements []= "" - - -jsRequirements (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs) - | f==f' = jsRequirements $ JScriptFile f (nub $ c++c'):rs - | otherwise= strRequirement r ++ jsRequirements (r':rs) +jsRequirements _ []= "" -jsRequirements (r:r':rs) - | r== r' = jsRequirements $ r:rs - | otherwise= strRequirement r ++ jsRequirements (r':rs) +jsRequirements False (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs) + | f==f' = jsRequirements False $ JScriptFile f (nub $ c++c'):rs + | otherwise= strRequirement r ++ jsRequirements False (r':rs) ++jsRequirements True (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs) + | f==f' = concatMap strRequirement(map JScript $ nub (c' ++ c)) ++ jsRequirements True rs + | otherwise= strRequirement r ++ jsRequirements True (r':rs) ++++ +jsRequirements auto (r:r':rs) + | r== r' = jsRequirements auto $ r:rs + | otherwise= strRequirement r ++ jsRequirements auto (r':rs) -jsRequirements (r:rs)= strRequirement r++jsRequirements rs +jsRequirements auto (r:rs)= strRequirement r++jsRequirements auto rs strRequirement (CSSFile s') = loadcssfile s' strRequirement (CSS s') = loadcss s' strRequirement (JScriptFile s' call) = loadjsfile s' call strRequirement (JScript s') = loadjs s' strRequirement (ServerProc f)= (unsafePerformIO $! addMessageFlows [f]) `seq` "" +++ --- AJAX ----
src/MFlow/Forms/Widgets.hs view
@@ -4,10 +4,12 @@ widgets for templating, content management and multilanguage. And some primitives to create other active widgets. -} - +-- {-# OPTIONS -F -pgmF cpphs #-}+{-# OPTIONS -cpp -pgmPcpphs -optP--cpp #-} {-# LANGUAGE UndecidableInstances,ExistentialQuantification , FlexibleInstances, OverlappingInstances, FlexibleContexts - , OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables #-} + , OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables+ , StandaloneDeriving #-} @@ -108,9 +110,13 @@ data Medit view m a = Medit (M.Map B.ByteString [(String,View view m a)])--- #if MIN_VERSION_ghc(7, 7, 0)--- deriving Typeable--- #else++#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)@@ -122,7 +128,8 @@ tm= undefined ta :: Medit v m a -> a ta= undefined--- #endif ++#endif -- | If not logged, it present a page flow which askm for the user name, then the password if not logged -- @@ -138,7 +145,7 @@ return username else do name <- getString Nothing <! hint "login name"- <! size 9+ <! size (9 :: Int) <++ ftag "br" mempty pass <- getPassword <! hint "password" <! size 9 @@ -162,9 +169,20 @@ 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++#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 @@ -172,10 +190,14 @@ -- | 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 +#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 -- ^ 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 @@ -199,9 +221,12 @@ 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) - => B.ByteString -> B.ByteString -> View v Identity a -> View v m B.ByteString +#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]) @@ -238,8 +263,12 @@ -- > delEdited sel ws' -- > return r -prependWidget - :: (Typeable a, MonadIO m, Executable m, FormInput v) +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 -- ^ 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 @@ -247,13 +276,21 @@ -- | 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 +#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 -- | 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) => +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)+ :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable m, Typeable Identity) =>+#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 @@ -285,8 +322,12 @@ -- > getString1 mx= El.div <<< delBox ++> getString mx <++ br wEditList :: (Typeable a,Read a - ,FormInput view - ,Functor m,MonadIO m, Executable m) + ,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) -- ^ The holder tag -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string -> [String] -- ^ The initial list of values. @@ -355,8 +396,12 @@ -- > ++> ftag "span" (fromStr $ fromJust x ) -- > ++> whidden( fromJust x) wautocompleteEdit - :: (Typeable a, MonadIO m,Functor m, Executable m - , FormInput v) + :: (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 -- ^ 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 @@ -405,11 +450,20 @@ \});" jaddtoautocomp textx us= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> " });" +++#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)+deriving instance Typeable Identity+#endif -- | 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) => +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 @@ -633,7 +687,7 @@ FormElm _ mr <- runView w' setCachePolicy reqs <- return . map ( \(Requirement r) -> unsafeCoerce r) =<< gets mfRequirements - let js = jsRequirements reqs+ let js = jsRequirements True reqs st' <- get liftIO . sendFlush t $ HttpData @@ -1247,8 +1301,7 @@ FormElm rendering mx <- runView w return $ FormElm (ftag "div" v `attrs` [("id",id)]) mx - else View $ do- modify $ \s -> s{mfHttpHeaders=[], mfRequirements=[]} + else View $ do resetCachePolicy st' <- get FormElm form mx <- runView w@@ -1266,11 +1319,8 @@ where --- waitAndExecute= "function waitAndExecute(sym,f) {\--- \if (eval(sym)) {f();}\--- \else {setTimeout(function() {waitAndExecute(sym,f)}, 50);}\--- \}\n" + scrollposition= "$.fn.scrollposition= function(){\ \var pos= $(this).position();\ \if (typeof(pos)==='undefined') {return 1;}\@@ -1306,3 +1356,7 @@ \}}};" +waitAndExecute= "function waitAndExecute(sym,f) {\+ \if (eval(sym)) {f();}\+ \else {setTimeout(function() {waitAndExecute(sym,f)}, 50);}\+ \}\n"