MFlow 0.2.0.2 → 0.2.0.3

raw patch · 7 files changed

+75/−61 lines, 7 filesdep ~hsp

Dependency ranges changed: hsp

Files

• Demos/demos.blaze.hs +4/−4
• MFlow.cabal +2/−2
• src/MFlow.hs +17/−14
• src/MFlow/Forms.hs +9/−7
• src/MFlow/Forms/HSP.hs +24/−15
• src/MFlow/Forms/Internals.hs +4/−4
• src/MFlow/Forms/Widgets.hs +15/−15

@@ -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") 

@@ -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

@@ -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

@@ -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

@@ -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 <http://hackage.haskell.org/package/hsp>@@ -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 =   <span/>-    mappend x y= <span> <% x %> <% y %> </span>-    mconcat xs= <span> <% [<% x %> | x <- xs] %> </span>+    mappend  x  y= <span> <% x %> <% y %> </span>+    mconcat xs=  <span> <% [<% x %> |  x <- xs] %> </span> -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= <pcdata> pcdataToChild s </pcdata>     finput typ name value checked onclick=       <input type= (typ)-             name=(name)+             name= (name)              value=(value)-             checked=(checked)+             checked=(show checked)              onclick=(case onclick of Just s -> s ; _ -> "")/>      ftextarea  name text= <textarea name=(name) > <% text %> </textarea>@@ -55,7 +64,7 @@                   </option>            where-          selected msel = if msel then "true" else  "false"+          selected msel = if msel then "true" else  "false" :: String      flink  v str = <a href=(v)> <% str %> </a> 

@@ -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);" ++         "    }" ++         "  };" ++

@@ -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")) <![("onclick",cmd "''")]) `waction` const logout       else noWidget  --- active widgets@@ -438,28 +440,26 @@         -> 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)