MFlow 0.4.5.6 → 0.4.5.7
raw patch · 5 files changed
+95/−63 lines, 5 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ MFlow.Forms.Internals: mfSomeNotValidates :: MFlowState view -> Bool
- MFlow.Forms: allOf :: (Functor m, MonadIO m, FormInput view) => [View view m a] -> View view m [a]
+ MFlow.Forms: allOf :: (Functor m, IsString view, MonadIO m, FormInput view) => [View view m a] -> View view m [a]
- MFlow.Forms: changeMonad :: (Monad m, Executable m1) => View v m1 a -> View v m a
+ MFlow.Forms: changeMonad :: (Monad m, Executable m') => View v m' a -> View v m a
- MFlow.Forms.Internals: MFlowState :: Int -> Bool -> Bool -> Bool -> Lang -> Params -> NeedForm -> Bool -> Token -> Int -> Integer -> [Cookie] -> [(ByteString, ByteString)] -> (view -> view) -> Bool -> [Requirement] -> [WebRequirement] -> Map TypeRep Void -> Maybe (Map String Void) -> Int -> Bool -> [String] -> [String] -> String -> Bool -> Bool -> Bool -> [String] -> Bool -> MFlowState view
+ MFlow.Forms.Internals: MFlowState :: Int -> Bool -> Bool -> Bool -> Bool -> Lang -> Params -> NeedForm -> Bool -> Token -> Int -> Integer -> [Cookie] -> [(ByteString, ByteString)] -> (view -> view) -> Bool -> [Requirement] -> [WebRequirement] -> Map TypeRep Void -> Maybe (Map String Void) -> Int -> Bool -> [String] -> [String] -> String -> Bool -> Bool -> Bool -> [String] -> Bool -> MFlowState view
- MFlow.Forms.Internals: changeMonad :: (Monad m, Executable m1) => View v m1 a -> View v m a
+ MFlow.Forms.Internals: changeMonad :: (Monad m, Executable m') => View v m' a -> View v m a
- MFlow.Forms.Widgets: 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]
+ MFlow.Forms.Widgets: wEditList :: (Typeable a, Read a, FormInput view, Functor m, MonadIO m, Executable m) => (view -> view) -> (Maybe a -> View view Identity a) -> [a] -> String -> View view m [a]
Files
- MFlow.cabal +4/−3
- src/MFlow/Forms.hs +41/−31
- src/MFlow/Forms/Internals.hs +13/−10
- src/MFlow/Forms/Widgets.hs +12/−15
- src/MFlow/Wai/Blaze/Html/All.hs +25/−4
MFlow.cabal view
@@ -1,5 +1,5 @@ name: MFlow -version: 0.4.5.6 +version: 0.4.5.7 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -108,7 +108,8 @@ utf8-string , wai , wai-extra, resourcet, case-insensitive , http-types , conduit ,conduit-extra, text , parsec , warp , warp-tls , random , blaze-html , blaze-markup , - monadloc, clientsession, pwstore-fast + monadloc, clientsession, pwstore-fast+ exposed-modules: MFlow MFlow.Wai.Blaze.Html.All MFlow.Forms MFlow.Forms.Admin MFlow.Cookies MFlow.Wai MFlow.Forms.Blaze.Html MFlow.Forms.Test @@ -128,7 +129,7 @@ -- hamlet , shakespeare, monadloc , aws , network , hscolour , -- persistent-template , persistent-sqlite , persistent , -- conduit , http-conduit , monad-logger , safecopy , --- time, acid-state +-- time, acid-state, data-default, haste-compiler -- main-is: demos-blaze.hs -- buildable: True -- hs-source-dirs: Demos
src/MFlow/Forms.hs view
@@ -1057,7 +1057,7 @@ ,mfRequirements= [] ,mfInstalledScripts= if newAsk st1 then [] else mfInstalledScripts st1} put st - FormElm forms mx <- FlowM . lift $ runView w + FormElm forms mx <- FlowM . lift $ runView w -- !> "eval" setCachePolicy st' <- get if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w @@ -1070,24 +1070,24 @@ Nothing -> if not (inSync st') && not (newAsk st') - -- !> ("insync="++show (inSync st')) - -- !> ("newask="++show (newAsk st')) - then fail "" -- !> "FAIL sync" + -- !> ("insync="++show (inSync st')) + -- !> ("newask="++show (newAsk st')) + then fail "" -- !> "FAIL sync" else if mfAutorefresh st' then do - resetState st st' -- !> ("EN AUTOREFRESH" ++ show [ mfPagePath st,mfPath st,mfPagePath st']) + resetState st st' -- !> ("EN AUTOREFRESH" ++ show [ mfPagePath st,mfPath st,mfPagePath st']) -- modify $ \st -> st{mfPagePath=mfPagePath st'} !> "REPEAT" FlowM $ lift nextMessage ask w else do - reqs <- FlowM $ lift installAllRequirements -- !> "REPEAT" - st' <- get + reqs <- FlowM $ lift installAllRequirements -- !> "REPEAT" + st' <- get -- !> (B.unpack $ toByteString reqs) let header= mfHeader st' t= mfToken st' cont <- case (needForm st') of HasElems -> do frm <- formPrefix st' forms False -- !> ("formPrefix="++ show(mfPagePath st')) - return . header $ reqs <> frm - _ -> return . header $ reqs <> forms + return . header $ reqs <> frm + _ -> return . header $ reqs <> forms let HttpData ctype c s= toHttpData cont liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s @@ -1097,13 +1097,15 @@ ask w where resetState st st'= - put st{mfCookies=[] - ,mfInstalledScripts= mfInstalledScripts st' + put st{mfCookies=[]+ -- if autorefresh, keep the list of installed scripts + ,mfInstalledScripts= if mfAutorefresh st' then mfInstalledScripts st' else [] ,newAsk= False ,mfToken= mfToken st' ,mfPageFlow= mfPageFlow st' ,mfAjax= mfAjax st' - ,mfData= mfData st' } + ,mfData= mfData st'+ ,mfSomeNotValidates= False} -- | A synonym of ask. @@ -1123,7 +1125,7 @@ t2= mfSessionTime st msg <- liftIO ( receiveReqTimeout t1 t2 t) let req= getParams msg - env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow) + env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow) npath= pwfPath msg path= mfPath st inPageFlow= mfPagePath st `isPrefixOf` npath @@ -1141,13 +1143,17 @@ updateParams :: Bool -> Params -> Params -> Params updateParams False _ req= req - updateParams True env req= - let params= takeWhile isparam req -- env - fs= fst $ head req - parms= (case findIndex (\p -> fst p == fs) params of - Nothing -> params - Just i -> Data.List.take i params) - ++ req + updateParams True env req=+ let old= takeWhile isparam env+ (new,rest)= Data.List.span isparam req+ parms= new++ old++ rest+ +-- let params= takeWhile isparam env +-- fs= fst $ head req +-- parms= (case findIndex (\p -> fst p == fs) params of +-- Nothing -> params +-- Just i -> Data.List.take i params) +-- ++ req in parms -- !> "IN PAGE FLOW" !> ("parms=" ++ show parms ) -- !> ("env=" ++ show env) @@ -1398,14 +1404,15 @@ manyOf xs= whidden () *> (View $ do forms <- mapM runView xs let vs = mconcat $ map (\(FormElm v _) -> v) forms - res1= catMaybes $ map (\(FormElm _ r) -> r) forms - return . FormElm vs $ Just res1) + res1= catMaybes $ map (\(FormElm _ r) -> r) forms+ nval <- gets mfSomeNotValidates+ return . FormElm vs $ if nval then Nothing else Just res1) -- | like manyOf, but does not validate if one or more of the widgets does not validate allOf xs= manyOf xs `validate` \rs -> if length rs== length xs then return Nothing - else return $ Just mempty + else return $ Just "Not all of the required data completed" (>:>) :: (Monad m, Monoid v) => View v m a -> View v m [a] -> View v m [a] (>:>) w ws = View $ do @@ -1608,11 +1615,14 @@ -- !> ("END CHILD pageflow. prefix="++ str)) - ---acum map []= map ---acum map (x:xs) = --- let map' = case M.lookup x map of --- Nothing -> M.insert x 1 map --- Just n -> M.insert x (n+1) map --- in acum map' xs - + -- !> ("END CHILD pageflow. prefix="++ str)) +-- | send raw data to the client.+--+-- example+-- +-- >rawSend $ HttpData [("Content-Type","text/plain"), ("Cache-Control", "max-age=360000")] [] "hello" +rawSend :: (FormInput v,MonadIO m) => HttpData -> View v m ()+rawSend dat= do+ tok <- getToken+ liftIO $ sendFlush tok dat+ modify $ \st -> st{mfAutorefresh= True}
src/MFlow/Forms/Internals.hs view
@@ -64,7 +64,8 @@ -- debug import Debug.Trace (!>) = flip trace - ++infixl 9 !> data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable) @@ -247,7 +248,8 @@ , mfPath=mfPath , mfData=mfData , mfTrace= mfTrace - , inSync=False + , inSync=False+ , mfSomeNotValidates= False , newAsk=False} @@ -428,8 +430,8 @@ liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO on the Identity monad -- | Execute the widget in a monad and return the result in another. -changeMonad :: (Monad m, Executable m1) - => View v m1 a -> View v m a +changeMonad :: (Monad m, Executable m') + => View v m' a -> View v m a changeMonad w= View . StateT $ \s -> let (r,s')= execute $ runStateT ( runView w) s in mfSequence s' `seq` return (r,s') @@ -643,7 +645,8 @@ mfSequence :: Int, mfCached :: Bool, newAsk :: Bool, - inSync :: Bool, + inSync :: Bool,+ mfSomeNotValidates :: Bool, mfLang :: Lang, mfEnv :: Params, needForm :: NeedForm, @@ -666,12 +669,10 @@ mfPath :: [String], mfPagePath :: [String], mfPrefix :: String, --- mfPIndex :: Int, + mfPageFlow :: Bool, linkMatched :: Bool, --- mfPendingPath :: [String], - mfAutorefresh :: Bool, mfTrace :: [String], mfClear :: Bool @@ -681,7 +682,7 @@ type Void = Char mFlowState0 :: (FormInput view) => MFlowState view -mFlowState0 = MFlowState 0 False True True "en" +mFlowState0 = MFlowState 0 False True True False "en" [] NoElems False (error "token of mFlowState0 used") 0 0 [] [] stdHeader False [] [] M.empty Nothing 0 False [] [] "" False False False [] False @@ -957,7 +958,8 @@ cachedWidget key t mf = View . StateT $ \s -> do let((FormElm form _), sec)= execute $! cachedByKey key t $ proc mf s{mfCached=True} let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True} - let s''= s{inSync = inSync s2 + let s''= s{inSync = inSync s2+ ,mfSomeNotValidates= mfSomeNotValidates s2 ,mfRequirements=mfRequirements s2 ,mfPath= mfPath s2 ,mfPagePath= mfPagePath s2 @@ -1306,6 +1308,7 @@ [(x,"")] -> return $ Validated x _ -> do let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) + modify $ \st -> st{mfSomeNotValidates= True} return $ NotValidated str err
src/MFlow/Forms/Widgets.hs view
@@ -231,13 +231,13 @@ 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 + 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 :: View v m a -> a typ = undefined -- | Return the javascript to be executed on the browser to prepend a widget to the location @@ -265,7 +265,7 @@ prependWidget #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707) - :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) + :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) #else :: (Typeable a, MonadIO m, Executable m, FormInput v) #endif @@ -277,7 +277,7 @@ -- | Like 'prependWidget' but append the widget instead of prepend. appendWidget #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707) - :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) => + :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) => #else :: (Typeable a, MonadIO m, Executable m, FormInput v) => #endif @@ -287,7 +287,7 @@ -- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element setWidget #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707) - :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable m, Typeable Identity) => + :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) => #else :: (Typeable a, MonadIO m, Executable m, FormInput v) => #endif @@ -329,11 +329,11 @@ ,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. + -> (Maybe a -> View view Identity a) -- ^ the contained widget, initialized by a value of its type + -> [a] -- ^ 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 +wEditList holderview w xs addId = pageFlow addId $ do let ws= map (w . Just) xs wn= w Nothing id1<- genNewId @@ -344,14 +344,11 @@ requires [JScriptFile jqueryScript [installevents] ] ws' <- getEdited sel - - r <- (holderview <<< (allOf $ ws' ++ map changeMonad ws)) <! [("id",id1)] + r <- (holderview <<< (manyOf $ ws' ++ map changeMonad ws)) <! [("id",id1)] delEdited sel ws' return r - - -- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box. wautocomplete :: (Show a, MonadIO m, FormInput v) @@ -404,7 +401,7 @@ #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 + -> (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 @@ -419,14 +416,14 @@ return $ jaddtoautocomp textx r - requires [JScriptFile jqueryScript [events textx ajaxc] + 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))) + ++> manyOf (ws' ++ (map (changeMonad . elem . Just) values))) <++ ftag "input" mempty `attrs` [("type", "text") ,("id", textx)
src/MFlow/Wai/Blaze/Html/All.hs view
@@ -66,10 +66,31 @@ return $ fromMaybe "80" $ lookup "PORT" env let porti= if and $ map isNumber port then fromIntegral $ read port else 80 + putStr "using port " print porti return porti - ++--getPortW= do +-- args <- getArgs+-- let h= Prelude.head args+-- ht= Prelude.head $ tail args+-- port <- if isport h then return h+-- else if isport ht then return ht+-- else do+-- env <- getEnvironment +-- return $ fromMaybe "80" $ lookup "PORT" env+-- +-- let porti= if isport port then fromIntegral $ read port +-- else 80 +-- +--+-- putStr "using port " +-- print porti +-- return porti+-- where+-- isport x= and $ map isNumber x+ -- | run a persistent flow. It uses `getPortW` to get the port -- The first parameter is the first element in the URL path. -- It also set the home page @@ -94,6 +115,6 @@ unless (null n) $ setNoScript n addMessageFlows[(n, runFlow f)] porti <- getPortW --- let s' = setPort porti s --- wait $ TLS.runTLS t s' waiMessageFlow - wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow + let s' = setPort porti s + wait $ TLS.runTLS t s' waiMessageFlow +-- wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow