MFlow 0.2.0.3 → 0.2.0.4
raw patch · 7 files changed
+361/−458 lines, 7 files
Files
- Demos/demos.blaze.hs +58/−49
- MFlow.cabal +1/−4
- src/MFlow.hs +234/−15
- src/MFlow/FileServer.hs +4/−213
- src/MFlow/Forms.hs +56/−50
- src/MFlow/Forms/Internals.hs +7/−69
- src/MFlow/Wai.hs +1/−58
Demos/demos.blaze.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module Main where import MFlow.Wai.Blaze.Html.All import Text.Blaze.Html5 as El@@ -22,14 +22,34 @@ setAdminUser "admin" "admin" syncWrite SyncManual setFilesPath ""- addFileServerWF- addMessageFlows [("" ,transient $ runFlow mainmenu)- ,("shop" ,runFlow shopCart)]- wait $ run 80 waiMessageFlow+-- addFileServerWF+ addMessageFlows [("" , transient $ runFlow mainmenu)+ ,("shop", runFlow shopCart)]+ wait $ run 8081 waiMessageFlow --- adminLoop -stdheader c= docTypeHtml << El.head << body << (p << text "You can press the back button" <> c)+stdheader c= docTypeHtml $ body $+ a ! At.style "text-align:center" ! href ( fromString "html/MFlow/index.html") << h1 << text "MFlow"+ <> (El.div ! At.style "position:fixed;top:40px;left:0%\+ \;width:50%;min-height:100%\+ \;margin-left:10px;margin-right:10px" $+ h2 << text "Example of some features."+ <> h3 << text "This demo uses warp and blaze-html"+ <> hr+ <> c)+ <> (El.div ! At.style "position:fixed;top:40px;left:50%;width:50%;min-height:100%" $+ h2 << text "Documentation"+ <> p << a ! href ( fromString "html/MFlow/index.html") << text "MFlow package description and documentation"+ <> p << a ! href ( fromString "demos.blaze.hs") << text "download demo source code"+ <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/11/mflow-now-widgets-can-express.html") << text "MFlow: now the widgets can express requirements"+ <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/12/on-spirit-of-mflow-anatomy-of-widget.html") << text "On the \"spirit\" of MFlow. Anatomy of a Widget"+ <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2013/01/now-example-of-use-of-active-widget.html") << text "MFlow active widgets example"+ <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2013/01/stateful-but-stateless-at-last-thanks.html") << text "Stateful, but virtually stateless, thanks to event sourcing"+ <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/11/i-just-added-some-templatingcontent.html") << text "Content Management and multilanguage in MFlow"+ <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/10/testing-mflow-applications_9.html") << text "Testing MFlow applications"+ <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/09/a.html") << text "A Web app. that creates Haskel computations from form responses, that store, retrieve and execute them? It´s easy"+ <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/09/announce-mflow-015.html") << text "ANNOUNCE MFlow 0.1.5 Web app server for stateful processes with safe, composable user interfaces."+ ) data Options= CountI | CountS | Radio | Login | TextEdit |Grid | Autocomp | AutocompList@@ -40,7 +60,8 @@ setHeader stdheader setTimeouts 100 0 r <- ask $ wcached "menu" 0 $- br ++> wlink CountI (b << text "increase an Int")+ b << text "BASIC"+ ++> br ++> wlink CountI (b << text "increase an Int") <|> br ++> wlink CountS (b << text "increase a String") <|> br ++> wlink Action (b << text "Example of action, executed when a widget is validated") <|> br ++> wlink Select (b << text "select options")@@ -56,7 +77,7 @@ <++ br <> br <> b << text "STATEFUL PERSISTENT FLOW" <> br <> a ! href "shop" << text "shopping" -- ordinary Blaze.Html link <> br <> br <> b << text "OTHERS"- <|> br ++> wlink Shop (b << text "Example of server-side redirection to another flow (shopping)")+ <|> br ++> wlink Login (b << text "login/logout") @@ -74,10 +95,10 @@ ListEdit -> wlistEd Radio -> radio Login -> login- Shop -> transfer "shop" + options= do r <- ask $ getSelect (setSelectedOption ("" :: String) (p << text "select a option") <|> setOption "blue" (b << text "blue") <|>@@ -150,62 +171,49 @@ ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)" getString1 mx= El.div <<< delBox ++> getString mx <++ br -clickn (n :: Int)= do- setHeader stdheader- r <- ask $ wlink ("menu" :: String) (p << text "menu")- |+| getInt (Just n) <* submitButton "submit"+clickn n= do+ r <- ask $ p << b << text "increase an Int"+ ++> wlink ("menu" :: String) (p << text "menu")+ |+| getInt (Just n) <* submitButton "submit" case r of (Just _,_) -> mainmenu (_, Just n') -> clickn $ n'+1 clicks s= do- setHeader stdheader- s' <- ask $ (getString (Just s)+ s' <- ask $ p << b << text "increase a String"+ ++>(getString (Just s) <* submitButton "submit") `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing ) clicks $ s'++ "1" radio = do- r <- ask $ getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]]+ r <- ask $ p << b << text "Radio buttons"+ ++> getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]] ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu") mainmenu ------askr :: (Read a,Show a,FormInput v,MonadIO m)--- => String -> a -> (a -> View v m b) -> FlowM v m b---askr id param w = do--- let key= addrStr w--- w'= do--- env <- getEnv--- let link= "param="++show param--- requires[JScript $ "document.getElementById('"++id++"').outerHtml=<a href='"++link++"'></a>"]--- let par = fromMaybe param $ fmap read $ lookup "param" env--- w par-------- liftIO $ addMessageFlows [(key, wstateless w')]--- ask w'-- ajaxsample= do- r <- ask $ do+ r <- ask $ p << b << text "Ajax example that increment the value in a box"+ ++> do let elemval= "document.getElementById('text1').value" ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'" b << text "click the box"- ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]<** submitButton "submit"+ ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc . B.unpack $ elemval)]<** submitButton "submit" ask $ p << ( show r ++ " returned") ++> wlink () (p << text " menu") mainmenu -+---- recursive callbacks --actions n=do -- ask $ wlink () (p << text "exit from action") -- <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) actions n= do- r<- ask $ (getString $ Just "widget1") `waction` action- <+> (getString $ Just "widget2") `waction` action+ r<- ask $ p << b << text "Two text boxes with one action each one"+ ++> getString (Just "widget1") `waction` action+ <+> getString (Just "widget2") `waction` action <** submitButton "submit" ask $ p << ( show r ++ " returned") ++> wlink () (p << text " menu") mainmenu@@ -215,12 +223,12 @@ data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum,Read, Show, Typeable) shopCart = do- setHeader $ \html -> El.span << text+ setHeader $ \html -> p << (text "A persistent flow (uses step). The process is killed after 10 seconds of inactivity \ \but it is restarted automatically. Event If you restart the whole server, it remember the shopping cart\n\n \ \Defines a table with links enclosed that return ints and a link to the menu, that abandon this flow.\n\ \The cart state is not stored, Only the history of events is saved. The cart is recreated by running the history of events."- <> html+ <> html) setTimeouts 10 0 shopCart1 (V.fromList [0,0,0:: Int]) where@@ -252,20 +260,19 @@ logout mainmenu --- an example of content management+ textEdit= do- setHeader $ \t -> html << body << t let first= p << i << (El.span << text "this is a page with"- <> b << text " two " <> El.span << text "paragraphs")+ <> b << text " two " <> El.span << text "paragraphs. this is the first") second= p << i << text "This is the original text of the second paragraph" - pageEditable = (tFieldEd "first" first)- **> (tFieldEd "second" second) - ask $ first++ ask $ p << b << text "An example of content management"+ ++> first ++> second ++> wlink () (p << text "click here to edit it") @@ -275,16 +282,18 @@ 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+ ++> tFieldEd "first" first+ **> tFieldEd "second" second **> wlink () (p << text "click here to see it as a normal user") logout ask $ p << text "the user sees the edited content. He can not edit"- ++> pageEditable+ ++> tFieldEd "first" first+ **> tFieldEd "second" second **> wlink () (p << text "click to continue") - ask $ p << text "When text are fixed,the edit facility and the original texts can be removed. The content is indexed by the field key"+ ask $ p << text "When texts are fixed,the edit facility and the original texts can be removed. The content is indexed by the field key" ++> tField "first" **> tField "second" **> p << text "End of edit field demo" ++> wlink () (p << text "click here to go to menu")
MFlow.cabal view
@@ -1,5 +1,5 @@ name: MFlow-version: 0.2.0.3+version: 0.2.0.4 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -34,9 +34,6 @@ . Altroug still it is experimental, it is being used in at least one future commercial project. So I have te commitment to continue its development. There are many examples in the documentation and in the package.- .- Due to compilation problems in Hackage, this release has the bindings for Hack and HSP not exposed,- but they can be found in the source files. . To do: .
src/MFlow.hs view
@@ -67,7 +67,7 @@ -- | very basic but efficient tag formatting btag, bhtml, bbody,Attribs, addAttrs -- * internal use-,addTokenToList,deleteTokenInList, msgScheduler)+,addTokenToList,deleteTokenInList, msgScheduler,serveFile) where import Control.Concurrent.MVar @@ -81,13 +81,13 @@ import Data.Monoid import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId) - +import Data.Char(toLower) import Unsafe.Coerce import System.IO.Unsafe import Data.TCache.DefaultPersistence hiding(Indexable(..)) --import Data.ByteString.Lazy.Char8 as B (ByteString, concat,pack, unpack,empty,append,cons,fromChunks) +import Data.TCache.Memoization+import Data.ByteString.Lazy.Char8 as B (readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks) import Data.ByteString.Lazy.Internal (ByteString(Chunk)) import qualified Data.Map as M import System.IO@@ -122,7 +122,7 @@ type Params = [(String,String)] -class Processable a where +class Processable a where pwfname :: a -> String puser :: a -> String pind :: a -> String@@ -149,12 +149,7 @@ data Resp = Fragm HttpData | EndFragm HttpData | Resp HttpData- --- | The anonymous user-anonymous= "anon#" --- | It is the path of the root flow-noScript = "noscript" -- | a Token identifies a flow that handle messages. The scheduler compose a Token with every `Processable` -- message that arrives and send the mesage to the appropriate flow. @@ -212,6 +207,12 @@ Just token-> return token +-- | The anonymous user+anonymous= "anon#"++-- | It is the path of the root flow+noScript = "noscript"+ {- instance (Monad m, Show a) => Traceable (Workflow m a) where debugf iox str = do @@ -355,8 +356,7 @@ msgScheduler x = do token <- getToken x th <- startMessageFlow (pwfname x) token- r <- tellToWF token x--- liftIO $ print $ let HttpData _ _ r1=r in unpack r1 + r <- tellToWF token x -- !> let HttpData _ _ r1=r in unpack r1 return (r,th) where --start the flow if not started yet @@ -365,9 +365,9 @@ wfs <- getMessageFlows r <- startWF wfname token wfs -- !>( "init wf " ++ wfname) case r of - Left NotFound -> do- sendFlush token (Error NotFound $ "Not found: " <> pack wfname)- deleteTokenInList token + Left NotFound -> sendFlush token =<< serveFile wfname+-- sendFlush token (Error NotFound $ "Not found: " <> pack wfname)+-- deleteTokenInList token Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname) Left Timeout -> return() -- !> "Timeout in msgScheduler" Left (WFException e)-> do@@ -442,3 +442,222 @@ Chunk "<"(Chunk tag (pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other+++--- basic file server ----+++serveFile path= do + 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" + Just r -> + let ext = reverse . takeWhile (/='.') $ reverse path + mmime= lookup (map toLower ext) mimeTable + mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream" + + in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r + where+ ioerr x= \(e :: CE.IOException) -> x + setMime x= ("Content-Type",x)+++ +mimeTable=[ + ("html", "text/html"), + ("htm", "text/html"), + ("txt", "text/plain"),+ ("hs", "text/plain"),+ ("lhs", "text/plain"), + ("jpeg", "image/jpeg"), + ("pdf", "application/pdf"), + ("js", "application/x-javascript"), + ("gif", "image/gif"), + ("bmp", "image/bmp"), + ("ico", "image/x-icon"), + ("doc", "application/msword"), + ("jpg", "image/jpeg"), + ("eps", "application/postscript"), + ("zip", "application/zip"), + ("exe", "application/octet-stream"), + ("tif", "image/tiff"), + ("tiff", "image/tiff"), + ("mov", "video/quicktime"), + ("movie", "video/x-sgi-movie"), + ("mp2", "video/mpeg"), + ("mp3", "audio/mpeg"), + ("mpa", "video/mpeg"), + ("mpe", "video/mpeg"), + ("mpeg", "video/mpeg"), + ("mpg", "video/mpeg"), + ("mpp", "application/vnd.ms-project"), + ("323", "text/h323"), + ("*", "application/octet-stream"), + ("acx", "application/internet-property-stream"), + ("ai", "application/postscript"), + ("aif", "audio/x-aiff"), + ("aifc", "audio/x-aiff"), + ("aiff", "audio/x-aiff"), + ("asf", "video/x-ms-asf"), + ("asr", "video/x-ms-asf"), + ("asx", "video/x-ms-asf"), + ("au", "audio/basic"), + ("avi", "video/x-msvideo"), + ("axs", "application/olescript"), + ("bas", "text/plain"), + ("bcpio", "application/x-bcpio"), + ("bin", "application/octet-stream"), + ("c", "text/plain"), + ("cat", "application/vnd.ms-pkiseccat"), + ("cdf", "application/x-cdf"), + ("cdf", "application/x-netcdf"), + ("cer", "application/x-x509-ca-cert"), + ("class", "application/octet-stream"), + ("clp", "application/x-msclip"), + ("cmx", "image/x-cmx"), + ("cod", "image/cis-cod"), + ("cpio", "application/x-cpio"), + ("crd", "application/x-mscardfile"), + ("crl", "application/pkix-crl"), + ("crt", "application/x-x509-ca-cert"), + ("csh", "application/x-csh"), + ("css", "text/css"), + ("dcr", "application/x-director"), + ("der", "application/x-x509-ca-cert"), + ("dir", "application/x-director"), + ("dll", "application/x-msdownload"), + ("dms", "application/octet-stream"), + ("dot", "application/msword"), + ("dvi", "application/x-dvi"), + ("dxr", "application/x-director"), + ("eps", "application/postscript"), + ("etx", "text/x-setext"), + ("evy", "application/envoy"), + ("fif", "application/fractals"), + ("flr", "x-world/x-vrml"), + ("gtar", "application/x-gtar"), + ("gz", "application/x-gzip"), + ("h", "text/plain"), + ("hdf", "application/x-hdf"), + ("hlp", "application/winhlp"), + ("hqx", "application/mac-binhex40"), + ("hta", "application/hta"), + ("htc", "text/x-component"), + ("htt", "text/webviewhtml"), + ("ief", "image/ief"), + ("iii", "application/x-iphone"), + ("ins", "application/x-internet-signup"), + ("isp", "application/x-internet-signup"), + ("jfif", "image/pipeg"), + ("jpe", "image/jpeg"), + ("latex", "application/x-latex"), + ("lha", "application/octet-stream"), + ("lsf", "video/x-la-asf"), + ("lsx", "video/x-la-asf"), + ("lzh", "application/octet-stream"), + ("m13", "application/x-msmediaview"), + ("m14", "application/x-msmediaview"), + ("m3u", "audio/x-mpegurl"), + ("man", "application/x-troff-man"), + ("mdb", "application/x-msaccess"), + ("me", "application/x-troff-me"), + ("mht", "message/rfc822"), + ("mhtml", "message/rfc822"), + ("mid", "audio/mid"), + ("mny", "application/x-msmoney"), + ("mpv2", "video/mpeg"), + ("ms", "application/x-troff-ms"), + ("msg", "application/vnd.ms-outlook"), + ("mvb", "application/x-msmediaview"), + ("nc", "application/x-netcdf"), + ("nws", "message/rfc822"), + ("oda", "application/oda"), + ("p10", "application/pkcs10"), + ("p12", "application/x-pkcs12"), + ("p7b", "application/x-pkcs7-certificates"), + ("p7c", "application/x-pkcs7-mime"), + ("p7m", "application/x-pkcs7-mime"), + ("p7r", "application/x-pkcs7-certreqresp"), + ("p7s", "application/x-pkcs7-signature"), + ("png", "image/png"), + ("pbm", "image/x-portable-bitmap"), + ("pfx", "application/x-pkcs12"), + ("pgm", "image/x-portable-graymap"), + ("pko", "application/ynd.ms-pkipko"), + ("pma", "application/x-perfmon"), + ("pmc", "application/x-perfmon"), + ("pml", "application/x-perfmon"), + ("pmr", "application/x-perfmon"), + ("pmw", "application/x-perfmon"), + ("pnm", "image/x-portable-anymap"), + ("pot", "application/vnd.ms-powerpoint"), + ("ppm", "image/x-portable-pixmap"), + ("pps", "application/vnd.ms-powerpoint"), + ("ppt", "application/vnd.ms-powerpoint"), + ("prf", "application/pics-rules"), + ("ps", "application/postscript"), + ("pub", "application/x-mspublisher"), + ("qt", "video/quicktime"), + ("ra", "audio/x-pn-realaudio"), + ("ram", "audio/x-pn-realaudio"), + ("ras", "image/x-cmu-raster"), + ("rgb", "image/x-rgb"), + ("rmi", "audio/mid"), + ("roff", "application/x-troff"), + ("rtf", "application/rtf"), + ("rtx", "text/richtext"), + ("scd", "application/x-msschedule"), + ("sct", "text/scriptlet"), + ("setpay", "application/set-payment-initiation"), + ("setreg", "application/set-registration-initiation"), + ("sh", "application/x-sh"), + ("shar", "application/x-shar"), + ("sit", "application/x-stuffit"), + ("snd", "audio/basic"), + ("spc", "application/x-pkcs7-certificates"), + ("spl", "application/futuresplash"), + ("src", "application/x-wais-source"), + ("sst", "application/vnd.ms-pkicertstore"), + ("stl", "application/vnd.ms-pkistl"), + ("stm", "text/html"), + ("sv4cpio", "application/x-sv4cpio"), + ("sv4crc", "application/x-sv4crc"), + ("svg", "image/svg+xml"), + ("swf", "application/x-shockwave-flash"), + ("t", "application/x-troff"), + ("tar", "application/x-tar"), + ("tcl", "application/x-tcl"), + ("tex", "application/x-tex"), + ("texi", "application/x-texinfo"), + ("texinfo", "application/x-texinfo"), + ("tgz", "application/x-compressed"), + ("tr", "application/x-troff"), + ("trm", "application/x-msterminal"), + ("tsv", "text/tab-separated-values"), + ("uls", "text/iuls"), + ("ustar", "application/x-ustar"), + ("vcf", "text/x-vcard"), + ("vrml", "x-world/x-vrml"), + ("wav", "audio/x-wav"), + ("wcm", "application/vnd.ms-works"), + ("wdb", "application/vnd.ms-works"), + ("wks", "application/vnd.ms-works"), + ("wmf", "application/x-msmetafile"), + ("wps", "application/vnd.ms-works"), + ("wri", "application/x-mswrite"), + ("wrl", "x-world/x-vrml"), + ("wrz", "x-world/x-vrml"), + ("xaf", "x-world/x-vrml"), + ("xbm", "image/x-xbitmap"), + ("xla", "application/vnd.ms-excel"), + ("xlc", "application/vnd.ms-excel"), + ("xlm", "application/vnd.ms-excel"), + ("xls", "application/vnd.ms-excel"), + ("xlt", "application/vnd.ms-excel"), + ("xlw", "application/vnd.ms-excel"), + ("xof", "x-world/x-vrml"), + ("xpm", "image/x-xpixmap"), + ("xwd", "image/x-xwindowdump"), + ("z", "application/x-compress") + + ]
src/MFlow/FileServer.hs view
@@ -19,7 +19,7 @@ -- ----------------------------------------------------------------------------- {-# OPTIONS -XScopedTypeVariables #-} -module MFlow.FileServer (addFileServerWF, linkFile,setFilesPath +module MFlow.FileServer (setFilesPath, serveFile ) where @@ -32,7 +32,6 @@ import Data.ByteString.Lazy.Char8 as B(readFile,concat,append,pack,empty) import Control.Exception as CE -import Data.Char import Data.List import System.IO.Unsafe import Data.IORef @@ -55,7 +54,7 @@ when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm filesPath <- readIORef rfilesPath let path= filesPath ++ path' - servefile path + serveFile path -- isDirectory <- doesDirectoryExist path -- !> path -- case isDirectory of @@ -66,8 +65,8 @@ where - setMime x= ("Content-Type",x) + dropBack ".."= ".." dropBack path | "../" `isPrefixOf` revpath =reverse . maybetail $ dropWhile (/= '/') $ drop 3 revpath @@ -77,18 +76,7 @@ -- maybetail ""= "." maybetail xs= tail xs noperm= "no permissions" - ioerr x= \(e :: CE.IOException) -> x - servefile path= do - 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" - Just r -> - let ext = reverse . takeWhile (/='.') $ reverse path - mmime= lookup (map toLower ext) mimeTable - mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream" - - in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r - + 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 @@ -134,201 +122,4 @@ fs <- getDirectoryContents path return $ HttpData [contentHtml][] $ B.concat [btag "a" [("href",linkFile ( path ++ file))] (B.pack file) `append` btag "br" [] B.empty | file <- fs] - -mimeTable=[ - ("html", "text/html"), - ("htm", "text/html"), - ("txt", "text/plain"), - ("jpeg", "image/jpeg"), - ("pdf", "application/pdf"), - ("js", "application/x-javascript"), - ("gif", "image/gif"), - ("bmp", "image/bmp"), - ("ico", "image/x-icon"), - ("doc", "application/msword"), - ("jpg", "image/jpeg"), - ("eps", "application/postscript"), - ("zip", "application/zip"), - ("exe", "application/octet-stream"), - ("tif", "image/tiff"), - ("tiff", "image/tiff"), - ("mov", "video/quicktime"), - ("movie", "video/x-sgi-movie"), - ("mp2", "video/mpeg"), - ("mp3", "audio/mpeg"), - ("mpa", "video/mpeg"), - ("mpe", "video/mpeg"), - ("mpeg", "video/mpeg"), - ("mpg", "video/mpeg"), - ("mpp", "application/vnd.ms-project"), - ("323", "text/h323"), - ("*", "application/octet-stream"), - ("acx", "application/internet-property-stream"), - ("ai", "application/postscript"), - ("aif", "audio/x-aiff"), - ("aifc", "audio/x-aiff"), - ("aiff", "audio/x-aiff"), - ("asf", "video/x-ms-asf"), - ("asr", "video/x-ms-asf"), - ("asx", "video/x-ms-asf"), - ("au", "audio/basic"), - ("avi", "video/x-msvideo"), - ("axs", "application/olescript"), - ("bas", "text/plain"), - ("bcpio", "application/x-bcpio"), - ("bin", "application/octet-stream"), - ("c", "text/plain"), - ("cat", "application/vnd.ms-pkiseccat"), - ("cdf", "application/x-cdf"), - ("cdf", "application/x-netcdf"), - ("cer", "application/x-x509-ca-cert"), - ("class", "application/octet-stream"), - ("clp", "application/x-msclip"), - ("cmx", "image/x-cmx"), - ("cod", "image/cis-cod"), - ("cpio", "application/x-cpio"), - ("crd", "application/x-mscardfile"), - ("crl", "application/pkix-crl"), - ("crt", "application/x-x509-ca-cert"), - ("csh", "application/x-csh"), - ("css", "text/css"), - ("dcr", "application/x-director"), - ("der", "application/x-x509-ca-cert"), - ("dir", "application/x-director"), - ("dll", "application/x-msdownload"), - ("dms", "application/octet-stream"), - ("dot", "application/msword"), - ("dvi", "application/x-dvi"), - ("dxr", "application/x-director"), - ("eps", "application/postscript"), - ("etx", "text/x-setext"), - ("evy", "application/envoy"), - ("fif", "application/fractals"), - ("flr", "x-world/x-vrml"), - ("gtar", "application/x-gtar"), - ("gz", "application/x-gzip"), - ("h", "text/plain"), - ("hdf", "application/x-hdf"), - ("hlp", "application/winhlp"), - ("hqx", "application/mac-binhex40"), - ("hta", "application/hta"), - ("htc", "text/x-component"), - ("htt", "text/webviewhtml"), - ("ief", "image/ief"), - ("iii", "application/x-iphone"), - ("ins", "application/x-internet-signup"), - ("isp", "application/x-internet-signup"), - ("jfif", "image/pipeg"), - ("jpe", "image/jpeg"), - ("latex", "application/x-latex"), - ("lha", "application/octet-stream"), - ("lsf", "video/x-la-asf"), - ("lsx", "video/x-la-asf"), - ("lzh", "application/octet-stream"), - ("m13", "application/x-msmediaview"), - ("m14", "application/x-msmediaview"), - ("m3u", "audio/x-mpegurl"), - ("man", "application/x-troff-man"), - ("mdb", "application/x-msaccess"), - ("me", "application/x-troff-me"), - ("mht", "message/rfc822"), - ("mhtml", "message/rfc822"), - ("mid", "audio/mid"), - ("mny", "application/x-msmoney"), - ("mpv2", "video/mpeg"), - ("ms", "application/x-troff-ms"), - ("msg", "application/vnd.ms-outlook"), - ("mvb", "application/x-msmediaview"), - ("nc", "application/x-netcdf"), - ("nws", "message/rfc822"), - ("oda", "application/oda"), - ("p10", "application/pkcs10"), - ("p12", "application/x-pkcs12"), - ("p7b", "application/x-pkcs7-certificates"), - ("p7c", "application/x-pkcs7-mime"), - ("p7m", "application/x-pkcs7-mime"), - ("p7r", "application/x-pkcs7-certreqresp"), - ("p7s", "application/x-pkcs7-signature"), - ("png", "image/png"), - ("pbm", "image/x-portable-bitmap"), - ("pfx", "application/x-pkcs12"), - ("pgm", "image/x-portable-graymap"), - ("pko", "application/ynd.ms-pkipko"), - ("pma", "application/x-perfmon"), - ("pmc", "application/x-perfmon"), - ("pml", "application/x-perfmon"), - ("pmr", "application/x-perfmon"), - ("pmw", "application/x-perfmon"), - ("pnm", "image/x-portable-anymap"), - ("pot", "application/vnd.ms-powerpoint"), - ("ppm", "image/x-portable-pixmap"), - ("pps", "application/vnd.ms-powerpoint"), - ("ppt", "application/vnd.ms-powerpoint"), - ("prf", "application/pics-rules"), - ("ps", "application/postscript"), - ("pub", "application/x-mspublisher"), - ("qt", "video/quicktime"), - ("ra", "audio/x-pn-realaudio"), - ("ram", "audio/x-pn-realaudio"), - ("ras", "image/x-cmu-raster"), - ("rgb", "image/x-rgb"), - ("rmi", "audio/mid"), - ("roff", "application/x-troff"), - ("rtf", "application/rtf"), - ("rtx", "text/richtext"), - ("scd", "application/x-msschedule"), - ("sct", "text/scriptlet"), - ("setpay", "application/set-payment-initiation"), - ("setreg", "application/set-registration-initiation"), - ("sh", "application/x-sh"), - ("shar", "application/x-shar"), - ("sit", "application/x-stuffit"), - ("snd", "audio/basic"), - ("spc", "application/x-pkcs7-certificates"), - ("spl", "application/futuresplash"), - ("src", "application/x-wais-source"), - ("sst", "application/vnd.ms-pkicertstore"), - ("stl", "application/vnd.ms-pkistl"), - ("stm", "text/html"), - ("sv4cpio", "application/x-sv4cpio"), - ("sv4crc", "application/x-sv4crc"), - ("svg", "image/svg+xml"), - ("swf", "application/x-shockwave-flash"), - ("t", "application/x-troff"), - ("tar", "application/x-tar"), - ("tcl", "application/x-tcl"), - ("tex", "application/x-tex"), - ("texi", "application/x-texinfo"), - ("texinfo", "application/x-texinfo"), - ("tgz", "application/x-compressed"), - ("tr", "application/x-troff"), - ("trm", "application/x-msterminal"), - ("tsv", "text/tab-separated-values"), - ("uls", "text/iuls"), - ("ustar", "application/x-ustar"), - ("vcf", "text/x-vcard"), - ("vrml", "x-world/x-vrml"), - ("wav", "audio/x-wav"), - ("wcm", "application/vnd.ms-works"), - ("wdb", "application/vnd.ms-works"), - ("wks", "application/vnd.ms-works"), - ("wmf", "application/x-msmetafile"), - ("wps", "application/vnd.ms-works"), - ("wri", "application/x-mswrite"), - ("wrl", "x-world/x-vrml"), - ("wrz", "x-world/x-vrml"), - ("xaf", "x-world/x-vrml"), - ("xbm", "image/x-xbitmap"), - ("xla", "application/vnd.ms-excel"), - ("xlc", "application/vnd.ms-excel"), - ("xlm", "application/vnd.ms-excel"), - ("xls", "application/vnd.ms-excel"), - ("xlt", "application/vnd.ms-excel"), - ("xlw", "application/vnd.ms-excel"), - ("xof", "x-world/x-vrml"), - ("xpm", "image/x-xpixmap"), - ("xwd", "image/x-xwindowdump"), - ("z", "application/x-compress") - - ]
src/MFlow/Forms.hs view
@@ -157,7 +157,8 @@ ,validate, noWidget, waction, wmodify, -- * Caching widgets-cachedWidget, wcached, wfreeze, +cachedWidget, wcached, wfreeze,+ -- * Widget combinators (<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>) @@ -585,22 +586,25 @@ return . FormElm [foption n val check] $ Just MFOption --- | Enclose Widgets in some formating. +-- | Enclose Widgets within some formating. -- @view@ is intended to be instantiated to a particular format ----- This is a widget, which is table with some links. it returns an Int+-- This is a widget, which is a table with some links. it returns an Int ----- > import MFlow.Forms.XHtml+-- it has a infix priority : @infixr 5@ less than '++>' so use parenthesis when appropriate+--+-- > import MFlow.Forms.Blaze.Html -- > -- > tableLinks :: View Html Int--- > tableLinks= table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"]--- > <<< caption << "choose an item"--- > ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"]--- > ++> (tbody--- > <<< (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << "One")--- > <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << "Two")--- > <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << "Three"))--- > ) +-- > table ! At.style "border:1;width:20%;margin-left:auto;margin-right:auto"+-- > <<< caption << text "choose an item"+-- > ++> thead << tr << ( th << b << text "item" <> th << b << text "times chosen")+-- > ++> (tbody+-- > <<< tr ! rowspan "2" << td << linkHome+-- > ++> (tr <<< td <<< wlink IPhone (b << text "iphone") <++ td << ( b << text (fromString $ show ( cart V.! 0)))+-- > <|> tr <<< td <<< wlink IPod (b << text "ipad") <++ td << ( b << text (fromString $ show ( cart V.! 1)))+-- > <|> tr <<< td <<< wlink IPad (b << text "ipod") <++ td << ( b << text (fromString $ show ( cart V.! 2))))+-- > ) (<<<) :: (Monad m, Monoid view) => (view ->view) -> View view m a @@ -630,7 +634,9 @@ -- | Append formatting code to a widget -- --- @ getString "hi" <++ H1 << "hi there"@ +-- @ getString "hi" <++ H1 << "hi there"@+--+-- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators (<++) :: (Monad m) => View v m a -> v @@ -643,7 +649,8 @@ -- | Prepend formatting code to a widget -- -- @bold << "enter name" ++> getString Nothing @ - +--+-- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators (++>) :: (Monad m, Monoid view) => view -> View view m a -> View view m a html ++> digest = (html `mappend`) <<< digest @@ -651,30 +658,16 @@ --- | Add attributes to the form element--- if the view has more than one element, it is applied to the first+-- | Add attributes to the topmost tag of a widget+--+-- it has a fixity @infix 8@ infix 8 <! widget <! atrs= View $ do FormElm fs mx <- runView widget return $ FormElm [attrs (head fs) atrs] mx --------------------------------- --- --- ---instance (MonadIO m, Functor m, FormInput view) --- => FormLet User m view where --- digest muser= --- (User <$> getString ( userName <$> muser) --- <*> getPassword) --- `validate` userValidate ---- - -- | Is an example of login\/register validation form needed by 'userWidget'. In this case -- the form field appears in a single line. it shows, in sequence, entries for the username, -- password, a button for loging, a entry to repeat password necesary for registering@@ -813,13 +806,12 @@ getUser mu form= ask $ userWidget mu form ---instance (MonadIO m, Functor m, m1 ~ m, b ~ a) --- => Widget(View view m1 b) a m view where --- widget = id - -- | Join two widgets in the same page -- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results --- +-- if both return Noting, the widget return @Nothing@ (invalid).+--+-- it has a low infix priority: @infixr 2@+-- -- > r <- ask widget1 <+> widget2 -- > case r of (Just x, Nothing) -> .. (<+>) , mix :: Monad m @@ -839,7 +831,7 @@ (<+>) = mix -infixr 1 **> , .**>. , <** , .<**.+ -- | The first elem result (even if it is not validated) is discarded, and the secod is returned -- . This contrast with the applicative operator '*>' which fails the whole validation if -- the validation of the first elem fails.@@ -852,18 +844,21 @@ -- -- @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated ---+-- it has a low infix priority: @infixr 1@ (**>) :: (Functor m, Monad m) => View view m a -> View view m b -> View view m b (**>) form1 form2 = valid form1 *> form2 +infixr 1 **> , .**>. , <** , .<**. -- | The second elem result (even if it is not validated) is discarded, and the first is returned -- . This contrast with the applicative operator '*>' which fails the whole validation if -- the validation of the second elem fails. -- The second element is displayed however, as in the case of '<*'. -- see the `<**` examples+--+-- it has a low infix priority: @infixr 1@ (<**) :: (Functor m, Monad m) => View view m a -> View view m b -> View view m a@@ -877,11 +872,14 @@ -- | It is the way to interact with the user. -- It takes a widget and return the user result.--- If the environment has the result, ask don't ask to the user.+--+-- If the widget is not validated (return @Nothing@), the page is presented again+--+-- If the environment has the parameters being looked at, as a result of a previous interaction,+-- it will not ask to the user. -- To force asking in any case, put an `clearEnv` statement before ask- :: (- FormInput view,+ :: (FormInput view, MonadIO m, Typeable view) => View view m b -> FlowM view m b @@ -892,7 +890,7 @@ 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+ (Just ajaxl,Just v1,Just f, Just v2) -> do FlowM . lift $ (unsafeCoerce f) v2 FlowM $ lift receiveWithTimeouts ask w@@ -908,7 +906,7 @@ Just x -> do put st'{prevSeq= mfSequence st: prevSeq st',onInit= True ,mfEnv=[]}- breturn x -- BackT . return $ BackPoint x -- !> "just x"+ breturn x -- !> "just x" Nothing -> if not (inSync st') && not (onInit st') && hasParams (mfSequence st') (mfSeqCache st') ( mfEnv st') -- !> (show $ inSync st') !> (show $ onInit st')@@ -975,7 +973,7 @@ -- op1 -> setGoStraighTo (Just goop1) >> goop1 -- op2 -> setGoStraighTo (Just goop2) >> goop2@ ----- However this is very specialized. normally the back button detection is not necessary.+-- However this is very specialized. Normally the back button detection is not necessary. -- In a persistent flow (with step) even this default entry option would be completely automatic, -- since the process would restar at the last page visited. No setting is necessary. goingBack :: MonadState (MFlowState view) m => m Bool@@ -1133,12 +1131,13 @@ toSend = flink (verb ++ "?" ++ name ++ "=" ++ showx) v getParam1 name env [toSend] --- | When some HTML produces a parameter in response, but it is not produced by--- a form or a link, but for example by an script, returning notify the type checker--- and the parameter extractor about this fact.+-- | When some HTML return some response to the server, but it is not produced by+-- a form or a link, but for example by an script, @returning@ notify the type checker. --+-- At runtime the parameter is read from the environment and validated.+-- -- . The parameter is the visualization code, that accept a serialization function that generate--- the server invocation string used by the visualization to return the value by means+-- the server invocation string, used by the visualization to return the value by means -- of a link or a @window.location@ statement in javasCript returning ::(Typeable a, Read a, Show a,Monad m, FormInput view) => ((a->String) ->view) -> View view m a@@ -1175,6 +1174,7 @@ res1= if null res then Nothing else head res return $ FormElm vs res1 +-- | from a list of widgets, it return the validated ones. manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a] -> View view m [a] manyOf xs= whidden () *> (View $ do forms <- mapM runView xs @@ -1183,6 +1183,7 @@ res1= catMaybes $ map (\(FormElm _ r) -> r) forms return $ FormElm vs $ Just res1) + (>:>) ::(Monad m)=> View v m a -> View v m [a] -> View v m [a] (>:>) w ws= View $ do FormElm fs mxs <- runView $ ws@@ -1193,7 +1194,9 @@ (Nothing, mxs) -> mxs (Just x, _) -> Just [x] --- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types+-- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types.+--+-- it has a infix priority @infixr 5@ (|*>) :: (MonadIO m, Functor m,Monoid view) => View view m r -> [View view m r']@@ -1211,7 +1214,10 @@ infixr 5 |*>, .|*>. --- | Put a widget above and below other. Useful for navigation links in a page.+-- | Put a widget before and after other. Useful for navigation links in a page that appears at toAdd+-- and at the bottom of a page.++-- It has a low infix priority: @infixr 1@ (|+|) :: (Functor m, Monoid view, MonadIO m) => View view m r -> View view m r'
src/MFlow/Forms/Internals.hs view
@@ -104,74 +104,7 @@ getAdminName= liftIO $ atomically ( readDBRef rconf `onNothing` error "admin user not set" ) >>= \(Config u) -> return u -data Action m a= Backward Dynamic | Forward (Maybe (Handle m a)) a | Abort String -data Handle m a= forall b.Typeable b => Handle(b -> m(Action m a))--data Sup m a= Sup {runSup :: m (Action m a)}--instance Monad m => Monad(Sup m) where- fail msg = Sup . return $ Backward $ toDyn msg- return x = Sup . return $ Forward Nothing x- x >>= f = Sup $ loop Nothing- where- loop mmsg= do- v <- runSup x -- !> "loop"- case v of- Forward Nothing y -> runSup (f y)- Forward (Just (Handle h)) y ->- case mmsg of- Just dmsg ->- case fromDynamic dmsg of- Just msg -> do- r <- h msg- case r of- Forward _ y -> continueWith y- Backward msg -> loop $ Just msg- Abort text-> return $ Abort text- Nothing -> loop mmsg- Nothing -> continueWith y--- Backward msg -> return $ Backward msg-- continueWith y=do- z <- runSup (f y)- case z of- Backward msg -> loop $ Just msg -- !> "GoBack"- other -> return other--instance MonadTrans Sup where- lift mx= Sup $ mx >>= return . Forward Nothing--returnSup :: Monad m => Handle m a -> a -> Sup m a-returnSup hand x= Sup . return $ Forward (Just hand) x--liftSup :: Monad m => Handle m a -> m a -> Sup m a-liftSup h mx= Sup $ do- x <- mx- return $ Forward (Just h) x----instance MonadState s m => MonadState s (Sup m) where- get= lift get -- !> "get"- put= lift . put----handleString = Handle $ \(s ::String) -> do--- putStrLn $"repeat "++s--- return $ Forward Nothing ()--- ---test= runSup $ do--- liftSup handleString $ print "hola"--- n2 <- lift $ getLine--- lift $ print "n3"--- n3 <- lift $ getLine--- if n3 == "back"--- then fail "again"--- else lift $ print $ n2++n3---- data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable) @@ -677,9 +610,11 @@ --instance FormLet a m view => Widget (Maybe a) a m view where -- widget = digest -{- | Execute the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`+{- | Execute the Flow, in the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow` `waiMessageFlow` or `addMessageFlows` +The flow is executed in a loop. When the flow is finished, it is started again+ @main= do addMessageFlows [(\"noscript\",transient $ runFlow mainf)] forkIO . run 80 $ waiMessageFlow@@ -688,8 +623,11 @@ -} runFlow :: (FormInput view, Monad m) => FlowM view m a -> Token -> m a -runFlow f = \t -> evalStateT (runBackT . runFlowM $ breturn() >> f) mFlowState0{mfToken=t,mfEnv= tenv t} >>= return . fromFailBack -- >> return ()+runFlow f = \t ->+ evalStateT (runBackT . runFlowM $ breturn() >> loopf) mFlowState0{mfToken=t,mfEnv= tenv t} >>= return . fromFailBack -- >> return () where+ loopf= f >> loopf+ -- to restart the flow in case of going back before the first page of the flow fromFailBack (NoBack x) = x
src/MFlow/Wai.hs view
@@ -49,8 +49,8 @@ --(!>)= flip trace flow= "flow" ---ciflow= mk flow + instance Processable Request where pwfname env= if SB.null sc then noScript else SB.unpack sc where @@ -88,63 +88,6 @@ return . show $ t + n ---------------------------------------------- --- ---instance ConvertTo String TResp where --- convert = TResp . pack --- ---instance ConvertTo ByteString TResp where --- convert = TResp --- --- ---instance ConvertTo Error TResp where --- convert (Error e)= TResp . pack $ errorResponse e --- ---instance ToResponse v =>ConvertTo (HttpData v) TResp where --- convert= TRespR - - ---webScheduler :: Request --- -> ProcList --- -> IO (TResp, ThreadId) ---webScheduler = msgScheduler - ---theDir= unsafePerformIO getCurrentDirectory - ---wFMiddleware :: (Request -> Bool) -> (Request-> IO Response) -> (Request -> IO Response) ---wFMiddleware filter f = \ env -> if filter env then waiWorkflow env else f env -- !> "new message" - --- | An instance of the abstract "MFlow" scheduler to the <http://hackage.haskell.org/package/wai> interface. --- --- it accept the list of processes being scheduled and return a wai handler --- --- Example: --- --- @main= do --- --- putStrLn $ options messageFlows --- 'run' 80 $ 'waiMessageFlow' messageFlows --- where --- messageFlows= [(\"main\", 'runFlow' flowname ) --- ,(\"hello\", 'stateless' statelesproc) --- ,(\"trans\", 'transient' $ runflow transientflow] --- options msgs= \"in the browser choose\\n\\n\" ++ --- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] --- @ ---waiMessageFlow :: [(String, (Token -> Workflow IO ()))] --- -> (Request -> ResourceT IO Response) ---waiMessageFlow messageFlows = --- unsafePerformIO (addMessageFlows messageFlows) `seq` --- waiWorkflow -- wFMiddleware f other - --- where --- f env = unsafePerformIO $ do --- paths <- getMessageFlows >>= --- return (pwfname env `elem` paths) - --- other= (\env -> defaultResponse $ "options: " ++ opts) --- (paths,_)= unzip messageFlows --- opts= concatMap (\s -> "<a href=\""++ s ++"\">"++s ++"</a>, ") paths splitPath ""= ("","","")