diff --git a/Demos/demos.blaze.hs b/Demos/demos.blaze.hs --- a/Demos/demos.blaze.hs +++ b/Demos/demos.blaze.hs @@ -270,11 +270,11 @@ ++> wlink () (p << text "click here to edit it") - ask $ p << text "Please login with admin/admin to edit it" - ++> userWidget (Just "admin") userLogin + ask $ p << text "Please login with admin/admin to edit it" + ++> userWidget (Just "admin") userLogin - ask $ p << text "now you can click the field and edit them" - ++> p << b << text "to save the edited field, double click on it" + ask $ p << text "now you can click the fields and edit them" + ++> p << b << text "to save an edited field, double click on it" ++> pageEditable **> wlink () (p << text "click here to see it as a normal user") diff --git a/MFlow.cabal b/MFlow.cabal --- a/MFlow.cabal +++ b/MFlow.cabal @@ -1,5 +1,5 @@ name: MFlow -version: 0.2.0.2 +version: 0.2.0.3 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -58,7 +58,7 @@ stm >2, old-time -any, vector -any, directory -any, utf8-string -any, wai -any, case-insensitive -any, http-types -any, conduit -any, text -any, parsec -any, warp -any, - random -any, hsp == 0.7.1, hack -any, hack-handler-simpleserver -any, + random -any, hsp >= 0.8, hack -any, hack-handler-simpleserver -any, blaze-html -any, blaze-markup -any exposed-modules: MFlow.Wai.Blaze.Html.All MFlow.Forms MFlow.Forms.Admin MFlow MFlow.FileServer diff --git a/src/MFlow.hs b/src/MFlow.hs --- a/src/MFlow.hs +++ b/src/MFlow.hs @@ -1,13 +1,14 @@ -{- | Non monadic low level support stuff for the MFlow application server. -(See "MFlow.Form" for the higher level interfaces) -it implements an scheduler of queued 'Processable' messages that are served according with +{- | Non monadic low level primitives that implement the MFlow application server. +See "MFlow.Form" for the higher level interface that you may use. + +it implements an scheduler of 'Processable' messages that are served according with the source identification and the verb invoked. The scheduler executed the appropriate workflow (using the workflow package). -The workflow may send additional messages to the source, identified by a 'Token' -. The computation state is optionally logged. on timeout, the process is killed. When invoked again +The workflow will send additional messages to the source and wait for the responses. +The diaglog is identified by a 'Token', which is associated to the flow. +. The computation state is optionally logged. On timeout, the process is killed. When invoked again, the execution state is recovered as if no interruption took place. -The message communication is trough polimorphic, monoidal queues. There is no asumption about message codification, so instantiations of this scheduler for different infrastructures is possible, including non-Web based ones as long as they support or emulate cookies. @@ -16,8 +17,8 @@ "MFlow.Wai" is a instantiation for the WAI interface. -"MFlow.Forms" implements a monadic type safe interface with composabe widgets and a -higher comunication interface. +"MFlow.Forms" implements a monadic type safe interface with composabe widgets and and applicative +combinator as well as an higher comunication interface. "MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format @@ -35,7 +36,7 @@ All these details are hidden in the monad of "MFlow.Forms" that provides an higher level interface. -Fragment based streaming 'sendFragment' are provided only at this level. +Fragment based streaming: 'sendFragment' are provided only at this level. 'stateless' and 'transient' server processeses are also possible. the first are request-response . `transient` processes do not persist after timeout, so they restart anew after a timeout or a crash. @@ -305,7 +306,7 @@ getMessageFlows = readMVar _messageFlows --class ToHttpData a where --- toHttpData :: a -> HttpData +-- toHttpData :: a -> HttpData thread t= show(unsafePerformIO myThreadId) ++ " "++ show (twfname t) @@ -344,8 +345,10 @@ -- toHttpData= HttpData [] [] . pack -- | The scheduler creates a Token with every `Processable` --- message that arrives and send the mesage to the appropriate flow, get the response +-- message that arrives and send the mesage to the appropriate flow, then waht for the response -- and return it. +-- +-- It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it msgScheduler :: (Typeable a,Processable a) => a -> IO (HttpData, ThreadId) @@ -435,7 +438,7 @@ bbody ats v= btag "body" ats v addAttrs :: ByteString -> Attribs -> ByteString -addAttrs (Chunk "<" (Chunk tag(Chunk ">" rest))) rs= - Chunk "<"(Chunk tag (pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> ">" <> rest +addAttrs (Chunk "<" (Chunk tag rest)) rs= + Chunk "<"(Chunk tag (pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest -addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ unpack other +addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other diff --git a/src/MFlow/Forms.hs b/src/MFlow/Forms.hs --- a/src/MFlow/Forms.hs +++ b/src/MFlow/Forms.hs @@ -233,9 +233,9 @@ import Data.Char(isNumber) import Network.HTTP.Types.Header - -import Debug.Trace -(!>)= flip trace +-- +--import Debug.Trace +--(!>)= flip trace @@ -276,7 +276,7 @@ let env = mfEnv s let seq = mfSequence s put s{mfSequence=mfSequence s+ 100,mfEnv=[]} - r <- flowToView $ ac x !> "ACTION" + r <- flowToView $ ac x modify $ \s-> s{mfSequence= seq, mfEnv= env} return r where @@ -888,9 +888,11 @@ ask w = do st1 <- get let env= mfEnv st1 - case (mfAjax st1,lookup "ajax" env, lookup "val" env) of - ( Just ajaxl,Just v1, Just v2) -> do - let f = fromMaybe (error $ "not found Ajax handler for: "++ v1) $ M.lookup v1 ajaxl + let mv1= lookup "ajax" env + let majax1= mfAjax st1 + + case (majax1,mv1,M.lookup (fromJust mv1)(fromJust majax1), lookup "val" env) of + ( Just ajaxl,Just v1,Just f, Just v2) -> do FlowM . lift $ (unsafeCoerce f) v2 FlowM $ lift receiveWithTimeouts ask w diff --git a/src/MFlow/Forms/HSP.hs b/src/MFlow/Forms/HSP.hs --- a/src/MFlow/Forms/HSP.hs +++ b/src/MFlow/Forms/HSP.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -F -pgmFtrhsx -XUndecidableInstances -XOverlappingInstances -XTypeSynonymInstances -XFlexibleInstances #-} +{-# OPTIONS -F -pgmFtrhsx -XTypeFamilies -XOverloadedStrings -XUndecidableInstances -XOverlappingInstances -XTypeSynonymInstances -XFlexibleInstances #-} {- | Instantiation of the 'FormInput' class for the HSP package @@ -14,26 +14,35 @@ import MFlow.Forms import Control.Monad.Trans import Data.Typeable -import HSP +import HSP.Monad +import HSP.XML +import HSP.XMLGenerator import Data.Monoid import Control.Monad(when) import Data.ByteString.Lazy.Char8(unpack,pack) import System.IO.Unsafe - +import Data.TCache.Memoization (Executable (..)) +import Data.Text.Lazy.Encoding +import Data.String +newtype XMLG m= XMLG (XMLGenT m (XMLType m)) +unXMLG (XMLG x)= x -instance Monoid (HSP XML) where +instance (XMLGen m,XML ~ XMLType m, EmbedAsChild m(XMLType m)) => Monoid (XMLGenT m XML) where mempty = - mappend x y= <% x %> <% y %> - mconcat xs= <% [<% x %> | x <- xs] %> + mappend x y= <% x %> <% y %> + mconcat xs= <% [<% x %> | x <- xs] %> -instance Typeable (HSP XML) where - typeOf= \_ -> mkTyConApp(mkTyCon "HSP XML") [] +instance Typeable (XMLGenT m XML) where + typeOf= \_ -> mkTyConApp(mkTyCon "HSP.XML") [] -instance FormInput (HSP XML) where - toByteString x= unsafePerformIO $ do - (_,r) <- evalHSP Nothing x - return . pack $ renderXML r +instance (XMLGen m,XML ~ XMLType m + ,EmbedAsChild m XML + ,EmbedAsAttr m (Attr String String) + ,Executable m + ,SetAttr m XML) + => FormInput (XMLGenT m XML) where + toByteString = encodeUtf8 . renderXML . execute . unXMLGenT toHttpData = HttpData [contentHtml ] [] . toByteString ftag t = \e -> genElement (toName t) [] [asChild e] @@ -41,9 +50,9 @@ fromStrNoEncode s= pcdataToChild s finput typ name value checked onclick= s ; _ -> "")/> ftextarea name text= @@ -55,7 +64,7 @@ where - selected msel = if msel then "true" else "false" + selected msel = if msel then "true" else "false" :: String flink v str = <% str %> diff --git a/src/MFlow/Forms/Internals.hs b/src/MFlow/Forms/Internals.hs --- a/src/MFlow/Forms/Internals.hs +++ b/src/MFlow/Forms/Internals.hs @@ -638,12 +638,12 @@ -> View view m a -- ^ The cached widget -> View view m a -- ^ The cached result wfreeze key t mf = View . StateT $ \s -> do - ((FormElm f mx), req,seq) <- cachedByKey key t $ proc mf s{mfCached=True} - return ((FormElm f mx), s{mfRequirements=req,mfSeqCache= seq}) + ((FormElm f mx), req,seq,ajax) <- cachedByKey key t $ proc mf s{mfCached=True} + return ((FormElm f mx), s{mfRequirements=req,mfSeqCache= seq,mfAjax=ajax}) where proc mf s= do (r,s) <- runStateT (runView mf) s - return (r,mfRequirements s, mfSeqCache s) + return (r,mfRequirements s, mfSeqCache s,mfAjax s) -- ---- | FormLet class @@ -934,7 +934,7 @@ "xmlhttp.onreadystatechange=function()" ++ " {" ++ " if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++ - " { " ++ + " {" ++ " eval(xmlhttp.responseText);" ++ " }" ++ " };" ++ diff --git a/src/MFlow/Forms/Widgets.hs b/src/MFlow/Forms/Widgets.hs --- a/src/MFlow/Forms/Widgets.hs +++ b/src/MFlow/Forms/Widgets.hs @@ -78,7 +78,9 @@ maybeLogout= do us <- getCurrentUser if us/= anonymous - then fromStr " " ++> wlink () (fromStr "logout") `waction` const logout + then do + cmd <- ajax $ const $ return "window.location=='/'" --refresh + fromStr " " ++> ((wlink () (fromStr "logout")) View v m () tFieldGen k getcontent create = wfreeze k 0 $ do content <- liftIO $ getcontent k - admin <- getAdminName + 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 useradmin= "if(document.cookie.search('"++cookieuser++"="++admin++"') != -1)" + -- Need to check the user in the browser because the widget is wfreeze'd + let ifUserAdmin= "if(document.cookie.search('"++cookieuser++"="++admin++"') != -1)" nikeditor= "var myNicEditor = new nicEditor();" - callback=useradmin ++ + callback=ifUserAdmin ++ "bkLib.onDomLoaded(function() {\ \ myNicEditor.addInstance('"++name++"');\ \});" - param= ("'"++k++ "'+','+ document.getElementById('"++name++"').innerHTML") - ajaxjs <- ajax - $ \str -> do - let (k,s)= break (==',') str - liftIO . create k $ fromStrNoEncode (tail s) - liftIO $ flushCached k - return "alert('saved');" + param= ("'"++k ++ "'+','+ document.getElementById('"++name++"').innerHTML") - requires - [JScriptFile "http://js.nicedit.com/nicEdit-latest.js" [nikeditor, callback] - ,JScript ajaxScript] + requires [JScriptFile "http://js.nicedit.com/nicEdit-latest.js" [nikeditor, callback]] - return [("id", name),("ondblclick", useradmin++ajaxjs param)] + return [("id", name),("ondblclick", ifUserAdmin ++ ajaxjs param)] wraw $ (ftag "span" content `attrs` attribs)