MFlow 0.2.0.4 → 0.2.0.5

raw patch · 9 files changed

+53/−153 lines, 9 filesdep −hackdep −hack-handler-simpleserver

Dependencies removed: hack, hack-handler-simpleserver

Files

• MFlow.cabal +17/−10
• src/MFlow.hs +23/−4
• src/MFlow/FileServer.hs +0/−125
• src/MFlow/Forms/HSP.hs +2/−3
• src/MFlow/Forms/Internals.hs +5/−3
• src/MFlow/Forms/Widgets.hs +1/−1
• src/MFlow/Forms/XHtml.hs +1/−1
• src/MFlow/Wai/Blaze/Html/All.hs +2/−3
• src/MFlow/Wai/XHtml/All.hs +2/−3

@@ -1,5 +1,5 @@ name: MFlow-version: 0.2.0.4+version: 0.2.0.5 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -18,15 +18,19 @@              is automatic. State consistence and transactions are given by the TCache package.              .              The processes interact trough widgets, that are an extension of formlets with-             additional combinators, formatting, link management, callbacks, modifiers, caching,+             additional applicative combinators, formatting, link management, callbacks, modifiers, caching,              byteString conversion and AJAX. All is coded in pure haskell.              .-             The interfaces and communications are abstract, but there are bindings for HSP, Text.XHtml and byteString+             The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString              , Hack and WAI but it can be extended to non Web based architectures.              .-             This release add transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting, AJAX,+             The previous release add transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting, AJAX,              and WAI integration.              .+             This version add better WAI integration, higher level dynamic Widgets, content management, multilanguage, blaze-html support,+             stateful ajax for server-side control, user-defined data in sessions and widget requirements for automatic installation of scripts, CSS and server flows.++             .              It is designed for applications that can be run with no deployment with runghc in order              to speed up the development process.              .@@ -43,6 +47,10 @@ author: Alberto Gómez Corona data-dir: "" extra-source-files: Demos/demos.blaze.hs+                  , src/MFlow/Hack.hs+                  , src/MFlow/Hack/Response.hs+                  , src/MFlow/Hack/XHtml.hs+                  , src/MFlow/Hack/XHtml/All.hs  source-repository head     type: git@@ -55,16 +63,15 @@                    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.8, hack -any, hack-handler-simpleserver -any,+                   random -any, hsp >= 0.8,                    blaze-html -any, blaze-markup -any-    exposed-modules: MFlow.Wai.Blaze.Html.All-                     MFlow.Forms MFlow.Forms.Admin MFlow MFlow.FileServer+    exposed-modules: MFlow MFlow.Wai.Blaze.Html.All+                     MFlow.Forms MFlow.Forms.Admin                      MFlow.Cookies  MFlow.Wai                      MFlow.Wai.XHtml.All MFlow.Forms.XHtml MFlow.Forms.HSP-                      MFlow.Hack MFlow.Hack.XHtml-                     MFlow.Hack.XHtml.All MFlow.Forms.Blaze.Html MFlow.Forms.Test+                     MFlow.Forms.Blaze.Html MFlow.Forms.Test                      MFlow.Forms.Widgets-    other-modules: MFlow.Forms.Internals MFlow.Wai.Response MFlow.Hack.Response+    other-modules: MFlow.Forms.Internals MFlow.Wai.Response     exposed: True     buildable: True     hs-source-dirs: src .

@@ -66,6 +66,9 @@ -- * ByteString tags -- | very basic but efficient tag formatting btag, bhtml, bbody,Attribs, addAttrs++-- * static files+,setFilesPath -- * internal use ,addTokenToList,deleteTokenInList, msgScheduler,serveFile) @@ -76,7 +79,7 @@ import Data.Typeable
 import Data.Maybe(isJust, isNothing, fromMaybe, fromJust) import Data.Char(isSeparator)
-import Data.List(isPrefixOf, elem , span, (\\))
+import Data.List(isPrefixOf,isSuffixOf,isInfixOf, elem , span, (\\))
 import Control.Monad(when) 
 import Data.Monoid
@@ -365,9 +368,10 @@         wfs <- getMessageFlows
         r <- startWF wfname  token   wfs                      -- !>( "init wf " ++ wfname)
         case r of
-          Left NotFound -> sendFlush token =<< serveFile wfname+          Left NotFound -> do+                 sendFlush token =<< serveFile wfname --               sendFlush token (Error NotFound $ "Not found: " <> pack wfname)---               deleteTokenInList token
+                 deleteTokenInList token
           Left AlreadyRunning -> return ()                    -- !> ("already Running " ++ wfname)           Left Timeout -> return()                            -- !>  "Timeout in msgScheduler"           Left (WFException e)-> do@@ -446,8 +450,22 @@  --- basic file server ---- +-- | Set the path of the files in the web server. The links to the files are relative to it.+-- The files are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of
+-- the efficient GHC threads by frequent IO calls.So it enhances the performance
+-- in the context of heavy concurrence.
+-- It uses 'Data.TCache.Memoization'. 
+-- The caching-uncaching follows the `setPersist` criteria
+setFilesPath :: String -> IO ()
+setFilesPath path= writeIORef rfilesPath path -serveFile path= do
+rfilesPath= unsafePerformIO $ newIORef "files/"++serveFile path'= do+     when(let hpath= head path' in hpath == '/' || hpath =='\\') $ error noperm
+     when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm
+     filesPath <- readIORef rfilesPath
+     let path= filesPath ++ path'
      mr <-  cachedByKey path 0  $   (B.readFile  path >>=  return . Just) `CE.catch` ioerr (return Nothing)
      case mr of
       Nothing -> return $ HttpData  [setMime "text/plain"] [] $ pack $  "not accessible"
@@ -458,6 +476,7 @@ 
          in return $ HttpData  [setMime mime, ("Cache-Control", "max-age=360000")] [] r
    where+   noperm= "no permissions"    ioerr x= \(e :: CE.IOException) ->  x
    setMime x= ("Content-Type",x) 

@@ -1,125 +0,0 @@-{- | A file server for frequently accessed files, such are static web pages and image decorations, icons etc
-that are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of
-the efficient GHC threads by frequent IO calls.So it enhances the performance
-in the context of heavy concurrence.
-It uses 'Data.TCache.Memoization'.
-The caching-uncaching follows the `setPersist` criteria.
--}
------------------------------------------------------------------------------
---
--- Module      :  FileServer
--- Copyright   :
--- License     :  BSD3
---
--- Maintainer  :  agocorona@gmail.com
--- Stability   :  experimental
--- Portability :
---
---
---
------------------------------------------------------------------------------
-{-# OPTIONS -XScopedTypeVariables  #-}
-module MFlow.FileServer (setFilesPath, serveFile
-
-) where
-
-import MFlow
-import MFlow.Cookies(contentHtml)
-import Control.Monad.State
-import Data.TCache.Memoization
-import MFlow.Forms.XHtml
-import System.Directory
-import Data.ByteString.Lazy.Char8 as B(readFile,concat,append,pack,empty)
-
-import Control.Exception as CE
-import Data.List
-import System.IO.Unsafe
-import Data.IORef
-import Data.Monoid
-
-
-rfilesPath= unsafePerformIO $ newIORef "files/"
-
--- | Set the path of the files in the web server. The links to the files are relative to it
-setFilesPath :: String -> IO ()
-setFilesPath path= writeIORef rfilesPath path
-
-pathPrm=  "path"
-fileServe :: Flow
-fileServe  = stateless $ \env  -> do
-  case lookup pathPrm   env of
-    Nothing -> error " no file specified"
-    Just path' ->do
-     when(let hpath= head path' in hpath == '/' || hpath =='\\') $ error noperm
-     when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm
-     filesPath <- readIORef rfilesPath
-     let path= filesPath ++ path'
-     serveFile path
-    -- isDirectory <- doesDirectoryExist  path -- !> path
-
---     case isDirectory of
---       True  -> do
---          dir <-  directory1 $ path ++ "/"
---          return $ HttpData  (setMime "text/html") []  dir
---       False -> servefile path
-
-
- where
-
-
- dropBack ".."= ".."
- dropBack path
-     | "../" `isPrefixOf` revpath =reverse . maybetail $ dropWhile (/= '/') $ drop 3 revpath
-     | otherwise= path
-   where
-   revpath= reverse path
---   maybetail ""= "."
-   maybetail xs= tail xs
- noperm= "no permissions"
- 
-stringServer mime str= stateless
--- | Is the flow to be added to the list in order to stream any file from the filesystem
--- for example, images
---
--- This app includes the fileServe  flow:
---
--- @
--- main= do
---   addFileServerWF
---   addMessageFlows messageFlows
---   run 80  hackMessageFlow
---   adminLoop
---   where
---   messageFlows=  [(\"noscript\" , transient $ runFlow showStories)
---                  ,("\admin\"    , transient $ runFlow admin)
---                  ,("\mail\"     , transient $ runFlow mail)]@
---
--- | Add the fileServer to the list of server flows
--- it is mandatory if you want to use the file service
-addFileServerWF= addMessageFlows [("file", fileServe)]
-
-
-
--- | Creates the url of file path. To be used in ordinary links to files.
--- in Text.XHtml, a image would be embeded as
---
--- > image ![src $ linkFile imagepath]
---
--- in HSP:
---
--- > <img src=(linkFile imagepath)\>
-
--- | Given the relative path of a file, it return the content of the @href@ element in a html link
-linkFile :: String -> String
-linkFile path=  "file?path=" <>  path
-
-directory :: Flow
-directory = stateless $ \_ -> do
-   path <- readIORef rfilesPath
-   directory1 path
-
-directory1 path = do
-   fs <- getDirectoryContents path
-   return $  HttpData [contentHtml][] $ B.concat [btag "a" [("href",linkFile ( path ++  file))] (B.pack file) `append` btag "br" [] B.empty | file <- fs]
-
-

@@ -25,16 +25,15 @@ import Data.Text.Lazy.Encoding import Data.String -newtype XMLG m= XMLG (XMLGenT m (XMLType m))-unXMLG (XMLG x)= x + 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>  instance Typeable  (XMLGenT m XML) where-   typeOf= \_ ->  mkTyConApp(mkTyCon "HSP.XML") []+    typeOf= \_ ->  mkTyConApp(mkTyCon3 "hsp" "HSP.XMLGenerator" "XMLGenT m XML") []  instance (XMLGen m,XML ~ XMLType m          ,EmbedAsChild m XML

@@ -630,8 +630,8 @@    -- to restart the flow in case of going back before the first page of the flow -  fromFailBack (NoBack  x)   = x-  fromFailBack (BackPoint  x)= x+fromFailBack (NoBack  x)   = x+fromFailBack (BackPoint  x)= x  -- | Run a persistent flow inside the current flow. It is identified by the procedure and -- the string identifier.@@ -646,7 +646,9 @@   -> FlowM view m b runFlowIn wf f= do   t <-  gets mfToken-  liftIO $ WF.exec1nc wf $ runFlow f t+  liftIO $ WF.exec1nc wf $ runFlow1 f t+  where+  runFlow1 f t=   evalStateT (runBackT . runFlowM $ breturn() >>  f)  mFlowState0{mfToken=t,mfEnv= tenv t}  >>= return . fromFailBack  -- >> return ()   

@@ -88,7 +88,7 @@ data Medit view m a = Medit (M.Map B.ByteString [(String,View view m a)]) instance (Typeable view, Typeable a)          =>Typeable (Medit view m a) where-  typeOf= \v -> mkTyConApp (mkTyCon "Medit" )+  typeOf= \v -> mkTyConApp (mkTyCon3 "MFlow" "MFlow.Forms.Widgets" "Medit" )                 [typeOf (tview v)                 ,typeOf (ta v)]       where

@@ -61,6 +61,6 @@     flink  v str = toHtml $ hotlink  (  v) << str  instance Typeable Html where-     typeOf =  \_ -> mkTyConApp (mkTyCon "Text.XHtml.Strict.Html") []+     typeOf =  \_ -> mkTyConApp (mkTyCon3 "xhtml" "Text.XHtml.Strict" "Html") []  

@@ -14,8 +14,8 @@  module MFlow.Wai.Blaze.Html.All (  module Data.TCache+,module MFlow ,module MFlow.Wai-,module MFlow.FileServer ,module MFlow.Forms ,module MFlow.Forms.Widgets ,module MFlow.Forms.Blaze.Html@@ -28,9 +28,8 @@ ,module Text.Blaze.Html5.Attributes ) where -+import MFlow import MFlow.Wai-import MFlow.FileServer import MFlow.Forms import MFlow.Forms.Widgets import MFlow.Forms.XHtml

@@ -14,8 +14,8 @@  module MFlow.Wai.XHtml.All (  module Data.TCache+,module MFlow ,module MFlow.Wai-,module MFlow.FileServer ,module MFlow.Forms ,module MFlow.Forms.XHtml ,module MFlow.Forms.Admin@@ -27,9 +27,8 @@ ,module Control.Applicative ) where -+import MFlow import MFlow.Wai-import MFlow.FileServer import MFlow.Forms import MFlow.Forms.XHtml import MFlow.Forms.Admin