@@ -0,0 +1,13157 @@
1+diff -ru orig/MFlow.cabal new/MFlow.cabal
2+--- orig/MFlow.cabal 2014-06-10 05:51:27.009015855 +0300
3++++ new/MFlow.cabal 2014-06-10 05:51:25.000000000 +0300
5+ extensible-exceptions , base >4.0 && <5,
6+ bytestring , containers , RefSerialize , TCache ,
7+ stm >2, time, old-time , vector , directory ,
8+- utf8-string , wai , case-insensitive ,
9++ utf8-string , wai , wai-extra, resourcet, case-insensitive ,
10+ http-types , conduit ,conduit-extra, text , parsec , warp ,
11+ warp-tls , random , blaze-html , blaze-markup ,
12+- monadloc, clientsession
13++ monadloc, clientsession, pwstore-fast
14+ exposed-modules: MFlow MFlow.Wai.Blaze.Html.All MFlow.Forms
15+ MFlow.Forms.Admin MFlow.Cookies MFlow.Wai
16+ MFlow.Forms.Blaze.Html MFlow.Forms.Test
18+ -- hamlet , shakespeare, monadloc , aws , network , hscolour ,
19+ -- persistent-template , persistent-sqlite , persistent ,
20+ -- conduit , http-conduit , monad-logger , safecopy ,
23+ -- main-is: demos-blaze.hs
25+ -- hs-source-dirs: Demos
27+ -- InitialConfig GenerateForm GenerateFormUndo GenerateFormUndoMsg WebService
29+ -- ghc-options: -iDemos -threaded -rtsopts
32+diff -ru orig/Setup.lhs new/Setup.lhs
33+--- orig/Setup.lhs 2014-06-10 05:51:26.953015857 +0300
34++++ new/Setup.lhs 2014-06-10 05:51:25.000000000 +0300
38+-> import Distribution.Simple
43++> import Distribution.Simple
46+diff -ru orig/src/MFlow/Cookies.hs new/src/MFlow/Cookies.hs
47+--- orig/src/MFlow/Cookies.hs 2014-06-10 05:51:26.961015857 +0300
48++++ new/src/MFlow/Cookies.hs 2014-06-10 05:51:25.000000000 +0300
50+-{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-}
52+-module MFlow.Cookies (
59+- paranoidEncryptCookie,
60+- paranoidDecryptCookie,
65+-import Control.Monad(MonadPlus(..), guard, replicateM_, when)
67+-import Data.Maybe(fromMaybe, fromJust)
68+-import System.IO.Unsafe
69+-import Control.Exception(handle)
74+-import Control.Monad.Identity
75+-import Data.ByteString.Char8 as B
76+-import Web.ClientSession
77+-import System.Environment
82+-contentHtml :: (ByteString, ByteString)
83+-contentHtml= ("Content-Type", "text/html; charset=UTF-8")
85+-type CookieT = (B.ByteString,B.ByteString,B.ByteString,Maybe B.ByteString)
88+- = UnEncryptedCookie CookieT
89+- | EncryptedCookie CookieT
90+- | ParanoidCookie CookieT
91+- deriving (Eq, Read, Show)
94+-cookieuser= "cookieuser"
97+- case lookup "Cookie" $ httpreq of
98+- Just str -> splitCookies str :: [(B.ByteString, B.ByteString)]
101+-cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs
103+-showCookie :: Cookie -> B.ByteString
104+-showCookie c@(EncryptedCookie _) = showCookie' $ decryptAndToTuple c
105+-showCookie c@(ParanoidCookie _) = showCookie' $ decryptAndToTuple c
106+-showCookie (UnEncryptedCookie c) = showCookie' c
108+-showCookie' (n,v,p,me) = n <> "=" <> v <>
112+-showMaxAge Nothing = ""
113+-showMaxAge (Just e) = ";Max-age=" <> e
115+-splitCookies cookies = f cookies []
117+- f s r | B.null s = r
120+- xs = B.dropWhile (==' ') xs0
121+- name = B.takeWhile (/='=') xs
122+- xs1 = B.dropWhile (/='=') xs
123+- xs2 = B.dropWhile (=='=') xs1
124+- val = B.takeWhile (/=';') xs2
125+- xs3 = B.dropWhile (/=';') xs2
126+- xs4 = B.dropWhile (==';') xs3
127+- xs5 = B.dropWhile (==' ') xs4
128+- in f xs5 ((name,val):r)
130++{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-}
132++module MFlow.Cookies (
139++ paranoidEncryptCookie,
140++ paranoidDecryptCookie,
145++import Control.Monad(MonadPlus(..), guard, replicateM_, when)
147++import Data.Maybe(fromMaybe, fromJust)
148++import System.IO.Unsafe
149++import Control.Exception(handle)
150++import Data.Typeable
151++import Unsafe.Coerce
154++import Control.Monad.Identity
155++import Data.ByteString.Char8 as B
156++import Web.ClientSession
157++import System.Environment
159++--import Debug.Trace
162++contentHtml :: (ByteString, ByteString)
163++contentHtml= ("Content-Type", "text/html; charset=UTF-8")
165++type CookieT = (B.ByteString,B.ByteString,B.ByteString,Maybe B.ByteString)
168++ = UnEncryptedCookie CookieT
169++ | EncryptedCookie CookieT
170++ | ParanoidCookie CookieT
171++ deriving (Eq, Read, Show)
173++cookieuser :: String
174++cookieuser= "cookieuser"
177++ case lookup "Cookie" $ httpreq of
178++ Just str -> splitCookies str :: [(B.ByteString, B.ByteString)]
181++cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs
183++showCookie :: Cookie -> B.ByteString
184++showCookie c@(EncryptedCookie _) = showCookie' $ decryptAndToTuple c
185++showCookie c@(ParanoidCookie _) = showCookie' $ decryptAndToTuple c
186++showCookie (UnEncryptedCookie c) = showCookie' c
188++showCookie' (n,v,p,me) = n <> "=" <> v <>
192++showMaxAge Nothing = ""
193++showMaxAge (Just e) = ";Max-age=" <> e
195++splitCookies cookies = f cookies []
197++ f s r | B.null s = r
200++ xs = B.dropWhile (==' ') xs0
201++ name = B.takeWhile (/='=') xs
202++ xs1 = B.dropWhile (/='=') xs
203++ xs2 = B.dropWhile (=='=') xs1
204++ val = B.takeWhile (/=';') xs2
205++ xs3 = B.dropWhile (/=';') xs2
206++ xs4 = B.dropWhile (==';') xs3
207++ xs5 = B.dropWhile (==' ') xs4
208++ in f xs5 ((name,val):r)
210+ ----------------------------
212+---readEnv :: Parser [(String,String)]
217+- return (n,v)) `sepBy` (string "&")
219+-urlEncoded :: Parsec String () String
221+- = many ( alphaNum `mplus` extra `mplus` safe
222+- `mplus` do{ char '+' ; return ' '}
223+- `mplus` do{ char '%' ; hexadecimal }
227+---extra :: Parser Char
228+-extra = satisfy (`Prelude.elem` "!*'(),/\"")
230+---safe :: Parser Char
231+-safe = satisfy (`Prelude.elem` "$-_.")
233+---hexadecimal :: Parser HexString
234+-hexadecimal = do d1 <- hexDigit
236+- return .chr $ toInt d1* 16 + toInt d2
237+- where toInt d | isDigit d = ord d - ord '0'
238+- toInt d | isHexDigit d = (ord d - ord 'A') + 10
239+- toInt d = error ("hex2int: illegal hex digit " ++ [d])
243+-decryptCookie :: Cookie -> IO Cookie
244+-decryptCookie c@(UnEncryptedCookie _) = return c
245+-decryptCookie (EncryptedCookie c) = decryptCookie' c
246+-decryptCookie (ParanoidCookie c) = paranoidDecryptCookie c
248+--- Uses 4 seperate keys, corresponding to the 4 seperate fields in the Cookie.
249+-paranoidEncryptCookie :: CookieT -> IO Cookie
250+-paranoidEncryptCookie (a,b,c,d) = do
251+- key1 <- getKey "CookieKey1.key"
252+- key2 <- getKey "CookieKey2.key"
253+- key3 <- getKey "CookieKey3.key"
254+- key4 <- getKey "CookieKey4.key"
259+- return $ ParanoidCookie
260+- ( encrypt key1 iv1 a,
261+- encrypt key2 iv2 b,
262+- encrypt key3 iv3 c,
263+- encryptMaybe key4 iv4 d)
265+-paranoidDecryptCookie :: CookieT -> IO Cookie
266+-paranoidDecryptCookie (a,b,c,d) = do
267+- key1 <- getKey "CookieKey1.key"
268+- key2 <- getKey "CookieKey2.key"
269+- key3 <- getKey "CookieKey3.key"
270+- key4 <- getKey "CookieKey4.key"
271+- return $ UnEncryptedCookie
272+- ( decryptFM key1 a,
275+- decryptMaybe key4 d)
277+--- Uses a single key to encrypt all 4 fields.
278+-encryptCookie :: CookieT -> IO Cookie
279+-encryptCookie (a,b,c,d) = do
280+- key <- getKey "CookieKey.key"
285+- return $ EncryptedCookie
286+- ( encrypt key iv1 a,
289+- encryptMaybe key iv4 d)
291+-decryptCookie' :: CookieT -> IO Cookie
292+-decryptCookie' (a,b,c,d) = do
293+- key <- getKey "CookieKey.key"
294+- return $ UnEncryptedCookie
298+- decryptMaybe key d)
300+-encryptMaybe :: Key -> IV -> Maybe ByteString -> Maybe ByteString
301+-encryptMaybe k i (Just s) = Just $ encrypt k i s
302+-encryptMaybe _ _ Nothing = Nothing
304+-decryptMaybe :: Key -> Maybe ByteString -> Maybe ByteString
305+-decryptMaybe k (Just s) = Just $ fromMaybe "" $ decrypt k s
306+-decryptMaybe _ Nothing = Nothing
308+-decryptFM :: Key -> ByteString -> ByteString
309+-decryptFM k b = fromMaybe "" $ decrypt k b
311+-cookieToTuple :: Cookie -> CookieT
312+-cookieToTuple (UnEncryptedCookie c) = c
313+-cookieToTuple (EncryptedCookie c) = c
314+-cookieToTuple (ParanoidCookie c) = c
316+-decryptAndToTuple :: Cookie -> CookieT
317+-decryptAndToTuple = cookieToTuple . unsafePerformIO . decryptCookie
319++--readEnv :: Parser [(String,String)]
324++ return (n,v)) `sepBy` (string "&")
326++urlEncoded :: Parsec String () String
328++ = many ( alphaNum `mplus` extra `mplus` safe
329++ `mplus` do{ char '+' ; return ' '}
330++ `mplus` do{ char '%' ; hexadecimal }
334++--extra :: Parser Char
335++extra = satisfy (`Prelude.elem` "!*'(),/\"")
337++--safe :: Parser Char
338++safe = satisfy (`Prelude.elem` "$-_.")
340++--hexadecimal :: Parser HexString
341++hexadecimal = do d1 <- hexDigit
343++ return .chr $ toInt d1* 16 + toInt d2
344++ where toInt d | isDigit d = ord d - ord '0'
345++ toInt d | isHexDigit d = (ord d - ord 'A') + 10
346++ toInt d = error ("hex2int: illegal hex digit " ++ [d])
350++decryptCookie :: Cookie -> IO Cookie
351++decryptCookie c@(UnEncryptedCookie _) = return c
352++decryptCookie (EncryptedCookie c) = decryptCookie' c
353++decryptCookie (ParanoidCookie c) = paranoidDecryptCookie c
355++-- Uses 4 seperate keys, corresponding to the 4 seperate fields in the Cookie.
356++paranoidEncryptCookie :: CookieT -> IO Cookie
357++paranoidEncryptCookie (a,b,c,d) = do
358++ key1 <- getKey "CookieKey1.key"
359++ key2 <- getKey "CookieKey2.key"
360++ key3 <- getKey "CookieKey3.key"
361++ key4 <- getKey "CookieKey4.key"
366++ return $ ParanoidCookie
367++ ( encrypt key1 iv1 a,
368++ encrypt key2 iv2 b,
369++ encrypt key3 iv3 c,
370++ encryptMaybe key4 iv4 d)
372++paranoidDecryptCookie :: CookieT -> IO Cookie
373++paranoidDecryptCookie (a,b,c,d) = do
374++ key1 <- getKey "CookieKey1.key"
375++ key2 <- getKey "CookieKey2.key"
376++ key3 <- getKey "CookieKey3.key"
377++ key4 <- getKey "CookieKey4.key"
378++ return $ UnEncryptedCookie
379++ ( decryptFM key1 a,
382++ decryptMaybe key4 d)
384++-- Uses a single key to encrypt all 4 fields.
385++encryptCookie :: CookieT -> IO Cookie
386++encryptCookie (a,b,c,d) = do
387++ key <- getKey "CookieKey.key"
392++ return $ EncryptedCookie
393++ ( encrypt key iv1 a,
396++ encryptMaybe key iv4 d)
398++decryptCookie' :: CookieT -> IO Cookie
399++decryptCookie' (a,b,c,d) = do
400++ key <- getKey "CookieKey.key"
401++ return $ UnEncryptedCookie
405++ decryptMaybe key d)
407++encryptMaybe :: Key -> IV -> Maybe ByteString -> Maybe ByteString
408++encryptMaybe k i (Just s) = Just $ encrypt k i s
409++encryptMaybe _ _ Nothing = Nothing
411++decryptMaybe :: Key -> Maybe ByteString -> Maybe ByteString
412++decryptMaybe k (Just s) = Just $ fromMaybe "" $ decrypt k s
413++decryptMaybe _ Nothing = Nothing
415++decryptFM :: Key -> ByteString -> ByteString
416++decryptFM k b = fromMaybe "" $ decrypt k b
418++cookieToTuple :: Cookie -> CookieT
419++cookieToTuple (UnEncryptedCookie c) = c
420++cookieToTuple (EncryptedCookie c) = c
421++cookieToTuple (ParanoidCookie c) = c
423++decryptAndToTuple :: Cookie -> CookieT
424++decryptAndToTuple = cookieToTuple . unsafePerformIO . decryptCookie
425+diff -ru orig/src/MFlow/Forms/Admin.hs new/src/MFlow/Forms/Admin.hs
426+--- orig/src/MFlow/Forms/Admin.hs 2014-06-10 05:51:26.985015856 +0300
427++++ new/src/MFlow/Forms/Admin.hs 2014-06-10 05:51:25.000000000 +0300
430+- -XScopedTypeVariables
433+-module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where
435++ -XScopedTypeVariables
438++module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where
441+-import MFlow.Forms.Blaze.Html
442+-import Text.Blaze.Html5 hiding (map)
443+-import Control.Applicative
444+-import Control.Workflow
445+-import Control.Monad.Trans
447+-import Data.TCache.IndexQuery
450+-import System.IO.Unsafe
451+-import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack)
453+-import Data.RefSerialize hiding ((<|>))
454+-import Data.Typeable
457+-import Data.Map as M (keys, toList)
459+-import Control.Exception as E
460+-import Control.Concurrent
461+-import Control.Concurrent.MVar
465+-ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done"
467+--- | A small console interpreter with some commands:
469+--- [@sync@] Synchronize the cache with persistent storage (see `syncCache`)
471+--- [@flush@] Flush the cache
473+--- [@end@] Synchronize and exit
475+--- [@abort@] Exit. Do not synchronize
477+--- on exception, for example Control-c, it sync and exits.
478+--- It must be used as the last statement of the main procedure.
481+- msgs <- getMessageFlows
483+- putStrLn $ "Served:"
484+- mapM putStrLn [ " http://server:port/"++ i | i <- M.keys msgs]
486+- putStrLn "Commands: sync, flush, end, abort"
488+- `E.catch` (\(e:: E.SomeException) ->do
490+- error $ "\nException: "++ show e)
493+- putStr ">"; hFlush stdout
496+- "sync" -> ssyncCache
497+- "flush" -> atomically flushAll >> putStrLn "flushed cache"
498+- "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess
499+- "abort" -> exitWith ExitSuccess
503+--- | execute the process and wait for its finalization.
504+--- then it synchronizes the cache
505++import MFlow.Forms.Blaze.Html
506++import Text.Blaze.Html5 hiding (map)
507++import Control.Applicative
508++import Control.Workflow
509++import Control.Monad.Trans
511++import Data.TCache.IndexQuery
514++import System.IO.Unsafe
515++import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack)
517++import Data.RefSerialize hiding ((<|>))
518++import Data.Typeable
521++import Data.Map as M (keys, toList)
523++import Control.Exception as E
524++import Control.Concurrent
525++import Control.Concurrent.MVar
529++ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done"
531++-- | A small console interpreter with some commands:
533++-- [@sync@] Synchronize the cache with persistent storage (see `syncCache`)
535++-- [@flush@] Flush the cache
537++-- [@end@] Synchronize and exit
539++-- [@abort@] Exit. Do not synchronize
541++-- on exception, for example Control-c, it sync and exits.
542++-- It must be used as the last statement of the main procedure.
545++ msgs <- getMessageFlows
547++ putStrLn $ "Served:"
548++ mapM putStrLn [ " http://server:port/"++ i | i <- M.keys msgs]
550++ putStrLn "Commands: sync, flush, end, abort"
552++ `E.catch` (\(e:: E.SomeException) ->do
554++ error $ "\nException: "++ show e)
557++ putStr ">"; hFlush stdout
560++ "sync" -> ssyncCache
561++ "flush" -> atomically flushAll >> putStrLn "flushed cache"
562++ "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess
563++ "abort" -> exitWith ExitSuccess
567++-- | execute the process and wait for its finalization.
568++-- then it synchronizes the cache
571+ putStrLn "Using configuration: "
572+ mapM_ putStrLn [k ++"= "++ show v | (k,v) <- M.toList config]
575+- forkIO (f1 >> putMVar mv True)
576+- putStrLn "wait: ready"
579++ forkIO (f1 >> putMVar mv True)
580++ putStrLn "wait: ready"
583+- `E.catch` (\(e:: E.SomeException) ->do
585+- error $ "Signal: "++ show e)
590+- n <- getNumProcessors
591+- putStr "Running in "
593+- putStrLn " core(s)"
597+--- | Install the admin flow in the list of flows handled by `HackMessageFlow`
598+--- this gives access to an administrator page. It is necessary to
599+--- create an admin user with `setAdminUser`.
601+--- The administration page is reached with the path \"adminserv\"
602+-addAdminWF= addMessageFlows[("adminserv", runFlow $ transientNav adminMFlow)]
605+-adminMFlow :: FlowM Html IO ()
607+- let admin = getAdminName
608+- u <- getUser (Just admin) $ p << b << "Please login as Administrator" ++> userLogin
609+- op <- ask $ p <<< wlink "sync" (b << "sync")
610+- <|> p <<< wlink "flush" (b << "flush")
611+- <|> p <<< wlink "errors"(b << "errors")
612+- <|> p <<< wlink "users" (b << "users")
613+- <|> p <<< wlink "end" (b << "end")
614+- <|> wlink "abort" (b << "abort")
618+- "sync" -> liftIO $ syncCache >> print "syncronized cache"
619+- "flush" -> liftIO $ atomically flushAll >> print "flushed cache"
622+- "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess)
623+- "abort" -> liftIO $ exitWith(ExitSuccess)
629+- size <- liftIO $ hFileSize hlog
631+- then ask $ wlink () (b << "no error log")
633+- liftIO $ hSeek hlog AbsoluteSeek 0
634+- log <- liftIO $ hGetNonBlocking hlog (fromIntegral size)
636+- let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]"
637+- let rows= [wlink (Prelude.head e) (b << Prelude.head e) `waction` optionsUser : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls]
638+- showFormList rows 0 10
648+- users <- liftIO $ atomically $ return . map fst =<< indexOf userName
650+- showFormList [[wlink u (b << u) `waction` optionsUser ] | u<- users] 0 10
653+- :: [[View Html IO ()]]
654+- -> Int -> Int -> FlowM Html IO b
655+-showFormList ls n l= do
656+- nav <- ask $ updown n l <|> (list **> updown n l)
657+- showFormList ls nav l
660+- list= table <<< firstOf (span1 n l [tr <<< cols e | e <- ls ])
662+- cols e= firstOf[td <<< c | c <- e]
663+- span1 n l = take l . drop n
664+- updown n l= wlink ( n +l) (b << "up ") <|> wlink ( n -l) (b << "down ") <++ br
667+- wfs <- liftIO $ return . M.keys =<< getMessageFlows
668+- stats <- let u= undefined
669+- in liftIO $ mapM (\wf -> getWFHistory wf (Token wf us u u u u u u)) wfs
670+- let wfss= filter (isJust . snd) $ zip wfs stats
672+- then ask $ b << " not logs for this user" ++> wlink () (b << "Press here")
674+- wf <- ask $ firstOf [ wlink wf (p << wf) | (wf,_) <- wfss]
675+- ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf wfss) ++> wlink () (p << "press to menu")
678++ `E.catch` (\(e:: E.SomeException) ->do
680++ error $ "Signal: "++ show e)
685++ n <- getNumProcessors
686++ putStr "Running in "
688++ putStrLn " core(s)"
692++-- | Install the admin flow in the list of flows handled by `HackMessageFlow`
693++-- this gives access to an administrator page. It is necessary to
694++-- create an admin user with `setAdminUser`.
696++-- The administration page is reached with the path \"adminserv\"
697++addAdminWF= addMessageFlows[("adminserv", runFlow $ transientNav adminMFlow)]
700++adminMFlow :: FlowM Html IO ()
702++ let admin = getAdminName
703++ u <- getUser (Just admin) $ p << b << "Please login as Administrator" ++> userLogin
704++ op <- ask $ p <<< wlink "sync" (b << "sync")
705++ <|> p <<< wlink "flush" (b << "flush")
706++ <|> p <<< wlink "errors"(b << "errors")
707++ <|> p <<< wlink "users" (b << "users")
708++ <|> p <<< wlink "end" (b << "end")
709++ <|> wlink "abort" (b << "abort")
713++ "sync" -> liftIO $ syncCache >> print "syncronized cache"
714++ "flush" -> liftIO $ atomically flushAll >> print "flushed cache"
717++ "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess)
718++ "abort" -> liftIO $ exitWith(ExitSuccess)
724++ size <- liftIO $ hFileSize hlog
726++ then ask $ wlink () (b << "no error log")
728++ liftIO $ hSeek hlog AbsoluteSeek 0
729++ log <- liftIO $ hGetNonBlocking hlog (fromIntegral size)
731++ let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]"
732++ let rows= [wlink (Prelude.head e) (b << Prelude.head e) `waction` optionsUser : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls]
733++ showFormList rows 0 10
743++ users <- liftIO $ atomically $ return . map fst =<< indexOf userName
745++ showFormList [[wlink u (b << u) `waction` optionsUser ] | u<- users] 0 10
748++ :: [[View Html IO ()]]
749++ -> Int -> Int -> FlowM Html IO b
750++showFormList ls n l= do
751++ nav <- ask $ updown n l <|> (list **> updown n l)
752++ showFormList ls nav l
755++ list= table <<< firstOf (span1 n l [tr <<< cols e | e <- ls ])
757++ cols e= firstOf[td <<< c | c <- e]
758++ span1 n l = take l . drop n
759++ updown n l= wlink ( n +l) (b << "up ") <|> wlink ( n -l) (b << "down ") <++ br
762++ wfs <- liftIO $ return . M.keys =<< getMessageFlows
763++ stats <- let u= undefined
764++ in liftIO $ mapM (\wf -> getWFHistory wf (Token wf us u u u u u u)) wfs
765++ let wfss= filter (isJust . snd) $ zip wfs stats
767++ then ask $ b << " not logs for this user" ++> wlink () (b << "Press here")
769++ wf <- ask $ firstOf [ wlink wf (p << wf) | (wf,_) <- wfss]
770++ ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf wfss) ++> wlink () (p << "press to menu")
772+diff -ru orig/src/MFlow/Forms/Blaze/Html.hs new/src/MFlow/Forms/Blaze/Html.hs
773+--- orig/src/MFlow/Forms/Blaze/Html.hs 2014-06-10 05:51:26.989015856 +0300
774++++ new/src/MFlow/Forms/Blaze/Html.hs 2014-06-10 05:51:25.000000000 +0300
776+ in if msel then tag ! selected (toValue ("" ::String)) else tag
779+- formAction action form = St.form ! acceptCharset "UTF-8" ! At.action (toValue action) ! method (toValue ("post" :: String)) $ form
780++ formAction action method1 form = St.form ! acceptCharset "UTF-8" ! At.action (toValue action) ! method (toValue method1) $ form
783+ fromStrNoEncode = preEscapedToMarkup
784+diff -ru orig/src/MFlow/Forms/Internals.hs new/src/MFlow/Forms/Internals.hs
785+--- orig/src/MFlow/Forms/Internals.hs 2014-06-10 05:51:26.981015856 +0300
786++++ new/src/MFlow/Forms/Internals.hs 2014-06-10 05:51:25.000000000 +0300
788+------------------------------------------------------------------------------
790+--- Module : MFlow.Forms.Internals
794+--- Maintainer : agocorona@gmail.com
795+--- Stability : experimental
800+------------------------------------------------------------------------------
801+-{-# OPTIONS -XDeriveDataTypeable
802+- -XExistentialQuantification
803+- -XScopedTypeVariables
804+- -XFlexibleInstances
805+- -XUndecidableInstances
806+- -XMultiParamTypeClasses
807+- -XGeneralizedNewtypeDeriving
809+- -XOverlappingInstances
813+-module MFlow.Forms.Internals where
815+-import MFlow.Cookies
816+-import Control.Applicative
818+-import Control.Monad.Trans
819+-import Control.Monad.State
820+-import Data.ByteString.Lazy.UTF8 as B hiding (length, foldr, take)
821+-import qualified Data.ByteString.UTF8 as SB
822+-import Data.Typeable
823+-import Data.RefSerialize hiding((<|>))
825+-import Data.TCache.Memoization
826+-import Data.TCache.DefaultPersistence
827+-import Data.TCache.Memoization
829+-import qualified Data.Map as M
830+-import Unsafe.Coerce
831+-import Control.Workflow as WF
832+-import Control.Monad.Identity
834+-import System.IO.Unsafe
835+-import Control.Concurrent.MVar
836++-----------------------------------------------------------------------------
838++-- Module : MFlow.Forms.Internals
842++-- Maintainer : agocorona@gmail.com
843++-- Stability : experimental
848++-----------------------------------------------------------------------------
849++{-# OPTIONS -XDeriveDataTypeable
850++ -XExistentialQuantification
851++ -XScopedTypeVariables
852++ -XFlexibleInstances
853++ -XUndecidableInstances
854++ -XMultiParamTypeClasses
855++ -XGeneralizedNewtypeDeriving
857++ -XOverlappingInstances
861++module MFlow.Forms.Internals where
863++import MFlow.Cookies
864++import Control.Applicative
866++import Control.Monad.Trans
867++import Control.Monad.State
868++import Data.ByteString.Lazy.UTF8 as B hiding (length, foldr, take)
869++import qualified Data.ByteString.UTF8 as SB
870++import Data.Typeable
871++import Data.RefSerialize hiding((<|>))
873++import Data.TCache.Memoization
874++import Data.TCache.DefaultPersistence
875++import Data.TCache.Memoization
877++import qualified Data.Map as M
878++import Unsafe.Coerce
879++import Control.Workflow as WF
880++import Control.Monad.Identity
882++import System.IO.Unsafe
883++import Control.Concurrent.MVar
884+ import qualified Data.Text as T
886+ import Data.List(stripPrefix)
887+ import Data.Maybe(isJust)
888+ import Control.Concurrent.STM
889+ import Data.TCache.Memoization
895+-import Control.Exception as CE
896+-import Control.Concurrent
897+-import Control.Monad.Loc
900+---import Debug.Trace
904+-data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable)
907+-instance (Serialize a) => Serialize (FailBack a ) where
908+- showp (BackPoint x)= insertString (fromString iCanFailBack) >> showp x
909+- showp (NoBack x) = insertString (fromString noFailBack) >> showp x
910+- showp GoBack = insertString (fromString repeatPlease)
912+- readp = choice [icanFailBackp,repeatPleasep,noFailBackp]
914+- noFailBackp = symbol noFailBack >> readp >>= return . NoBack
915+- icanFailBackp = symbol iCanFailBack >> readp >>= return . BackPoint
916+- repeatPleasep = symbol repeatPlease >> return GoBack
922+-newtype Sup m a = Sup { runSup :: m (FailBack a ) }
924+-class MonadState s m => Supervise s m where
925+- supBack :: s -> m () -- called before backtracing. state passed is the previous
926+- supBack = const $ return () -- By default the state passed is the last one
928+- supervise :: m (FailBack a) -> m (FailBack a)
933+-instance (Supervise s m)=> Monad (Sup m) where
934+- fail _ = Sup . return $ GoBack
935+- return x = Sup . return $ NoBack x
936+- x >>= f = Sup $ loop
940+- v <- supervise $ runSup x -- !> "loop"
942+- NoBack y -> supervise $ runSup (f y) -- !> "runback"
944+- z <- supervise $ runSup (f y) -- !> "BACK"
946+- GoBack -> supBack s >> loop -- !> "BACKTRACKING"
947+- other -> return other
948+- GoBack -> return $ GoBack
951+-fromFailBack (NoBack x) = x
952+-fromFailBack (BackPoint x)= x
953+-toFailBack x= NoBack x
956+--- | the FlowM monad executes the page navigation. It perform Backtracking when necessary to syncronize
957+--- when the user press the back button or when the user enter an arbitrary URL. The instruction pointer
958+--- is moved to the right position within the procedure to handle the request.
960+--- However this is transparent to the programmer, who codify in the style of a console application.
961+-newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a} deriving (Monad,MonadIO,Functor,MonadState(MFlowState v))
965+-{-# NOINLINE breturn #-}
967+--- | Use this instead of return to return from a computation with ask statements
969+--- This way when the user press the back button, the computation will execute back, to
970+--- the returned code, according with the user navigation.
971+-breturn :: (Monad m) => a -> FlowM v m a
972+-breturn = flowM . Sup . return . BackPoint -- !> "breturn"
975+-instance (Supervise s m,MonadIO m) => MonadIO (Sup m) where
976+- liftIO f= Sup $ liftIO f >>= \ x -> return $ NoBack x
978+-instance (Monad m,Functor m) => Functor (Sup m) where
982+- BackPoint x -> return . BackPoint $ f x
983+- NoBack x -> return . NoBack $ f x
984+- GoBack -> return $ GoBack
987+-liftSup f = Sup $ f >>= \x -> return $ NoBack x
988+-instance MonadTrans Sup where
989+- lift f = Sup $ f >>= \x -> return $ NoBack x
992+-instance (Supervise s m,MonadState s m) => MonadState s (Sup m) where
993+- get= lift get -- !> "get"
996+-type WState view m = StateT (MFlowState view) m
997+-type FlowMM view m= Sup (WState view m)
999+-data FormElm view a = FormElm view (Maybe a) deriving Typeable
1001+-instance (Monoid view,Serialize a) => Serialize (FormElm view a) where
1002+- showp (FormElm _ x)= showp x
1003+- readp= readp >>= \x -> return $ FormElm mempty x
1005+--- | @View v m a@ is a widget (formlet) with formatting `v` running the monad `m` (usually `IO`) and which return a value of type `a`
1007+--- It has 'Applicative', 'Alternative' and 'Monad' instances.
1009+--- Things to know about these instances:
1011+--- If the View expression does not validate, ask will present the page again.
1013+--- /Alternative instance/: Both alternatives are executed. The rest is as usual
1015+--- /Monad Instance/:
1017+--- The rendering of each statement is added to the previous. If you want to avoid this, use 'wcallback'
1019+--- The execution is stopped when the statement has a formlet-widget that does not validate and
1020+--- return an invalid response (So it will present the page again if no other widget in the expression validates).
1022+--- The monadic code is executed from the beginning each time the page is presented or refreshed
1024+--- use 'pageFlow' if your page has more than one monadic computation with dynamic behaviour
1026+--- use 'pageFlow' to identify each subflow branch of a conditional
1030+--- > pageFlow "myid" $ do
1032+--- > liftIO $ ioaction1 r
1034+--- > liftIO $ ioaction2 s
1036+--- > True -> pageFlow "idtrue" $ do ....
1037+--- > False -> paeFlow "idfalse" $ do ...
1040+--- Here if @formlet2@ do not validate, @ioaction2@ is not executed. But if @formLet1@ validates and the
1041+--- page is refreshed two times (because @formlet2@ has failed, see above),then @ioaction1@ is executed two times.
1042+--- use 'cachedByKey' if you want to avoid repeated IO executions.
1043+-newtype View v m a = View { runView :: WState v m (FormElm v a)}
1046+-instance Monad m => Supervise (MFlowState v) (WState v m) where
1047+- supBack st= do -- the previous state is recovered, with the exception of these fields:
1048+- MFlowState{..} <- get
1049+- put st{ mfEnv= mfEnv,mfToken=mfToken
1052+- , mfTrace= mfTrace
1058++import Control.Exception as CE
1059++import Control.Concurrent
1060++import Control.Monad.Loc
1067++data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable)
1069++instance Functor FailBack where
1070++ fmap f GoBack= GoBack
1071++ fmap f (BackPoint x)= BackPoint $ f x
1072++ fmap f (NoBack x)= NoBack $ f x
1074++instance Applicative FailBack where
1076++ _ <*> GoBack = GoBack
1077++ GoBack <*> _ = GoBack
1078++ k <*> x = NoBack $ (fromFailBack k) (fromFailBack x)
1080++instance Alternative FailBack where
1085++instance (Serialize a) => Serialize (FailBack a ) where
1086++ showp (BackPoint x)= insertString (fromString iCanFailBack) >> showp x
1087++ showp (NoBack x) = insertString (fromString noFailBack) >> showp x
1088++ showp GoBack = insertString (fromString repeatPlease)
1090++ readp = choice [icanFailBackp,repeatPleasep,noFailBackp]
1092++ noFailBackp = symbol noFailBack >> readp >>= return . NoBack
1093++ icanFailBackp = symbol iCanFailBack >> readp >>= return . BackPoint
1094++ repeatPleasep = symbol repeatPlease >> return GoBack
1100++newtype Sup m a = Sup { runSup :: m (FailBack a ) }
1102++class MonadState s m => Supervise s m where
1103++ supBack :: s -> m () -- called before backtracing. state passed is the previous
1104++ supBack = const $ return () -- By default the state passed is the last one
1106++ supervise :: m (FailBack a) -> m (FailBack a)
1111++instance (Supervise s m)=> Monad (Sup m) where
1112++ fail _ = Sup . return $ GoBack
1113++ return x = Sup . return $ NoBack x
1114++ x >>= f = Sup $ loop
1118++ v <- supervise $ runSup x -- !> "loop"
1120++ NoBack y -> supervise $ runSup (f y) -- !> "runback"
1122++ z <- supervise $ runSup (f y) -- !> "BACK"
1124++ GoBack -> supBack s >> loop -- !> "BACKTRACKING"
1125++ other -> return other
1126++ GoBack -> return $ GoBack
1129++fromFailBack (NoBack x) = x
1130++fromFailBack (BackPoint x)= x
1131++toFailBack x= NoBack x
1133++instance (Monad m,Applicative m) => Applicative (Sup m) where
1134++ pure x = Sup . return $ NoBack x
1140++instance(Monad m, Applicative m) => Alternative (Sup m) where
1141++ empty = Sup . return $ GoBack
1145++ GoBack -> runSup g !> "GOBACK"
1148++-- | the FlowM monad executes the page navigation. It perform Backtracking when necessary to syncronize
1149++-- when the user press the back button or when the user enter an arbitrary URL. The instruction pointer
1150++-- is moved to the right position within the procedure to handle the request.
1152++-- However this is transparent to the programmer, who codify in the style of a console application.
1153++newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a}
1154++ deriving (Applicative,Alternative,Monad,MonadIO,Functor
1155++ ,MonadState(MFlowState v))
1157++--runFlowM= runView
1159++{-# NOINLINE breturn #-}
1161++-- | Use this instead of return to return from a computation with ask statements
1163++-- This way when the user press the back button, the computation will execute back, to
1164++-- the returned code, according with the user navigation.
1165++breturn :: (Monad m) => a -> FlowM v m a
1166++breturn = FlowM . Sup . return . BackPoint -- !> "breturn"
1169++instance (Supervise s m,MonadIO m) => MonadIO (Sup m) where
1170++ liftIO f= Sup $ liftIO f >>= \ x -> return $ NoBack x
1172++instance (Monad m,Functor m) => Functor (Sup m) where
1173++ fmap f g= Sup $ do
1176++ BackPoint x -> return . BackPoint $ f x
1177++ NoBack x -> return . NoBack $ f x
1178++ GoBack -> return $ GoBack
1181++liftSup f = Sup $ f >>= \x -> return $ NoBack x
1182++instance MonadTrans Sup where
1183++ lift f = Sup $ f >>= \x -> return $ NoBack x
1186++instance (Supervise s m,MonadState s m) => MonadState s (Sup m) where
1187++ get= lift get -- !> "get"
1190++type WState view m = StateT (MFlowState view) m
1191++type FlowMM view m= Sup (WState view m)
1193++data FormElm view a = FormElm view (Maybe a) deriving Typeable
1195++instance (Monoid view,Serialize a) => Serialize (FormElm view a) where
1196++ showp (FormElm _ x)= showp x
1197++ readp= readp >>= \x -> return $ FormElm mempty x
1200++-- | @View v m a@ is a widget (formlet) with formatting `v` running the monad `m` (usually `IO`) and which return a value of type `a`
1202++-- It has 'Applicative', 'Alternative' and 'Monad' instances.
1204++-- Things to know about these instances:
1206++-- If the View expression does not validate, ask will present the page again.
1208++-- /Alternative instance/: Both alternatives are executed. The rest is as usual
1210++-- /Monad Instance/:
1212++-- The rendering of each statement is added to the previous. If you want to avoid this, use 'wcallback'
1214++-- The execution is stopped when the statement has a formlet-widget that does not validate and
1215++-- return an invalid response (So it will present the page again if no other widget in the expression validates).
1217++-- The monadic code is executed from the beginning each time the page is presented or refreshed
1219++-- use 'pageFlow' if your page has more than one monadic computation with dynamic behaviour
1221++-- use 'pageFlow' to identify each subflow branch of a conditional
1225++-- > pageFlow "myid" $ do
1227++-- > liftIO $ ioaction1 r
1229++-- > liftIO $ ioaction2 s
1231++-- > True -> pageFlow "idtrue" $ do ....
1232++-- > False -> paeFlow "idfalse" $ do ...
1235++-- Here if @formlet2@ do not validate, @ioaction2@ is not executed. But if @formLet1@ validates and the
1236++-- page is refreshed two times (because @formlet2@ has failed, see above),then @ioaction1@ is executed two times.
1237++-- use 'cachedByKey' if you want to avoid repeated IO executions.
1238++newtype View v m a = View { runView :: WState v m (FormElm v a)}
1241++instance Monad m => Supervise (MFlowState v) (WState v m) where
1242++ supBack st= do -- the previous state is recovered, with the exception of these fields:
1243++ MFlowState{..} <- get
1244++ put st{ mfEnv= mfEnv,mfToken=mfToken
1247++ , mfTrace= mfTrace
1254+-instance MonadLoc (FlowM v IO) where
1255+- withLoc loc f = FlowM . Sup $ do
1258+- (r,s') <- lift $ do
1259+- rs@(r,s') <- runStateT (runSup (runFlowM f) ) s
1260+- `CE.catch` (handler1 loc s)
1261+- case mfTrace s' of
1263+- trace -> return(r, s'{mfTrace= loc:trace})
1268+- handler1 loc s (e :: SomeException)= do
1269+- case CE.fromException e :: Maybe WFErrors of
1270+- Just e -> CE.throw e -- !> ("TROWNF=" ++ show e)
1272+- case CE.fromException e :: Maybe AsyncException of
1273+- Just e -> CE.throw e -- !> ("TROWN ASYNCF=" ++ show e)
1275+- return (GoBack, s{mfTrace= [show e]})
1278+---instance (Serialize a,Typeable a, FormInput v) => MonadLoc (FlowM v (Workflow IO)) a where
1279+--- withLoc loc f = FlowM . Sup $
1280+--- withLoc loc $ do
1282+--- (r,s') <- lift . WF.step $ exec1d "jkkjk" ( runStateT (runSup $ runFlowM f) s) `CMT.catch` (handler1 loc s)
1287+--- handler1 loc s (e :: SomeException)=
1288+--- return (GoBack, s{mfTrace= Just ["exception: " ++show e]})
1290+-instance FormInput v => MonadLoc (View v IO) where
1291+- withLoc loc f = View $ do
1294+- (r,s') <- lift $ do
1295+- rs@(r,s') <- runStateT (runView f) s
1296+- `CE.catch` (handler1 loc s)
1297+- case mfTrace s' of
1299+- trace -> return(r, s'{mfTrace= loc:trace})
1304+- handler1 loc s (e :: SomeException)= do
1305+- case CE.fromException e :: Maybe WFErrors of
1306+- Just e -> CE.throw e -- !> ("TROWN=" ++ show e)
1308+- case CE.fromException e :: Maybe AsyncException of
1309+- Just e -> CE.throw e -- !> ("TROWN ASYNC=" ++ show e)
1311+- return (FormElm mempty Nothing, s{mfTrace= [show e]}) -- !> loc
1319+-instance Functor (FormElm view ) where
1320+- fmap f (FormElm form x)= FormElm form (fmap f x)
1322+-instance (Monad m,Functor m) => Functor (View view m) where
1323+- fmap f x= View $ fmap (fmap f) $ runView x
1326+-instance (Monoid view,Functor m, Monad m) => Applicative (View view m) where
1327+- pure a = View . return . FormElm mempty $ Just a
1328+- View f <*> View g= View $
1329+- f >>= \(FormElm form1 k) ->
1330+- g >>= \(FormElm form2 x) ->
1331+- return $ FormElm (form1 `mappend` form2) (k <*> x)
1333+-instance (FormInput view,Functor m, Monad m) => Alternative (View view m) where
1334+- empty= View $ return $ FormElm mempty Nothing
1340++instance MonadLoc (FlowM v IO) where
1341++ withLoc loc f = FlowM . Sup $ do
1344++ (r,s') <- lift $ do
1345++ rs@(r,s') <- runStateT (runSup (runFlowM f) ) s
1346++ `CE.catch` (handler1 loc s)
1347++ case mfTrace s' of
1349++ trace -> return(r, s'{mfTrace= loc:trace})
1354++ handler1 loc s (e :: SomeException)= do
1355++ case CE.fromException e :: Maybe WFErrors of
1356++ Just e -> CE.throw e -- !> ("TROWNF=" ++ show e)
1358++ case CE.fromException e :: Maybe AsyncException of
1359++ Just e -> CE.throw e -- !> ("TROWN ASYNCF=" ++ show e)
1361++ return (GoBack, s{mfTrace= [show e]})
1364++--instance (Serialize a,Typeable a, FormInput v) => MonadLoc (FlowM v (Workflow IO)) a where
1365++-- withLoc loc f = FlowM . Sup $
1366++-- withLoc loc $ do
1368++-- (r,s') <- lift . WF.step $ exec1d "jkkjk" ( runStateT (runSup $ runFlowM f) s) `CMT.catch` (handler1 loc s)
1373++-- handler1 loc s (e :: SomeException)=
1374++-- return (GoBack, s{mfTrace= Just ["exception: " ++show e]})
1376++instance FormInput v => MonadLoc (View v IO) where
1377++ withLoc loc f = View $ do
1380++ (r,s') <- lift $ do
1381++ rs@(r,s') <- runStateT (runView f) s
1382++ `CE.catch` (handler1 loc s)
1383++ case mfTrace s' of
1385++ trace -> return(r, s'{mfTrace= loc:trace})
1390++ handler1 loc s (e :: SomeException)= do
1391++ case CE.fromException e :: Maybe WFErrors of
1392++ Just e -> CE.throw e -- !> ("TROWN=" ++ show e)
1394++ case CE.fromException e :: Maybe AsyncException of
1395++ Just e -> CE.throw e -- !> ("TROWN ASYNC=" ++ show e)
1397++ return (FormElm mempty Nothing, s{mfTrace= [show e]}) -- !> loc
1405++instance Functor (FormElm view ) where
1406++ fmap f (FormElm form x)= FormElm form (fmap f x)
1408++instance (Monad m,Functor m) => Functor (View view m) where
1409++ fmap f x= View $ fmap (fmap f) $ runView x
1412++instance (Monoid view,Functor m, Monad m) => Applicative (View view m) where
1413++ pure a = View . return . FormElm mempty $ Just a
1414++ View f <*> View g= View $
1415++ f >>= \(FormElm form1 k) ->
1416++ g >>= \(FormElm form2 x) ->
1417++ return $ FormElm (form1 `mappend` form2) (k <*> x)
1419++instance (FormInput view,Functor m, Monad m) => Alternative (View view m) where
1420++ empty= View $ return $ FormElm mempty Nothing
1421+ View f <|> View g= View $ do
1422+- path <- gets mfPagePath
1423++ path <- gets mfPagePath
1424+ FormElm form1 k <- f
1426+ let path1 = mfPagePath s1
1427+- put s1{mfPagePath=path}
1428++ put s1{mfPagePath=path}
1429+ FormElm form2 x <- g
1431+ (mix,hasform) <- controlForms s1 s2 form1 form2
1432+@@ -317,259 +349,259 @@
1433+ (_,Just _) -> path2
1435+ if hasform then put s2{needForm= HasForm,mfPagePath= path3}
1436+- else put s2{mfPagePath=path3}
1437+- return $ FormElm mix (k <|> x)
1440+-instance (FormInput view, Monad m) => Monad (View view m) where
1441+- View x >>= f = View $ do
1442+- FormElm form1 mk <- x
1445++ else put s2{mfPagePath=path3}
1446++ return $ FormElm mix (k <|> x)
1449++instance (FormInput view, Monad m) => Monad (View view m) where
1450++ View x >>= f = View $ do
1451++ FormElm form1 mk <- x
1455+ let st = st''{ linkMatched = False }
1458+ FormElm form2 mk <- runView $ f k
1460+ (mix, hasform) <- controlForms st st' form1 form2
1461+ when hasform $ put st'{needForm= HasForm}
1463+- return $ FormElm mix mk
1465+- return $ FormElm form1 Nothing
1469+- return = View . return . FormElm mempty . Just
1470+--- fail msg= View . return $ FormElm [inRed msg] Nothing
1475+-instance (FormInput v,Monad m, Functor m, Monoid a) => Monoid (View v m a) where
1476+- mappend x y = mappend <$> x <*> y -- beware that both operands must validate to generate a sum
1477+- mempty= return mempty
1480+--- | It is a callback in the view monad. The callback rendering substitutes the widget rendering
1481+--- when the latter is validated, without afecting the rendering of other widgets. This allow
1482+--- the simultaneous execution of different behaviours in different widgets in the
1483+--- same page. The inspiration is the callback primitive in the Seaside Web Framework
1484+--- that allows similar functionality (See <http://www.seaside.st>)
1486+--- This is the visible difference with 'waction' callbacks, which execute a
1487+--- a flow in the FlowM monad that takes complete control of the navigation, while wactions are
1488+--- executed whithin the same page.
1491+- View view m a -> (a -> View view m b) -> View view m b
1492+-wcallback (View x) f = View $ do
1493+- FormElm form1 mk <- x
1496+- modify $ \st -> st{linkMatched= False, needForm=NoElems}
1498++ return $ FormElm mix mk
1500++ return $ FormElm form1 Nothing
1504++ return = View . return . FormElm mempty . Just
1505++-- fail msg= View . return $ FormElm [inRed msg] Nothing
1510++instance (FormInput v,Monad m, Functor m, Monoid a) => Monoid (View v m a) where
1511++ mappend x y = mappend <$> x <*> y -- beware that both operands must validate to generate a sum
1512++ mempty= return mempty
1515++-- | It is a callback in the view monad. The callback rendering substitutes the widget rendering
1516++-- when the latter is validated, without afecting the rendering of other widgets. This allow
1517++-- the simultaneous execution of different behaviours in different widgets in the
1518++-- same page. The inspiration is the callback primitive in the Seaside Web Framework
1519++-- that allows similar functionality (See <http://www.seaside.st>)
1521++-- This is the visible difference with 'waction' callbacks, which execute a
1522++-- a flow in the FlowM monad that takes complete control of the navigation, while wactions are
1523++-- executed whithin the same page.
1526++ View view m a -> (a -> View view m b) -> View view m b
1527++wcallback (View x) f = View $ do
1528++ FormElm form1 mk <- x
1531++ modify $ \st -> st{linkMatched= False, needForm=NoElems}
1534+- Nothing -> return $ FormElm form1 Nothing
1541+-instance Monoid view => MonadTrans (View view) where
1542+- lift f = View $ (lift f) >>= \x -> return $ FormElm mempty $ Just x
1544+-instance MonadTrans (FlowM view) where
1545+- lift f = FlowM $ lift (lift f) -- >>= \x -> return x
1547+-instance (FormInput view, Monad m)=> MonadState (MFlowState view) (View view m) where
1548+- get = View $ get >>= \x -> return $ FormElm mempty $ Just x
1549+- put st = View $ put st >>= \x -> return $ FormElm mempty $ Just x
1551+---instance (Monad m)=> MonadState (MFlowState view) (FlowM view m) where
1552+--- get = FlowM $ get >>= \x -> return $ FormElm [] $ Just x
1553+--- put st = FlowM $ put st >>= \x -> return $ FormElm [] $ Just x
1556+-instance (FormInput view,MonadIO m) => MonadIO (View view m) where
1557+- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO on the Identity monad
1559+--- | Execute the widget in a monad and return the result in another.
1560+-changeMonad :: (Monad m, Executable m1)
1561+- => View v m1 a -> View v m a
1562+-changeMonad w= View . StateT $ \s ->
1563+- let (r,s')= execute $ runStateT ( runView w) s
1564+- in mfSequence s' `seq` return (r,s')
1566++ Nothing -> return $ FormElm form1 Nothing
1573++instance Monoid view => MonadTrans (View view) where
1574++ lift f = View $ (lift f) >>= \x -> return $ FormElm mempty $ Just x
1576++instance MonadTrans (FlowM view) where
1577++ lift f = FlowM $ lift (lift f) -- >>= \x -> return x
1579++instance (FormInput view, Monad m)=> MonadState (MFlowState view) (View view m) where
1580++ get = View $ get >>= \x -> return $ FormElm mempty $ Just x
1581++ put st = View $ put st >>= \x -> return $ FormElm mempty $ Just x
1583++--instance (Monad m)=> MonadState (MFlowState view) (FlowM view m) where
1584++-- get = FlowM $ get >>= \x -> return $ FormElm [] $ Just x
1585++-- put st = FlowM $ put st >>= \x -> return $ FormElm [] $ Just x
1588++instance (FormInput view,MonadIO m) => MonadIO (View view m) where
1589++ liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO on the Identity monad
1591++-- | Execute the widget in a monad and return the result in another.
1592++changeMonad :: (Monad m, Executable m1)
1593++ => View v m1 a -> View v m a
1594++changeMonad w= View . StateT $ \s ->
1595++ let (r,s')= execute $ runStateT ( runView w) s
1596++ in mfSequence s' `seq` return (r,s')
1600+ ----- some combinators ----
1602+--- | Join two widgets in the same page
1603+--- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results
1604+--- if both return Noting, the widget return @Nothing@ (invalid).
1606+--- it has a low infix priority: @infixr 2@
1608+--- > r <- ask widget1 <+> widget2
1609+--- > case r of (Just x, Nothing) -> ..
1610+-(<+>) , mix :: (Monad m, FormInput view)
1613+- -> View view m (Maybe a, Maybe b)
1614+-mix digest1 digest2= View $ do
1616++-- | Join two widgets in the same page
1617++-- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results
1618++-- if both return Noting, the widget return @Nothing@ (invalid).
1620++-- it has a low infix priority: @infixr 2@
1622++-- > r <- ask widget1 <+> widget2
1623++-- > case r of (Just x, Nothing) -> ..
1624++(<+>) , mix :: (Monad m, FormInput view)
1627++ -> View view m (Maybe a, Maybe b)
1628++mix digest1 digest2= View $ do
1629+ FormElm f1 mx' <- runView digest1
1632+ FormElm f2 my' <- runView digest2
1634+ (mix, hasform) <- controlForms s1 s2 f1 f2
1635+- when hasform $ put s2{needForm= HasForm}
1636+- return $ FormElm mix
1637+- $ case (mx',my') of
1638+- (Nothing, Nothing) -> Nothing
1639+- other -> Just other
1647+--- | The first elem result (even if it is not validated) is discarded, and the secod is returned
1648+--- . This contrast with the applicative operator '*>' which fails the whole validation if
1649+--- the validation of the first elem fails.
1651+--- The first element is displayed however, as happens in the case of '*>' .
1653+--- Here @w\'s@ are widgets and @r\'s@ are returned values
1655+--- @(w1 <* w2)@ will return @Just r1@ only if w1 and w2 are validated
1657+--- @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated
1659+--- it has a low infix priority: @infixr 1@
1661+-(**>) :: (Functor m, Monad m, FormInput view)
1662+- => View view m a -> View view m b -> View view m b
1663++ when hasform $ put s2{needForm= HasForm}
1664++ return $ FormElm mix
1665++ $ case (mx',my') of
1666++ (Nothing, Nothing) -> Nothing
1667++ other -> Just other
1675++-- | The first elem result (even if it is not validated) is discarded, and the secod is returned
1676++-- . This contrast with the applicative operator '*>' which fails the whole validation if
1677++-- the validation of the first elem fails.
1679++-- The first element is displayed however, as happens in the case of '*>' .
1681++-- Here @w\'s@ are widgets and @r\'s@ are returned values
1683++-- @(w1 <* w2)@ will return @Just r1@ only if w1 and w2 are validated
1685++-- @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated
1687++-- it has a low infix priority: @infixr 1@
1689++(**>) :: (Functor m, Monad m, FormInput view)
1690++ => View view m a -> View view m b -> View view m b
1691+ --(**>) form1 form2 = valid form1 *> form2
1692+ (**>) f g = View $ do
1693+ FormElm form1 k <- runView $ valid f
1696+ FormElm form2 x <- runView g
1698+ (mix,hasform) <- controlForms s1 s2 form1 form2
1699+- when hasform $ put s2{needForm= HasForm}
1700+- return $ FormElm mix (k *> x)
1704+-valid form= View $ do
1705+- FormElm form mx <- runView form
1706+- return $ FormElm form $ Just undefined
1710+--- | The second elem result (even if it is not validated) is discarded, and the first is returned
1711+--- . This contrast with the applicative operator '*>' which fails the whole validation if
1712+--- the validation of the second elem fails.
1713+--- The second element is displayed however, as in the case of '<*'.
1714+--- see the `<**` examples
1716+--- it has a low infix priority: @infixr 1@
1717+-(<**) :: (Functor m, Monad m, FormInput view) =>
1718+- View view m a -> View view m b -> View view m a
1719+--- (<**) form1 form2 = form1 <* valid form2
1720++ when hasform $ put s2{needForm= HasForm}
1721++ return $ FormElm mix (k *> x)
1725++valid form= View $ do
1726++ FormElm form mx <- runView form
1727++ return $ FormElm form $ Just undefined
1731++-- | The second elem result (even if it is not validated) is discarded, and the first is returned
1732++-- . This contrast with the applicative operator '*>' which fails the whole validation if
1733++-- the validation of the second elem fails.
1734++-- The second element is displayed however, as in the case of '<*'.
1735++-- see the `<**` examples
1737++-- it has a low infix priority: @infixr 1@
1738++(<**) :: (Functor m, Monad m, FormInput view) =>
1739++ View view m a -> View view m b -> View view m a
1740++-- (<**) form1 form2 = form1 <* valid form2
1741+ (<**) f g = View $ do
1742+ FormElm form1 k <- runView f
1745+ FormElm form2 x <- runView $ valid g
1747+ (mix,hasform) <- controlForms s1 s2 form1 form2
1748+- when hasform $ put s2{needForm= HasForm}
1749+- return $ FormElm mix (k <* x)
1751++ when hasform $ put s2{needForm= HasForm}
1752++ return $ FormElm mix (k <* x)
1756+ -------- Flow control
1758+--- | True if the flow is going back (as a result of the back button pressed in the web browser).
1759+--- Usually this check is nos necessary unless conditional code make it necessary
1762+--- mop <- getGoStraighTo
1764+--- Just goop -> goop
1766+--- r \<- `ask` option1 \<|> option2
1768+--- op1 -> setGoStraighTo (Just goop1) >> goop1
1769+--- op2 -> setGoStraighTo (Just goop2) >> goop2@
1771+--- This pseudocode below would execute the ask of the menu once. But the user will never have
1772+--- the possibility to see the menu again. To let him choose other option, the code
1773+--- has to be change to
1776+--- mop <- getGoStraighTo
1777+--- back <- `goingBack`
1778+--- case (mop,back) of
1779+--- (Just goop,False) -> goop
1781+--- r \<- `ask` option1 \<|> option2
1783+--- op1 -> setGoStraighTo (Just goop1) >> goop1
1784+--- op2 -> setGoStraighTo (Just goop2) >> goop2@
1786+--- However this is very specialized. Normally the back button detection is not necessary.
1787+--- In a persistent flow (with step) even this default entry option would be completely automatic,
1788+--- since the process would restart at the last page visited.
1789+-goingBack :: MonadState (MFlowState view) m => m Bool
1792+- return $ not (inSync st) && not (newAsk st)
1794+--- | Will prevent the Suprack beyond the point where 'preventGoingBack' is located.
1795+--- If the user press the back button beyond that point, the flow parameter is executed, usually
1796+--- it is an ask statement with a message. If the flow is not going back, it does nothing. It is a cut in Supracking
1798+--- It is useful when an undoable transaction has been commited. For example, after a payment.
1800+--- This example show a message when the user go back and press again to pay
1802+--- > ask $ wlink () << b << "press here to pay 100000 $ "
1804+--- > preventGoingBack . ask $ b << "You paid 10000 $ one time"
1805+--- > ++> wlink () << b << " Please press here to complete the proccess"
1806+--- > ask $ wlink () << b << "OK, press here to go to the menu or press the back button to verify that you can not pay again"
1808+--- > payIt= liftIO $ print "paying"
1811+- :: ( Functor m, MonadIO m, FormInput v) => FlowM v m () -> FlowM v m ()
1812+-preventGoingBack msg= do
1814+- if not back then breturn() else do
1815+- breturn() -- will not go back beyond this
1817+- modify $ \s -> s{newAsk= True}
1821+--- | executes the first computation when going forward and the second computation when backtracking.
1822+--- Depending on how the second computation finishes, the flow will resume forward or backward.
1823+-onBacktrack :: Monad m => m a -> FlowM v m a -> FlowM v m a
1824+-onBacktrack doit onback= do
1827+- False -> (lift doit) >>= breturn
1830+--- | less powerflul version of `onBacktrack`: The second computation simply undo the effect of
1831+--- the first one, and the flow continues backward ever. It can be used as a rollback mechanism in
1832+--- the context of long running transactions.
1833+-compensate :: Monad m => m a -> m a -> FlowM v m a
1834+-compensate doit undoit= doit `onBacktrack` ( (lift undoit) >> fail "")
1836++-- | True if the flow is going back (as a result of the back button pressed in the web browser).
1837++-- Usually this check is nos necessary unless conditional code make it necessary
1840++-- mop <- getGoStraighTo
1842++-- Just goop -> goop
1844++-- r \<- `ask` option1 \<|> option2
1846++-- op1 -> setGoStraighTo (Just goop1) >> goop1
1847++-- op2 -> setGoStraighTo (Just goop2) >> goop2@
1849++-- This pseudocode below would execute the ask of the menu once. But the user will never have
1850++-- the possibility to see the menu again. To let him choose other option, the code
1851++-- has to be change to
1854++-- mop <- getGoStraighTo
1855++-- back <- `goingBack`
1856++-- case (mop,back) of
1857++-- (Just goop,False) -> goop
1859++-- r \<- `ask` option1 \<|> option2
1861++-- op1 -> setGoStraighTo (Just goop1) >> goop1
1862++-- op2 -> setGoStraighTo (Just goop2) >> goop2@
1864++-- However this is very specialized. Normally the back button detection is not necessary.
1865++-- In a persistent flow (with step) even this default entry option would be completely automatic,
1866++-- since the process would restart at the last page visited.
1867++goingBack :: MonadState (MFlowState view) m => m Bool
1870++ return $ not (inSync st) && not (newAsk st)
1872++-- | Will prevent the Suprack beyond the point where 'preventGoingBack' is located.
1873++-- If the user press the back button beyond that point, the flow parameter is executed, usually
1874++-- it is an ask statement with a message. If the flow is not going back, it does nothing. It is a cut in Supracking
1876++-- It is useful when an undoable transaction has been commited. For example, after a payment.
1878++-- This example show a message when the user go back and press again to pay
1880++-- > ask $ wlink () << b << "press here to pay 100000 $ "
1882++-- > preventGoingBack . ask $ b << "You paid 10000 $ one time"
1883++-- > ++> wlink () << b << " Please press here to complete the proccess"
1884++-- > ask $ wlink () << b << "OK, press here to go to the menu or press the back button to verify that you can not pay again"
1886++-- > payIt= liftIO $ print "paying"
1889++ :: ( Functor m, MonadIO m, FormInput v) => FlowM v m () -> FlowM v m ()
1890++preventGoingBack msg= do
1892++ if not back then breturn() else do
1893++ breturn() -- will not go back beyond this
1895++ modify $ \s -> s{newAsk= True}
1899++-- | executes the first computation when going forward and the second computation when backtracking.
1900++-- Depending on how the second computation finishes, the flow will resume forward or backward.
1901++onBacktrack :: Monad m => m a -> FlowM v m a -> FlowM v m a
1902++onBacktrack doit onback= do
1905++ False -> (lift doit) >>= breturn
1908++-- | less powerflul version of `onBacktrack`: The second computation simply undo the effect of
1909++-- the first one, and the flow continues backward ever. It can be used as a rollback mechanism in
1910++-- the context of long running transactions.
1911++compensate :: Monad m => m a -> m a -> FlowM v m a
1912++compensate doit undoit= doit `onBacktrack` ( (lift undoit) >> fail "")
1915+ --orElse :: FormInput v => FlowM v IO a -> FlowM v IO a -> FlowM v IO a
1916+@@ -595,91 +627,96 @@
1918+ -- Nothing -> retry
1919+ -- Just v -> return v
1924+-needForm1 st= case needForm st of
1929+-data NeedForm= HasForm | HasElems | NoElems deriving Show
1931+-data MFlowState view= MFlowState{
1932+- mfSequence :: Int,
1938+- needForm :: NeedForm,
1940+- mfkillTime :: Int,
1941+- mfSessionTime :: Integer,
1942+- mfCookies :: [Cookie],
1943+- mfHttpHeaders :: [(SB.ByteString,SB.ByteString)],
1944+- mfHeader :: view -> view,
1946+- mfRequirements :: [Requirement],
1947+- mfData :: M.Map TypeRep Void,
1948+- mfAjax :: Maybe (M.Map String Void),
1949+- mfSeqCache :: Int,
1950+- notSyncInAction :: Bool,
1952+- -- Link management
1953++--needForm1 st= case needForm st of
1954++-- HasForm -> False
1955++-- HasElems _ -> True
1956++-- NoElems -> False
1960++data NeedForm= HasForm | HasElems | NoElems deriving Show
1962++data MFlowState view= MFlowState{
1963++ mfSequence :: Int,
1969++ needForm :: NeedForm,
1970++ mfFileUpload :: Bool,
1972++ mfkillTime :: Int,
1973++ mfSessionTime :: Integer,
1974++ mfCookies :: [Cookie],
1975++ mfHttpHeaders :: [(SB.ByteString,SB.ByteString)],
1976++ mfHeader :: view -> view,
1978++ mfRequirements :: [Requirement],
1979++ mfInstalledScripts :: [WebRequirement],
1980++ mfData :: M.Map TypeRep Void,
1981++ mfAjax :: Maybe (M.Map String Void),
1982++ mfSeqCache :: Int,
1983++ notSyncInAction :: Bool,
1985++ -- Link management
1986+ mfPath :: [String],
1987+- mfPagePath :: [String],
1988+- mfPrefix :: String,
1989+--- mfPIndex :: Int,
1990+- mfPageFlow :: Bool,
1991++ mfPagePath :: [String],
1992++ mfPrefix :: String,
1993++-- mfPIndex :: Int,
1994++ mfPageFlow :: Bool,
1995+ linkMatched :: Bool,
1996+--- mfPendingPath :: [String],
1999+- mfAutorefresh :: Bool,
2000+- mfTrace :: [String],
2007+-mFlowState0 :: (FormInput view) => MFlowState view
2008+-mFlowState0 = MFlowState 0 False True True "en"
2009+- [] NoElems (error "token of mFlowState0 used")
2010+- 0 0 [] [] stdHeader False [] M.empty Nothing 0 False [] [] "" False False False [] False
2013+--- | Set user-defined data in the context of the session.
2015+--- The data is indexed by type in a map. So the user can insert-retrieve different kinds of data
2016+--- in the session context.
2018+--- This example define @addHistory@ and @getHistory@ to maintain a Html log in the session of a Flow:
2020+--- > newtype History = History ( Html) deriving Typeable
2021+--- > setHistory html= setSessionData $ History html
2022+--- > getHistory= getSessionData `onNothing` return (History mempty) >>= \(History h) -> return h
2023+--- > addHistory html= do
2024+--- > html' <- getHistory
2025+--- > setHistory $ html' `mappend` html
2027+-setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a -> m ()
2029+- modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)}
2032+- modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
2034+--- | Get the session data of the desired type if there is any.
2035+-getSessionData :: (Typeable a, MonadState (MFlowState view) m) => m (Maybe a)
2036+-getSessionData = resp where
2037+- resp= gets mfData >>= \list ->
2038+- case M.lookup ( typeOf $ typeResp resp ) list of
2039+- Just x -> return . Just $ unsafeCoerce x
2040+- Nothing -> return $ Nothing
2041+- typeResp :: m (Maybe x) -> x
2042+- typeResp= undefined
2043++-- mfPendingPath :: [String],
2046++ mfAutorefresh :: Bool,
2047++ mfTrace :: [String],
2054++mFlowState0 :: (FormInput view) => MFlowState view
2055++mFlowState0 = MFlowState 0 False True True "en"
2056++ [] NoElems False (error "token of mFlowState0 used")
2057++ 0 0 [] [] stdHeader False [] [] M.empty Nothing 0 False
2058++ [] [] "" False False False [] False
2061++-- | Set user-defined data in the context of the session.
2063++-- The data is indexed by type in a map. So the user can insert-retrieve different kinds of data
2064++-- in the session context.
2066++-- This example define @addHistory@ and @getHistory@ to maintain a Html log in the session of a Flow:
2068++-- > newtype History = History ( Html) deriving Typeable
2069++-- > setHistory html= setSessionData $ History html
2070++-- > getHistory= getSessionData `onNothing` return (History mempty) >>= \(History h) -> return h
2071++-- > addHistory html= do
2072++-- > html' <- getHistory
2073++-- > setHistory $ html' `mappend` html
2075++setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a -> m ()
2077++ modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)}
2080++ modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
2082++-- | Get the session data of the desired type if there is any.
2083++getSessionData :: (Typeable a, MonadState (MFlowState view) m) => m (Maybe a)
2084++getSessionData = resp where
2085++ resp= gets mfData >>= \list ->
2086++ case M.lookup ( typeOf $ typeResp resp ) list of
2087++ Just x -> return . Just $ unsafeCoerce x
2088++ Nothing -> return $ Nothing
2089++ typeResp :: m (Maybe x) -> x
2090++ typeResp= undefined
2092+ -- | getSessionData specialized for the View monad. if Nothing, the monadic computation
2093+ -- does not continue.
2094+@@ -691,554 +728,555 @@
2095+ -- | Return the session identifier
2096+ getSessionId :: MonadState (MFlowState v) m => m String
2097+ getSessionId= gets mfToken >>= return . key
2099+--- | Return the user language. Now it is fixed to "en"
2100+-getLang :: MonadState (MFlowState view) m => m String
2101+-getLang= gets mfLang
2103+-getToken :: MonadState (MFlowState view) m => m Token
2104+-getToken= gets mfToken
2107+--- get a parameter form the las received response
2108+-getEnv :: MonadState (MFlowState view) m => m Params
2109+-getEnv = gets mfEnv
2114+--- | Set the header-footer that will enclose the widgets. It must be provided in the
2115+--- same formatting than them, altrough with normalization to byteStrings any formatting can be used
2117+--- This header uses XML trough Haskell Server Pages (<http://hackage.haskell.org/package/hsp>)
2120+--- setHeader $ \c ->
2123+--- \<title\> my title \</title\>
2124+--- \<meta name= \"Keywords\" content= \"sci-fi\" /\>)
2126+--- \<body style= \"margin-left:5%;margin-right:5%\"\>
2132+--- This header uses "Text.XHtml"
2135+--- setHeader $ \c ->
2138+--- << (`thetitle` << title +++
2139+--- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++
2140+--- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c
2143+--- This header uses both. It uses byteString tags
2146+--- setHeader $ \c ->
2148+--- `btag` "head" [] $
2149+--- (`toByteString` (thetitle << title) `append`
2150+--- `toByteString` <meta name= \"Keywords\" content= \"sci-fi\" />) `append`
2151+--- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c
2154+-setHeader :: MonadState (MFlowState view) m => (view -> view) -> m ()
2155+-setHeader header= do
2157+- put fs{mfHeader= header}
2161+--- | Return the current header
2162+-getHeader :: ( Monad m) => FlowM view m (view -> view)
2163+-getHeader= gets mfHeader
2165+--- | Add another header embedded in the previous one
2167+- fhtml <- getHeader
2168+- setHeader $ fhtml . new
2170+--- | Set an HTTP cookie
2171+-setCookie :: MonadState (MFlowState view) m
2172+- => String -- ^ name
2173+- -> String -- ^ value
2174+- -> String -- ^ path
2175+- -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie
2177+-setCookie n v p me=
2178+- modify $ \st -> st{mfCookies= (UnEncryptedCookie
2179+- ( SB.fromString n,
2182+- fmap (SB.fromString . show) me)):mfCookies st }
2184+-setParanoidCookie :: MonadState (MFlowState view) m
2185+- => String -- ^ name
2186+- -> String -- ^ value
2187+- -> String -- ^ path
2189++-- | Return the user language. Now it is fixed to "en"
2190++getLang :: MonadState (MFlowState view) m => m String
2191++getLang= gets mfLang
2193++getToken :: MonadState (MFlowState view) m => m Token
2194++getToken= gets mfToken
2197++-- get a parameter form the las received response
2198++getEnv :: MonadState (MFlowState view) m => m Params
2199++getEnv = gets mfEnv
2204++-- | Set the header-footer that will enclose the widgets. It must be provided in the
2205++-- same formatting than them, altrough with normalization to byteStrings any formatting can be used
2207++-- This header uses XML trough Haskell Server Pages (<http://hackage.haskell.org/package/hsp>)
2210++-- setHeader $ \c ->
2213++-- \<title\> my title \</title\>
2214++-- \<meta name= \"Keywords\" content= \"sci-fi\" /\>)
2216++-- \<body style= \"margin-left:5%;margin-right:5%\"\>
2222++-- This header uses "Text.XHtml"
2225++-- setHeader $ \c ->
2228++-- << (`thetitle` << title +++
2229++-- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++
2230++-- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c
2233++-- This header uses both. It uses byteString tags
2236++-- setHeader $ \c ->
2238++-- `btag` "head" [] $
2239++-- (`toByteString` (thetitle << title) `append`
2240++-- `toByteString` <meta name= \"Keywords\" content= \"sci-fi\" />) `append`
2241++-- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c
2244++setHeader :: MonadState (MFlowState view) m => (view -> view) -> m ()
2245++setHeader header= do
2247++ put fs{mfHeader= header}
2251++-- | Return the current header
2252++getHeader :: ( Monad m) => FlowM view m (view -> view)
2253++getHeader= gets mfHeader
2255++-- | Add another header embedded in the previous one
2257++ fhtml <- getHeader
2258++ setHeader $ fhtml . new
2260++-- | Set an HTTP cookie
2261++setCookie :: MonadState (MFlowState view) m
2262++ => String -- ^ name
2263++ -> String -- ^ value
2264++ -> String -- ^ path
2265++ -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie
2267++setCookie n v p me=
2268++ modify $ \st -> st{mfCookies= (UnEncryptedCookie
2269++ ( SB.fromString n,
2272++ fmap (SB.fromString . show) me)):mfCookies st }
2274++setParanoidCookie :: MonadState (MFlowState view) m
2275++ => String -- ^ name
2276++ -> String -- ^ value
2277++ -> String -- ^ path
2278+ -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie
2280+-setParanoidCookie n v p me = setEncryptedCookie' n v p me paranoidEncryptCookie
2282++setParanoidCookie n v p me = setEncryptedCookie' n v p me paranoidEncryptCookie
2284+-setEncryptedCookie :: MonadState (MFlowState view) m
2285+- => String -- ^ name
2286+- -> String -- ^ value
2287+- -> String -- ^ path
2288++setEncryptedCookie :: MonadState (MFlowState view) m
2289++ => String -- ^ name
2290++ -> String -- ^ value
2291++ -> String -- ^ path
2292+ -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie
2294+-setEncryptedCookie n v p me = setEncryptedCookie' n v p me encryptCookie
2296+-setEncryptedCookie' n v p me encFunc=
2297+- modify $ \st -> st{mfCookies =
2298+- (unsafePerformIO $ encFunc
2299+- ( SB.fromString n,
2302+- fmap (SB.fromString . show) me)):mfCookies st }
2304+--- | Set an HTTP Response header
2305+-setHttpHeader :: MonadState (MFlowState view) m
2306+- => SB.ByteString -- ^ name
2307+- -> SB.ByteString -- ^ value
2309+-setHttpHeader n v =
2310+- modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (n,v):mfHttpHeaders st}
2314+--- 1) the timeout of the flow execution since the last user interaction.
2315+--- Once passed, the flow executes from the begining.
2317+--- 2) In persistent flows
2318+--- it set the session state timeout for the flow, that is persistent. If the
2319+--- flow is not persistent, it has no effect.
2321+--- As the other state primitives, it can be run in the Flow and in the View monad
2323+--- `transient` flows restart anew.
2324+--- persistent flows (that use `step`) restart at the las saved execution point, unless
2325+--- the session time has expired for the user.
2326+-setTimeouts :: ( MonadState (MFlowState v) m) => Int -> Integer -> m ()
2327+-setTimeouts kt st= do
2329+- put fs{ mfkillTime= kt, mfSessionTime= st}
2332+-getWFName :: MonadState (MFlowState view) m => m String
2335+- return . twfname $ mfToken fs
2337+-getCurrentUser :: MonadState (MFlowState view) m => m String
2338+-getCurrentUser = do
2346+-type OnClick= Maybe String
2348+-normalize :: (Monad m, FormInput v) => View v m a -> View B.ByteString m a
2349+-normalize f= View . StateT $ \s ->do
2350+- (FormElm fs mx, s') <- runStateT ( runView f) $ unsafeCoerce s
2351+- return (FormElm (toByteString fs ) mx,unsafeCoerce s')
2355+--- | Minimal interface for defining the basic form and link elements. The core of MFlow is agnostic
2356+--- about the rendering package used. Every formatting (either HTML or not) used with MFlow must have an
2357+--- instance of this class.
2358+--- See "MFlow.Forms.Blaze.Html for the instance for blaze-html" "MFlow.Forms.XHtml" for the instance
2359+--- for @Text.XHtml@ and MFlow.Forms.HSP for the instance for Haskell Server Pages.
2360+-class (Monoid view,Typeable view) => FormInput view where
2361+- toByteString :: view -> B.ByteString
2362+- toHttpData :: view -> HttpData
2363+- fromStr :: String -> view
2364+- fromStrNoEncode :: String -> view
2365+- ftag :: String -> view -> view
2366+- inred :: view -> view
2367+- flink :: String -> view -> view
2368+- flink1:: String -> view
2369+- flink1 verb = flink verb (fromStr verb)
2370+- finput :: Name -> Type -> Value -> Checked -> OnClick -> view
2371+- ftextarea :: String -> T.Text -> view
2372+- fselect :: String -> view -> view
2373+- foption :: String -> view -> Bool -> view
2374+- foption1 :: String -> Bool -> view
2375+- foption1 val msel= foption val (fromStr val) msel
2376+- formAction :: String -> view -> view
2377+- attrs :: view -> Attribs -> view
2381+---instance (MonadIO m) => MonadIO (FlowM view m) where
2382+--- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad
2384+---instance Executable (View v m) where
2385+--- execute f = execute $ evalStateT f mFlowState0
2388+---instance (Monad m, Executable m, Monoid view, FormInput view)
2389+--- => Executable (StateT (MFlowState view) m) where
2390+--- execute f= execute $ evalStateT f mFlowState0
2392+--- | Cached widgets operate with widgets in the Identity monad, but they may perform IO using the execute instance
2393+--- of the monad m, which is usually the IO monad. execute basically \"sanctifies\" the use of unsafePerformIO for a transient purpose
2394+--- such is caching. This is defined in "Data.TCache.Memoization". The programmer can create his
2395+--- own instance for his monad.
2397+--- With `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)
2398+---, permanently or for a certain time. this is very useful for complex widgets that present information. Specially it they must access to databases.
2401+--- import MFlow.Wai.Blaze.Html.All
2402+--- import Some.Time.Library
2403+--- addMessageFlows [(noscript, time)]
2404+--- main= run 80 waiMessageFlow
2405+--- time=do ask $ cachedWidget \"time\" 5
2406+--- $ wlink () b << \"the time is \" ++ show (execute giveTheTime) ++ \" click here\"
2410+--- this pseudocode would update the time every 5 seconds. The execution of the IO computation
2411+--- giveTheTime must be executed inside the cached widget to avoid unnecesary IO executions.
2413+--- NOTE: the rendering of cached widgets are shared by all users
2414+-cachedWidget :: (MonadIO m,Typeable view
2415+- , FormInput view, Typeable a, Executable m )
2416+- => String -- ^ The key of the cached object for the retrieval
2417+- -> Int -- ^ Timeout of the caching. Zero means the whole server run
2418+- -> View view Identity a -- ^ The cached widget, in the Identity monad
2419+- -> View view m a -- ^ The cached result
2420+-cachedWidget key t mf = View . StateT $ \s -> do
2421+- let((FormElm form _), sec)= execute $! cachedByKey key t $ proc mf s{mfCached=True}
2422+- let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True}
2423+- let s''= s{inSync = inSync s2
2424+- ,mfRequirements=mfRequirements s2
2426++setEncryptedCookie n v p me = setEncryptedCookie' n v p me encryptCookie
2428++setEncryptedCookie' n v p me encFunc=
2429++ modify $ \st -> st{mfCookies =
2430++ (unsafePerformIO $ encFunc
2431++ ( SB.fromString n,
2434++ fmap (SB.fromString . show) me)):mfCookies st }
2436++-- | Set an HTTP Response header
2437++setHttpHeader :: MonadState (MFlowState view) m
2438++ => SB.ByteString -- ^ name
2439++ -> SB.ByteString -- ^ value
2441++setHttpHeader n v =
2442++ modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (n,v):mfHttpHeaders st}
2446++-- 1) the timeout of the flow execution since the last user interaction.
2447++-- Once passed, the flow executes from the begining.
2449++-- 2) In persistent flows
2450++-- it set the session state timeout for the flow, that is persistent. If the
2451++-- flow is not persistent, it has no effect.
2453++-- As the other state primitives, it can be run in the Flow and in the View monad
2455++-- `transient` flows restart anew.
2456++-- persistent flows (that use `step`) restart at the las saved execution point, unless
2457++-- the session time has expired for the user.
2458++setTimeouts :: ( MonadState (MFlowState v) m) => Int -> Integer -> m ()
2459++setTimeouts kt st= do
2461++ put fs{ mfkillTime= kt, mfSessionTime= st}
2464++getWFName :: MonadState (MFlowState view) m => m String
2467++ return . twfname $ mfToken fs
2469++getCurrentUser :: MonadState (MFlowState view) m => m String
2470++getCurrentUser = do
2478++type OnClick= Maybe String
2480++normalize :: (Monad m, FormInput v) => View v m a -> View B.ByteString m a
2481++normalize f= View . StateT $ \s ->do
2482++ (FormElm fs mx, s') <- runStateT ( runView f) $ unsafeCoerce s
2483++ return (FormElm (toByteString fs ) mx,unsafeCoerce s')
2487++-- | Minimal interface for defining the basic form and link elements. The core of MFlow is agnostic
2488++-- about the rendering package used. Every formatting (either HTML or not) used with MFlow must have an
2489++-- instance of this class.
2490++-- See "MFlow.Forms.Blaze.Html for the instance for blaze-html" "MFlow.Forms.XHtml" for the instance
2491++-- for @Text.XHtml@ and MFlow.Forms.HSP for the instance for Haskell Server Pages.
2492++class (Monoid view,Typeable view) => FormInput view where
2493++ toByteString :: view -> B.ByteString
2494++ toHttpData :: view -> HttpData
2495++ fromStr :: String -> view
2496++ fromStrNoEncode :: String -> view
2497++ ftag :: String -> view -> view
2498++ inred :: view -> view
2499++ flink :: String -> view -> view
2500++ flink1:: String -> view
2501++ flink1 verb = flink verb (fromStr verb)
2502++ finput :: Name -> Type -> Value -> Checked -> OnClick -> view
2503++ ftextarea :: String -> T.Text -> view
2504++ fselect :: String -> view -> view
2505++ foption :: String -> view -> Bool -> view
2506++ foption1 :: String -> Bool -> view
2507++ foption1 val msel= foption val (fromStr val) msel
2508++ formAction :: String -> String -> view -> view
2509++ attrs :: view -> Attribs -> view
2513++--instance (MonadIO m) => MonadIO (FlowM view m) where
2514++-- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad
2516++--instance Executable (View v m) where
2517++-- execute f = execute $ evalStateT f mFlowState0
2520++--instance (Monad m, Executable m, Monoid view, FormInput view)
2521++-- => Executable (StateT (MFlowState view) m) where
2522++-- execute f= execute $ evalStateT f mFlowState0
2524++-- | Cached widgets operate with widgets in the Identity monad, but they may perform IO using the execute instance
2525++-- of the monad m, which is usually the IO monad. execute basically \"sanctifies\" the use of unsafePerformIO for a transient purpose
2526++-- such is caching. This is defined in "Data.TCache.Memoization". The programmer can create his
2527++-- own instance for his monad.
2529++-- With `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)
2530++--, permanently or for a certain time. this is very useful for complex widgets that present information. Specially it they must access to databases.
2533++-- import MFlow.Wai.Blaze.Html.All
2534++-- import Some.Time.Library
2535++-- addMessageFlows [(noscript, time)]
2536++-- main= run 80 waiMessageFlow
2537++-- time=do ask $ cachedWidget \"time\" 5
2538++-- $ wlink () b << \"the time is \" ++ show (execute giveTheTime) ++ \" click here\"
2542++-- this pseudocode would update the time every 5 seconds. The execution of the IO computation
2543++-- giveTheTime must be executed inside the cached widget to avoid unnecesary IO executions.
2545++-- NOTE: the rendering of cached widgets are shared by all users
2546++cachedWidget :: (MonadIO m,Typeable view
2547++ , FormInput view, Typeable a, Executable m )
2548++ => String -- ^ The key of the cached object for the retrieval
2549++ -> Int -- ^ Timeout of the caching. Zero means the whole server run
2550++ -> View view Identity a -- ^ The cached widget, in the Identity monad
2551++ -> View view m a -- ^ The cached result
2552++cachedWidget key t mf = View . StateT $ \s -> do
2553++ let((FormElm form _), sec)= execute $! cachedByKey key t $ proc mf s{mfCached=True}
2554++ let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True}
2555++ let s''= s{inSync = inSync s2
2556++ ,mfRequirements=mfRequirements s2
2558+- ,mfPagePath= mfPagePath s2
2559+- ,needForm= needForm s2
2560+- ,mfPageFlow= mfPageFlow s2
2561++ ,mfPagePath= mfPagePath s2
2562++ ,needForm= needForm s2
2563++ ,mfPageFlow= mfPageFlow s2
2564+ ,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec}
2565+ return $ (mfSeqCache s'') `seq` form `seq` ((FormElm form mx2), s'')
2567+- -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2))
2569+- proc mf s= runStateT (runView mf) s >>= \(r,_) -> mfSeqCache s `seq` return (r,mfSeqCache s )
2571+--- | A shorter name for `cachedWidget`
2572+-wcached :: (MonadIO m,Typeable view
2573+- , FormInput view, Typeable a, Executable m )
2574+- => String -- ^ The key of the cached object for the retrieval
2575+- -> Int -- ^ Timeout of the caching. Zero means sessionwide
2576+- -> View view Identity a -- ^ The cached widget, in the Identity monad
2577+- -> View view m a -- ^ The cached result
2578+-wcached= cachedWidget
2580+--- | Unlike `cachedWidget`, which cache the rendering but not the user response, @wfreeze@
2581+--- cache also the user response. This is useful for pseudo-widgets which just show information
2582+--- while the controls are in other non freezed widgets. A freezed widget ever return the first user response
2583+--- It is faster than `cachedWidget`.
2584+--- It is not restricted to the Identity monad.
2586+--- NOTE: the content of freezed widgets are shared by all users
2587+-wfreeze :: (MonadIO m,Typeable view
2588+- , FormInput view, Typeable a, Executable m )
2589+- => String -- ^ The key of the cached object for the retrieval
2590+- -> Int -- ^ Timeout of the caching. Zero means sessionwide
2591+- -> View view m a -- ^ The cached widget
2592+- -> View view m a -- ^ The cached result
2593+-wfreeze key t mf = View . StateT $ \s -> do
2594+- (FormElm f mx, req,seq,ajax) <- cachedByKey key t $ proc mf s{mfCached=True}
2595+- return ((FormElm f mx), s{mfRequirements=req ,mfSeqCache= seq,mfAjax=ajax})
2598+- (r,s) <- runStateT (runView mf) s
2599+- return (r,mfRequirements s, mfSeqCache s, mfAjax s)
2603+-{- | Execute the Flow, in the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`
2604+-`waiMessageFlow` or `addMessageFlows`
2606+-The flow is executed in a loop. When the flow is finished, it is started again
2609+- addMessageFlows [(\"noscript\",transient $ runFlow mainf)]
2610+- forkIO . run 80 $ waiMessageFlow
2614+-runFlow :: (FormInput view, MonadIO m)
2615+- => FlowM view (Workflow m) () -> Token -> Workflow m ()
2617+- loop (startState t) f t
2620+- (mt,s) <- runFlowOnce2 s f
2621+- let t'= fromFailBack mt
2622+- let t''= t'{tpath=[twfname t']}
2626++ -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2))
2628++ proc mf s= runStateT (runView mf) s >>= \(r,_) -> mfSeqCache s `seq` return (r,mfSeqCache s )
2630++-- | A shorter name for `cachedWidget`
2631++wcached :: (MonadIO m,Typeable view
2632++ , FormInput view, Typeable a, Executable m )
2633++ => String -- ^ The key of the cached object for the retrieval
2634++ -> Int -- ^ Timeout of the caching. Zero means sessionwide
2635++ -> View view Identity a -- ^ The cached widget, in the Identity monad
2636++ -> View view m a -- ^ The cached result
2637++wcached= cachedWidget
2639++-- | Unlike `cachedWidget`, which cache the rendering but not the user response, @wfreeze@
2640++-- cache also the user response. This is useful for pseudo-widgets which just show information
2641++-- while the controls are in other non freezed widgets. A freezed widget ever return the first user response
2642++-- It is faster than `cachedWidget`.
2643++-- It is not restricted to the Identity monad.
2645++-- NOTE: the content of freezed widgets are shared by all users
2646++wfreeze :: (MonadIO m,Typeable view
2647++ , FormInput view, Typeable a, Executable m )
2648++ => String -- ^ The key of the cached object for the retrieval
2649++ -> Int -- ^ Timeout of the caching. Zero means sessionwide
2650++ -> View view m a -- ^ The cached widget
2651++ -> View view m a -- ^ The cached result
2652++wfreeze key t mf = View . StateT $ \s -> do
2653++ (FormElm f mx, req,seq,ajax) <- cachedByKey key t $ proc mf s{mfCached=True}
2654++ return ((FormElm f mx), s{mfRequirements=req ,mfSeqCache= seq,mfAjax=ajax})
2657++ (r,s) <- runStateT (runView mf) s
2658++ return (r,mfRequirements s, mfSeqCache s, mfAjax s)
2662++{- | Execute the Flow, in the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`
2663++`waiMessageFlow` or `addMessageFlows`
2665++The flow is executed in a loop. When the flow is finished, it is started again
2668++ addMessageFlows [(\"noscript\",transient $ runFlow mainf)]
2669++ forkIO . run 80 $ waiMessageFlow
2673++runFlow :: (FormInput view, MonadIO m)
2674++ => FlowM view (Workflow m) () -> Token -> Workflow m ()
2676++ loop (startState t) f t
2679++ (mt,s) <- runFlowOnce2 s f
2680++ let t'= fromFailBack mt
2681++ let t''= t'{tpath=[twfname t']}
2685+ let s'= case mfSequence s of
2686+ -1 -> s -- !> "end of recovery loop"
2687+- _ -> s{mfPath=[twfname t],mfPagePath=[],mfEnv=[]}
2688+- loop s' f t''{tpath=[]} -- !> "LOOPAGAIN"
2692+-runFlowOnce :: (FormInput view, MonadIO m)
2693+- => FlowM view (Workflow m) () -> Token -> Workflow m ()
2694+-runFlowOnce f t= runFlowOnce1 f t >> return ()
2696+-runFlowOnce1 f t = runFlowOnce2 (startState t) f
2698++ _ -> s{mfPath=[twfname t],mfPagePath=[],mfEnv=[]}
2699++ loop s' f t''{tpath=[]} -- !> "LOOPAGAIN"
2703++runFlowOnce :: (FormInput view, MonadIO m)
2704++ => FlowM view (Workflow m) () -> Token -> Workflow m ()
2705++runFlowOnce f t= runFlowOnce1 f t >> return ()
2707++runFlowOnce1 f t = runFlowOnce2 (startState t) f
2709+ startState t= mFlowState0{mfToken=t
2710+- ,mfSequence= inRecovery
2712++ ,mfSequence= inRecovery
2719+- runStateT (runSup . runFlowM $ do
2727+- s <- get -- !> "BackInit"
2730++ runStateT (runSup . runFlowM $ do
2738++ s <- get -- !> "BackInit"
2743+ recover <- lift $ isInRecover
2744+- when (back && not recover) . modify $ \s -> s{ newAsk= True,mfPagePath=[twfname t]}
2745++ when (back && not recover) . modify $ \s -> s{ newAsk= True,mfPagePath=[twfname t]}
2748+- tr -> error $ disp tr
2750+- disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr)
2751+- -- to restart the flow in case of going back before the first page of the flow
2753++ tr -> error $ disp tr
2755++ disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr)
2756++ -- to restart the flow in case of going back before the first page of the flow
2759+ :: FormInput v => MFlowState v -> FlowM v m a -> Token -> m (FailBack a, MFlowState v)
2760+-runFlowOnceReturn s f t =
2761+- runStateT (runSup $ runFlowM f) (startState t)
2765+--- | Run a persistent flow inside the current flow. It is identified by the procedure and
2766+--- the string identifier.
2767+--- unlike the normal flows, that run within infinite loops, runFlowIn executes once.
2768+--- In subsequent executions, the flow will get the intermediate responses from te log
2769++runFlowOnceReturn s f t =
2770++ runStateT (runSup $ runFlowM f) (startState t)
2774++-- | Run a persistent flow inside the current flow. It is identified by the procedure and
2775++-- the string identifier.
2776++-- unlike the normal flows, that run within infinite loops, runFlowIn executes once.
2777++-- In subsequent executions, the flow will get the intermediate responses from te log
2778+ -- and will return the result without asking again.
2779+ -- This is useful for asking once, storing in the log and subsequently retrieving user
2780+--- defined configurations by means of persistent flows with web formularies.
2785+- -> FlowM view (Workflow IO) b
2787+-runFlowIn wf f= FlowM . Sup $ do
2789+- let t = mfToken st
2790+- (r,st') <- liftIO $ exec1nc wf $ runFlow1 st f t
2791+- put st{mfPath= mfPath st'}
2793+- GoBack -> delWF wf ()
2797+- runFlow1 st f t= runStateT (runSup . runFlowM $ f) st
2800+--- | to unlift a FlowM computation. useful for executing the configuration generated by runFLowIn
2801+--- outside of the web flow (FlowM) monad
2802+-runFlowConf :: (FormInput view, MonadIO m) => FlowM view m a -> m a
2804+- q <- liftIO newEmptyMVar -- `debug` (i++w++u)
2805++-- defined configurations by means of persistent flows with web formularies.
2810++ -> FlowM view (Workflow IO) b
2812++runFlowIn wf f= FlowM . Sup $ do
2814++ let t = mfToken st
2815++ (r,st') <- liftIO $ exec1nc wf $ runFlow1 st f t
2816++ put st{mfPath= mfPath st'}
2818++ GoBack -> delWF wf ()
2822++ runFlow1 st f t= runStateT (runSup . runFlowM $ f) st
2825++-- | to unlift a FlowM computation. useful for executing the configuration generated by runFLowIn
2826++-- outside of the web flow (FlowM) monad
2827++runFlowConf :: (FormInput view, MonadIO m) => FlowM view m a -> m a
2829++ q <- liftIO newEmptyMVar -- `debug` (i++w++u)
2830+ qr <- liftIO newEmptyMVar
2831+- block <- liftIO $ newMVar True
2832+- let t= Token "" "" "" [] [] block q qr
2833+- evalStateT (runSup . runFlowM $ f ) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return ()
2835++ block <- liftIO $ newMVar True
2836++ let t= Token "" "" "" [] [] block q qr
2837++ evalStateT (runSup . runFlowM $ f ) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return ()
2840+ -- | run a transient Flow from the IO monad.
2841+ --runNav :: String -> FlowM Html IO () -> IO ()
2842+ --runNav ident f= exec1 ident $ runFlowOnce (transientNav f) undefined
2845+--- | Clears the environment
2846+-clearEnv :: MonadState (MFlowState view) m => m ()
2849+- put st{ mfEnv= []}
2853+-instance (FormInput v,Serialize a)
2854+- => Serialize (a,MFlowState v) where
2855+- showp (x,s)= case mfDebug s of
2857+- True -> showp(x, mfEnv s)
2858+- readp= choice[nodebug, debug]
2860+- nodebug= readp >>= \x -> return (x, mFlowState0{mfSequence= inRecovery})
2863+- return (x,mFlowState0{mfEnv= env,mfSequence= inRecovery})
2867+--- | stores the result of the flow in a persistent log. When restarted, it get the result
2868+--- from the log and it does not execute it again. When no results are in the log, the computation
2869+--- is executed. It is equivalent to 'Control.Workflow.step' but in the FlowM monad.
2877+- -> FlowM view (Workflow m) a
2881+- (r,s') <- lift . WF.step $ runStateT (runSup $ runFlowM f) s
2883+- -- when recovery of a workflow, the MFlow state is not considered
2884+- when( mfSequence s' /= inRecovery) $ put s' -- !> (show $ mfSequence s') -- else put s{newAsk=True}
2887+--- | to execute transient flows as if they were persistent
2890++-- | Clears the environment
2891++clearEnv :: MonadState (MFlowState view) m => m ()
2894++ put st{ mfEnv= []}
2898++instance (FormInput v,Serialize a)
2899++ => Serialize (a,MFlowState v) where
2900++ showp (x,s)= case mfDebug s of
2902++ True -> showp(x, mfEnv s)
2903++ readp= choice[nodebug, debug]
2905++ nodebug= readp >>= \x -> return (x, mFlowState0{mfSequence= inRecovery})
2908++ return (x,mFlowState0{mfEnv= env,mfSequence= inRecovery})
2912++-- | stores the result of the flow in a persistent log. When restarted, it get the result
2913++-- from the log and it does not execute it again. When no results are in the log, the computation
2914++-- is executed. It is equivalent to 'Control.Workflow.step' but in the FlowM monad.
2922++ -> FlowM view (Workflow m) a
2926++ (r,s') <- lift . WF.step $ runStateT (runSup $ runFlowM f) s
2928++ -- when recovery of a workflow, the MFlow state is not considered
2929++ when( mfSequence s' /= inRecovery) $ put s' -- !> (show $ mfSequence s') -- else put s{newAsk=True}
2932++-- | to execute transient flows as if they were persistent
2933+ -- it can be used instead of step, but it does log nothing.
2934+ -- Thus, it is faster and convenient when no session state must be stored beyond the lifespan of
2935+--- the server process.
2937+--- > transient $ runFlow f === runFlow $ transientNav f
2944+- -> FlowM view (Workflow IO) a
2948+- (r,s') <- lift . unsafeIOtoWF $ runStateT (runSup $ runFlowM f) s
2953+--- :: (Serialize a,
2959+--- -> FlowM view (Workflow m) (WFRef (FailBack a),a)
2962+--- flowM $ Sup $ do
2963+--- (r,s') <- lift . WF.stepWFRef $ runStateT (runSup $ runFlowM f) s
2964+--- -- when recovery of a workflow, the MFlow state is not considered
2965+--- when( mfSequence s' >0) $ put s'
2970+--- flowM $ Sup $ do
2972+--- (br,s') <- runStateT (runSup $ runFlowM f) s
2974+--- NoBack r -> WF.step $ return r
2975+--- BackPoint r -> WF.step $ return r
2976+--- GoBack -> undoStep
2977+--- -- when recovery of a workflow, the MFlow state is not considered
2978+--- when( mfSequence s' >0) $ put s'
2984+--- :: (Serialize a,
2991+--- -> FlowM view (Workflow m) a
2992+---stepDebug f= Sup $ do
2994+--- (r, s') <- lift $ do
2996+--- rec <- isInRecover
2998+--- True ->do (r', s'') <- getStep 0
2999+--- return (r',s{mfEnv= mfEnv (s'' `asTypeOf`s)})
3000+--- False -> return (undefined,s)
3001+--- (r'', s''') <- WF.stepDebug $ runStateT (runSup f) stat >>= \(r,s)-> return (r, s)
3002+--- return $ (r'' `asTypeOf` r', s''' )
3008+-data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)
3010+-valToMaybe (Validated x)= Just x
3011+-valToMaybe _= Nothing
3013+-isValidated (Validated x)= True
3014+-isValidated _= False
3016+-fromValidated (Validated x)= x
3017+-fromValidated NoParam= error $ "fromValidated : NoParam"
3018+-fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s
3022+-getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
3023+- => String -> Params -> m (ParamResult v a)
3024+-getParam1 par req = case lookup par req of
3025+- Just x -> readParam x
3026+- Nothing -> return NoParam
3027++-- the server process.
3029++-- > transient $ runFlow f === runFlow $ transientNav f
3036++ -> FlowM view (Workflow IO) a
3040++ (r,s') <- lift . unsafeIOtoWF $ runStateT (runSup $ runFlowM f) s
3045++-- :: (Serialize a,
3051++-- -> FlowM view (Workflow m) (WFRef (FailBack a),a)
3054++-- flowM $ Sup $ do
3055++-- (r,s') <- lift . WF.stepWFRef $ runStateT (runSup $ runFlowM f) s
3056++-- -- when recovery of a workflow, the MFlow state is not considered
3057++-- when( mfSequence s' >0) $ put s'
3062++-- flowM $ Sup $ do
3064++-- (br,s') <- runStateT (runSup $ runFlowM f) s
3066++-- NoBack r -> WF.step $ return r
3067++-- BackPoint r -> WF.step $ return r
3068++-- GoBack -> undoStep
3069++-- -- when recovery of a workflow, the MFlow state is not considered
3070++-- when( mfSequence s' >0) $ put s'
3076++-- :: (Serialize a,
3083++-- -> FlowM view (Workflow m) a
3084++--stepDebug f= Sup $ do
3086++-- (r, s') <- lift $ do
3088++-- rec <- isInRecover
3090++-- True ->do (r', s'') <- getStep 0
3091++-- return (r',s{mfEnv= mfEnv (s'' `asTypeOf`s)})
3092++-- False -> return (undefined,s)
3093++-- (r'', s''') <- WF.stepDebug $ runStateT (runSup f) stat >>= \(r,s)-> return (r, s)
3094++-- return $ (r'' `asTypeOf` r', s''' )
3100++data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)
3102++valToMaybe (Validated x)= Just x
3103++valToMaybe _= Nothing
3105++isValidated (Validated x)= True
3106++isValidated _= False
3108++fromValidated (Validated x)= x
3109++fromValidated NoParam= error $ "fromValidated : NoParam"
3110++fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s
3114++getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
3115++ => String -> Params -> m (ParamResult v a)
3116++getParam1 par req = case lookup par req of
3117++ Just x -> readParam x
3118++ Nothing -> return NoParam
3120+ -- Read a segment in the REST path. if it does not match with the type requested
3121+--- or if there is no remaining segment, it returns Nothing
3122++-- or if there is no remaining segment, it returns Nothing
3123+ getRestParam :: (Read a, Typeable a, Monad m, Functor m, MonadState (MFlowState v) m, FormInput v)
3127+- let lpath = mfPath st
3131++ let lpath = mfPath st
3133+- then return Nothing
3134++ then return Nothing
3135+ else case stripPrefix (mfPagePath st) lpath of
3136+ Nothing -> return Nothing
3137+- Just [] -> return Nothing
3139+- case stripPrefix (mfPrefix st) (head xs) of
3140+- Nothing -> return Nothing
3142+- r <- fmap valToMaybe $ readParam name
3143+- when (isJust r) $ modify $ \s -> s{inSync= True
3144+- ,linkMatched= True
3145+- ,mfPagePath= mfPagePath s++[name]}
3148++ Just [] -> return Nothing
3150++-- case stripPrefix (mfPrefix st) (head xs) of
3151++-- Nothing -> return Nothing
3154++ r <- fmap valToMaybe $ readParam name
3155++ when (isJust r) $ modify $ \s -> s{inSync= True
3156++ ,linkMatched= True
3157++ ,mfPagePath= mfPagePath s++[name]}
3162+ -- | return the value of a post or get param in the form ?param=value¶m2=value2...
3163+@@ -1246,31 +1284,31 @@
3165+ r <- getParam1 par $ mfEnv st
3166+ return $ valToMaybe r
3168+-readParam :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
3169+- => String -> m (ParamResult v a)
3173+- modify $ \s -> s{inSync= True}
3176+- getType :: m (ParamResult v a) -> a
3177+- getType= undefined
3180+- let typeofx = typeOf x
3182++readParam :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
3183++ => String -> m (ParamResult v a)
3187++ modify $ \s -> s{inSync= True}
3190++ getType :: m (ParamResult v a) -> a
3191++ getType= undefined
3194++ let typeofx = typeOf x
3195+ if typeofx == typeOf ( undefined :: String) then
3196+ return . Validated $ unsafeCoerce str
3197+ else if typeofx == typeOf (undefined :: T.Text) then
3198+- return . Validated . unsafeCoerce $ T.pack str
3199+- else case readsPrec 0 $ str of
3200+- [(x,"")] -> return $ Validated x
3202+- let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
3203+- return $ NotValidated str err
3206++ return . Validated . unsafeCoerce $ T.pack str
3207++ else case readsPrec 0 $ str of
3208++ [(x,"")] -> return $ Validated x
3210++ let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
3211++ return $ NotValidated str err
3217+@@ -1278,39 +1316,41 @@
3218+ -- Web page or in the server when a widget specifies this. @requires@ is the
3219+ -- procedure to be called with the list of requirements.
3220+ -- Various widgets in the page can require the same element, MFlow will install it once.
3225+ let l = mfRequirements st
3226+--- let rs'= map Requirement rs \\ l
3227+ put st {mfRequirements= l ++ map Requirement rs}
3230++unfold (JScriptFile f ss)= JScript loadScript:map (\s-> JScriptFile f [s]) ss
3233+ data Requirement= forall a.(Show a,Typeable a,Requirements a) => Requirement a deriving Typeable
3235+ class Requirements a where
3236+- installRequirements :: (Monad m,FormInput view) => Bool -> [a] -> m view
3237++ installRequirements :: (MonadState (MFlowState view) m,MonadIO m,FormInput view) => [a] -> m view
3239+ instance Show Requirement where
3240+ show (Requirement a)= show a ++ "\n"
3242+-installAllRequirements :: ( Monad m, FormInput view) => WState view m view
3243++installAllRequirements :: ( MonadIO m, FormInput view) => WState view m view
3244+ installAllRequirements= do
3246+ let rs = mfRequirements st
3247+- auto = mfAutorefresh st
3248+- installAllRequirements1 auto mempty rs
3249++ installAllRequirements1 mempty rs
3253+- installAllRequirements1 _ v []= return v
3254+- installAllRequirements1 auto v rs= do
3255++ installAllRequirements1 v []= return v
3256++ installAllRequirements1 v rs= do
3257+ let typehead= case head rs of {Requirement r -> typeOf r}
3258+ (rs',rs'')= partition1 typehead rs
3259+ v' <- installRequirements2 rs'
3260+- installAllRequirements1 auto (v `mappend` v') rs''
3261++ installAllRequirements1 (v `mappend` v') rs''
3263+ installRequirements2 []= return $ fromStrNoEncode ""
3264+- installRequirements2 (Requirement r:rs)= installRequirements auto $ r:unmap rs
3265++ installRequirements2 (Requirement r:rs)= installRequirements $ r:unmap rs
3267+ unmap (Requirement r:rs)= unsafeCoerce r:unmap rs
3268+ partition1 typehead xs = foldr select ([],[]) xs
3269+@@ -1320,155 +1360,194 @@
3270+ in if typer== typehead then ( x:ts,fs)
3273+--- Web requirements ---
3274+-loadjsfile filename lcallbacks=
3275+- let name= addrStr filename in
3276+- "var fileref = document.getElementById('"++name++"');\
3277+- \if (fileref === null){\
3278++-- Web requirements ---
3279++loadjsfile filename=
3280++ let name= addrStr filename
3281++ in "\n"++name++"=loadScript('"++name++"','"++filename++"');\n"
3283++loadScript ="function loadScript(name, filename){\
3284++ \var fileref = document.getElementById(name);\
3285++ \if (fileref === null){\
3286+ \fileref=document.createElement('script');\
3287+- \fileref.setAttribute('id','"++name++"');\
3288+- \fileref.setAttribute('type','text/javascript');\
3289+- \fileref.setAttribute('src',\'" ++ filename ++ "\');\
3290+- \document.getElementsByTagName('head')[0].appendChild(fileref);};"
3293+- onload= case lcallbacks of
3295+- cs -> "fileref.onload = function() {"++ (concat $ nub cs)++"};"
3298+-loadjs content= content
3301+-loadcssfile filename=
3302+- "var fileref=document.createElement('link');\
3303+- \fileref.setAttribute('rel', 'stylesheet');\
3304+- \fileref.setAttribute('type', 'text/css');\
3305+- \fileref.setAttribute('href', \'"++filename++"\');\
3306+- \document.getElementsByTagName('head')[0].appendChild(fileref);"
3310+- "var fileref=document.createElement('link');\
3311+- \fileref.setAttribute('rel', 'stylesheet');\
3312+- \fileref.setAttribute('type', 'text/css');\
3313+- \fileref.innerText=\""++content++"\";\
3314+- \document.getElementsByTagName('head')[0].appendChild(fileref);"
3317+-data WebRequirement= JScriptFile
3319+- [String] -- ^ Script URL and the list of scripts to be executed when loaded
3320+- | CSSFile String -- ^ a CSS file URL
3321+- | CSS String -- ^ a String with a CSS description
3322+- | JScript String -- ^ a string with a valid JavaScript
3323+- | ServerProc (String, Flow) -- ^ a server procedure
3324+- deriving(Typeable,Eq,Ord,Show)
3326+-instance Eq (String, Flow) where
3327++ \fileref.setAttribute('id',name);\
3328++ \fileref.setAttribute('type','text/javascript');\
3329++ \fileref.setAttribute('src',filename);\
3330++ \document.getElementsByTagName('head')[0].appendChild(fileref);}\
3331++ \return fileref};\n\
3332++ \function addLoadEvent(elem,func) {\
3333++ \var oldonload = elem.onload;\
3334++ \if (typeof elem.onload != 'function') {\
3335++ \elem.onload = func;\
3337++ \elem.onload = function() {\
3338++ \if (oldonload) {\
3346++loadCallback depend script=
3347++ let varname= addrStr depend in
3348++ "\naddLoadEvent("++varname++",function(){"++ script++"});"
3353++loadcssfile filename=
3354++ "var fileref=document.createElement('link');\
3355++ \fileref.setAttribute('rel', 'stylesheet');\
3356++ \fileref.setAttribute('type', 'text/css');\
3357++ \fileref.setAttribute('href', \'"++filename++"\');\
3358++ \document.getElementsByTagName('head')[0].appendChild(fileref);"
3362++ "var fileref=document.createElement('link');\
3363++ \fileref.setAttribute('rel', 'stylesheet');\
3364++ \fileref.setAttribute('type', 'text/css');\
3365++ \fileref.innerText=\""++content++"\";\
3366++ \document.getElementsByTagName('head')[0].appendChild(fileref);"
3369++data WebRequirement= JScriptFile
3371++ [String] -- ^ Script URL and the list of scripts to be executed when loaded
3372++ | CSSFile String -- ^ a CSS file URL
3373++ | CSS String -- ^ a String with a CSS description
3374++ | JScript String -- ^ a string with a valid JavaScript
3375++ | ServerProc (String, Flow) -- ^ a server procedure
3376++ deriving(Typeable,Eq,Ord,Show)
3378++instance Eq (String, Flow) where
3379+ (x,_) == (y,_)= x == y
3381+-instance Ord (String, Flow) where
3382+- compare(x,_) (y,_)= compare x y
3383+-instance Show (String, Flow) where
3384+- show (x,_)= show x
3386+-instance Requirements WebRequirement where
3387+- installRequirements= installWebRequirements
3391+-installWebRequirements :: (Monad m,FormInput view) => Bool -> [WebRequirement] -> m view
3392+-installWebRequirements auto rs= do
3393+- let s = jsRequirements auto $ sort rs
3395+- return $ ftag "script" (fromStrNoEncode s)
3398+-jsRequirements _ []= ""
3400+-jsRequirements False (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs)
3401+- | f==f' = jsRequirements False $ JScriptFile f (nub $ c++c'):rs
3402+- | otherwise= strRequirement r ++ jsRequirements False (r':rs)
3404+-jsRequirements True (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs)
3405+- | f==f' = concatMap strRequirement(map JScript $ nub (c' ++ c)) ++ jsRequirements True rs
3406+- | otherwise= strRequirement r ++ jsRequirements True (r':rs)
3411+-jsRequirements auto (r:r':rs)
3412+- | r== r' = jsRequirements auto $ r:rs
3413+- | otherwise= strRequirement r ++ jsRequirements auto (r':rs)
3415+-jsRequirements auto (r:rs)= strRequirement r++jsRequirements auto rs
3417+-strRequirement (CSSFile s') = loadcssfile s'
3418+-strRequirement (CSS s') = loadcss s'
3419+-strRequirement (JScriptFile s' call) = loadjsfile s' call
3420+-strRequirement (JScript s') = loadjs s'
3421+-strRequirement (ServerProc f)= (unsafePerformIO $! addMessageFlows [f]) `seq` ""
3429+- "function loadXMLObj()" ++
3432+- "if (window.XMLHttpRequest)" ++
3434+- " xmlhttp=new XMLHttpRequest();" ++
3438+- " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++
3440+- "return xmlhttp" ++
3443+- " xmlhttp= loadXMLObj();" ++
3446+- "function doServer (servproc,param,param2){" ++
3447+- " xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++
3448+- " xmlhttp.send();};" ++
3450+- "xmlhttp.onreadystatechange=function()" ++
3452+- " if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++
3454+- " eval(xmlhttp.responseText);" ++
3459+-formPrefix st form anchored= do
3461++instance Ord (String, Flow) where
3462++ compare(x,_) (y,_)= compare x y
3463++instance Show (String, Flow) where
3464++ show (x,_)= show x
3466++instance Requirements WebRequirement where
3467++ installRequirements= installWebRequirements
3471++installWebRequirements
3472++ :: (MonadState(MFlowState view) m,MonadIO m,FormInput view) => [WebRequirement] -> m view
3473++installWebRequirements rs= do
3474++ installed <- gets mfInstalledScripts
3475++ let rs'= (nub rs) \\ installed
3477++ strs <- mapM strRequirement rs' -- !>( "OLD="++show installed) !> ("new="++show rs')
3479++ True -> return mempty
3480++ False -> return . ftag "script" . fromStrNoEncode $ concat strs
3483++strRequirement r=do
3484++ r1 <- strRequirement' r
3485++ modify $ \st -> st{mfInstalledScripts= mfInstalledScripts st ++ [r]}
3488++strRequirement' (CSSFile scr) = return $ loadcssfile scr
3489++strRequirement' (CSS scr) = return $ loadcss scr
3490++strRequirement' (JScriptFile file scripts) = do
3491++ installed <- gets mfInstalledScripts
3492++ let hasLoadScript (JScriptFile _ _)= True
3493++ hasLoadScript _= False
3494++ inst2= dropWhile (not . hasLoadScript) installed
3495++ hasSameFile file (JScriptFile fil _)= if file== fil then True else False
3496++ hasSameFile _ _= False
3497++ case (inst2,find (hasSameFile file) inst2) of
3499++ -- no script file has been loaded previously
3500++ return $ loadScript <> loadjsfile file <> concatMap(loadCallback file) scripts
3502++ -- This script file has been already loaded or demanded for load
3503++ autorefresh <- gets mfAutorefresh
3504++ case autorefresh of
3505++ -- demanded for load, not loaded
3506++ False -> return $ concatMap(loadCallback file) scripts
3508++ True -> return $ concat scripts
3509++ -- other script file has been loaded or demanded load, so loadScript is already installed
3510++ _ -> return $ loadjsfile file <> concatMap(loadCallback file) scripts
3513++strRequirement' (JScript scr) = return scr
3514++strRequirement' (ServerProc f)= do
3515++ liftIO $ addMessageFlows [f]
3524++ "function loadXMLObj()" ++
3527++ "if (window.XMLHttpRequest)" ++
3529++ " xmlhttp=new XMLHttpRequest();" ++
3533++ " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++
3535++ "return xmlhttp" ++
3538++ " xmlhttp= loadXMLObj();" ++
3541++ "function doServer (servproc,param,param2){" ++
3542++ " xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++
3543++ " xmlhttp.send();};" ++
3545++ "xmlhttp.onreadystatechange=function()" ++
3547++ " if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++
3549++ " eval(xmlhttp.responseText);" ++
3554++formPrefix st form anchored= do
3555+ let verb = twfname $ mfToken st
3556+- path = currentPath st
3558+- <- case anchored of
3560+- anchor <- genNewId
3561+- return ('#':anchor, (ftag "a") mempty `attrs` [("name",anchor)])
3562+- False -> return (mempty,mempty)
3563+- return $ formAction (path ++ anchor ) $ anchorf <> form -- !> anchor
3565+--- | insert a form tag if the widget has form input fields. If not, it does nothing
3566+-insertForm w=View $ do
3567+- FormElm forms mx <- runView w
3569+- cont <- case needForm1 st of
3571+- frm <- formPrefix st forms False
3572+- put st{needForm= HasForm}
3576+- return $ FormElm cont mx
3577++ path = currentPath st
3578++ hasfile= mfFileUpload st
3579++ attr= case hasfile of
3580++ True -> [("enctype","multipart/form-data")]
3583++ <- case anchored of
3585++ anchor <- genNewId
3586++ return ('#':anchor, (ftag "a") mempty `attrs` [("name",anchor)])
3587++ False -> return (mempty,mempty)
3588++ return $ formAction (path ++ anchor ) "POST" ( anchorf <> form ) `attrs` attr
3595++-- | insert a form tag if the widget has form input fields. If not, it does nothing
3596++insertForm w=View $ do
3597++ FormElm forms mx <- runView w
3599++ cont <- case needForm st of
3601++ frm <- formPrefix st forms False
3602++ put st{needForm= HasForm}
3606++ return $ FormElm cont mx
3608+ -- isert a form tag if necessary when two pieces of HTML have to mix as a result of >>= >> <|> or <+> operators
3609+ controlForms :: (FormInput v, MonadState (MFlowState v) m)
3610+@@ -1481,40 +1560,40 @@
3611+ v1' <- formPrefix s1 v1 True
3612+ return (v1' <> v2 , True)
3614+- _ -> return (v1 <> v2, False)
3616+-currentPath st= concat ['/':v| v <- mfPagePath st ]
3618+--- | Generate a new string. Useful for creating tag identifiers and other attributes.
3620+--- if the page is refreshed, the identifiers generated are the same.
3621+-genNewId :: MonadState (MFlowState view) m => m String
3624+- case mfCached st of
3626+- let n= mfSequence st
3627+- prefseq= mfPrefix st
3628+- put $ st{mfSequence= n+1}
3630+- return $ 'p':show n++prefseq
3632+- let n = mfSeqCache st
3633+- put $ st{mfSeqCache=n+1}
3634+- return $ 'c' : (show n)
3636+--- | get the next ideitifier that will be created by genNewId
3637+-getNextId :: MonadState (MFlowState view) m => m String
3640+- case mfCached st of
3642+- let n= mfSequence st
3643+- prefseq= mfPrefix st
3644+- return $ 'p':show n++prefseq
3646+- let n = mfSeqCache st
3647+- return $ 'c' : (show n)
3648++ _ -> return (v1 <> v2, False)
3650++currentPath st= concat ['/':v| v <- mfPagePath st ]
3652++-- | Generate a new string. Useful for creating tag identifiers and other attributes.
3654++-- if the page is refreshed, the identifiers generated are the same.
3655++genNewId :: MonadState (MFlowState view) m => m String
3658++ case mfCached st of
3660++ let n= mfSequence st
3661++ prefseq= mfPrefix st
3662++ put $ st{mfSequence= n+1}
3664++ return $ 'p':show n++prefseq
3666++ let n = mfSeqCache st
3667++ put $ st{mfSeqCache=n+1}
3668++ return $ 'c' : (show n)
3670++-- | get the next ideitifier that will be created by genNewId
3671++getNextId :: MonadState (MFlowState view) m => m String
3674++ case mfCached st of
3676++ let n= mfSequence st
3677++ prefseq= mfPrefix st
3678++ return $ 'p':show n++prefseq
3680++ let n = mfSeqCache st
3681++ return $ 'c' : (show n)
3686+diff -ru orig/src/MFlow/Forms/Test.hs new/src/MFlow/Forms/Test.hs
3687+--- orig/src/MFlow/Forms/Test.hs 2014-06-10 05:51:26.977015856 +0300
3688++++ new/src/MFlow/Forms/Test.hs 2014-06-10 05:51:25.000000000 +0300
3690+------------------------------------------------------------------------------
3692+--- Module : MFlow.Forms.Test
3696+--- Maintainer : agocorona@gmail.com
3697+--- Stability : experimental
3702+------------------------------------------------------------------------------
3704+- -XOverlappingInstances
3705+- -XFlexibleInstances
3706+- -XUndecidableInstances
3711+-module MFlow.Forms.Test (Generate(..),runTest,runTest1,inject, ask, askt, userWidget, getUser, getUserSimple, verify) where
3712+-import MFlow.Forms hiding(ask,askt,getUser,userWidget,getUserSimple)
3713+-import qualified MFlow.Forms (ask)
3714+-import MFlow.Forms.Internals
3715+-import MFlow.Forms(FormInput(..))
3716+-import MFlow.Forms.Admin
3717+-import Control.Workflow as WF
3718+-import Control.Concurrent
3719+-import Control.Monad
3721+-import qualified Data.Map as M
3722+-import Control.Monad.Trans
3723+-import System.IO.Unsafe
3724+-import System.Random
3725+-import Data.Char(chr, ord)
3727+-import Data.Typeable
3728+-import qualified Data.ByteString.Lazy.Char8 as B
3729+-import Control.Concurrent.MVar
3730+-import Data.TCache.Memoization
3731+-import Control.Monad.State
3735+-import MFlow.Cookies(cookieuser)
3737+-import Data.Dynamic
3738+-import Data.TCache.Memoization
3742+-class Generate a where
3745+-instance Generate a => Generate (Maybe a) where
3747+- b <- randomRIO(0,1 :: Int)
3748+- case b of 0 -> generate >>= return . Just ; _ -> return Nothing
3750+-instance Generate String where
3751+- generate= replicateM 5 $ randomRIO ('a','z')
3753+-instance Generate Int where
3754+- generate= randomRIO(1,1000)
3756+-instance Generate Integer where
3757+- generate= randomRIO(1,1000)
3760+-instance (Generate a, Generate b) => Generate (a,b) where
3761+- generate= fmap (,) generate `ap` generate
3764+-instance (Generate a, Generate b) => Generate (Maybe a,Maybe b) where
3768+- (Nothing,Nothing) -> generate
3769+- other -> return other
3772+-instance (Bounded a, Enum a) => Generate a where
3776+- let x= typeOfIO mx
3777+- n <- randomRIO ( fromEnum $ minBound `asTypeOf` x
3778+- , fromEnum $ maxBound `asTypeOf` x)
3781+- typeOfIO :: IO a -> a
3782+- typeOfIO = undefined
3784+--- | run a list of flows with a number of simultaneous threads
3785+-runTest :: [(Int, Flow)] -> IO ()
3787+- mapM_ (forkIO . run1) ps
3788+- putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads"
3791+- run1 (nusers, proc) = replicateM_ nusers $ runTest1 proc
3794+- atomicModifyIORef testNumber (\n -> (n+1,n+1))
3798++-----------------------------------------------------------------------------
3800++-- Module : MFlow.Forms.Test
3804++-- Maintainer : agocorona@gmail.com
3805++-- Stability : experimental
3810++-----------------------------------------------------------------------------
3812++ -XOverlappingInstances
3813++ -XFlexibleInstances
3814++ -XUndecidableInstances
3819++module MFlow.Forms.Test (Generate(..),runTest,runTest1,inject, ask, askt, userWidget, getUser, getUserSimple, verify) where
3820++import MFlow.Forms hiding(ask,askt,getUser,userWidget,getUserSimple)
3821++import qualified MFlow.Forms (ask)
3822++import MFlow.Forms.Internals
3823++import MFlow.Forms(FormInput(..))
3824++import MFlow.Forms.Admin
3825++import Control.Workflow as WF
3826++import Control.Concurrent
3827++import Control.Monad
3829++import qualified Data.Map as M
3830++import Control.Monad.Trans
3831++import System.IO.Unsafe
3832++import System.Random
3833++import Data.Char(chr, ord)
3835++import Data.Typeable
3836++import qualified Data.ByteString.Lazy.Char8 as B
3837++import Control.Concurrent.MVar
3838++import Data.TCache.Memoization
3839++import Control.Monad.State
3843++import MFlow.Cookies(cookieuser)
3845++import Data.Dynamic
3846++import Data.TCache.Memoization
3850++class Generate a where
3853++instance Generate a => Generate (Maybe a) where
3855++ b <- randomRIO(0,1 :: Int)
3856++ case b of 0 -> generate >>= return . Just ; _ -> return Nothing
3858++instance Generate String where
3859++ generate= replicateM 5 $ randomRIO ('a','z')
3861++instance Generate Int where
3862++ generate= randomRIO(1,1000)
3864++instance Generate Integer where
3865++ generate= randomRIO(1,1000)
3868++instance (Generate a, Generate b) => Generate (a,b) where
3869++ generate= fmap (,) generate `ap` generate
3872++instance (Generate a, Generate b) => Generate (Maybe a,Maybe b) where
3876++ (Nothing,Nothing) -> generate
3877++ other -> return other
3880++instance (Bounded a, Enum a) => Generate a where
3884++ let x= typeOfIO mx
3885++ n <- randomRIO ( fromEnum $ minBound `asTypeOf` x
3886++ , fromEnum $ maxBound `asTypeOf` x)
3889++ typeOfIO :: IO a -> a
3890++ typeOfIO = undefined
3892++-- | run a list of flows with a number of simultaneous threads
3893++runTest :: [(Int, Flow)] -> IO ()
3895++ mapM_ (forkIO . run1) ps
3896++ putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads"
3899++ run1 (nusers, proc) = replicateM_ nusers $ runTest1 proc
3902++ atomicModifyIORef testNumber (\n -> (n+1,n+1))
3908+- let t = Token x y z [] [] undefined undefined undefined
3911+-testNumber= unsafePerformIO $ newIORef 0
3913+-getTestNumber :: MonadIO m => m Int
3914+-getTestNumber= liftIO $ readIORef testNumber
3916+--- | inject substitutes an expression by other. It may be used to override
3917+--- ask interaction with the user. It should bee used infix for greater readability:
3919+--- > ask something `inject` const someother
3921+--- The parameter passed is the test number
3922+--- if the flow has not been executed by runTest, inject return the original
3923+-inject :: MonadIO m => m b -> (Int -> b) -> m b
3925+- n <- getTestNumber
3926+- if n== 0 then exp else exp `seq` return $ v n
3928+--- | a simulated ask that generate simulated user input of the type expected.
3930+--- It forces the web page rendering, since it is monadic and can contain
3931+--- side effects and load effects to be tested.
3933+--- it is a substitute of 'ask' from "MFlow.Forms" for testing purposes.
3935+--- execute 'runText' to initiate threads under different load conditions.
3936+-ask :: (Generate a, MonadIO m, Functor m, FormInput v,Typeable v) => View v m a -> FlowM v m a
3938+- FormElm forms mx <- FlowM . lift $ runView w
3939+- r <- liftIO generate
3940+- let n= B.length $ toByteString forms
3941+- breturn $ n `seq` mx `seq` r
3942+--- let u= undefined
3943+--- liftIO $ runStateT (runView mf) s
3944+--- bool <- liftIO generate
3946+--- False -> fail ""
3948+--- b <- liftIO generate
3949+--- r <- liftIO generate
3951+--- (True,x) -> breturn x
3955+--- | instead of generating a result like `ask`, the result is given as the first parameter
3956+--- so it does not need a Generate instance.
3958+--- It forces the web page rendering, since it is monadic so it can contain
3959+--- side effects and load effects to be tested.
3960+-askt :: (MonadIO m, FormInput v) => (Int -> a) -> View v m a -> FlowM v m a
3962+- FormElm forms mx <- FlowM . lift $ runView w
3963+- n <- getTestNumber
3964+- let l= B.length $ toByteString forms
3965+- breturn $ l `seq` mx `seq` v n
3967+---mvtestopts :: MVar (M.Map String (Int,Dynamic))
3968+---mvtestopts = unsafePerformIO $ newMVar M.empty
3970+---asktn :: (Typeable a,MonadIO m) => [a] -> View v m a -> FlowM v m a
3972+--- v <- liftIO $ do
3973+--- let k = addrStr xs
3974+--- opts <- takeMVar mvtestopts
3975+--- let r = M.lookup k opts
3978+--- putMVar mvtestopts $ M.singleton k (0,toDyn xs)
3979+--- return $ head xs
3980+--- Just (i,d) -> do
3981+--- putMVar mvtestopts $ M.insert k (i+1,d) opts
3982+--- return $ (fromMaybe (error err1) $ fromDynamic d) !! i
3987+--- err1= "MFlow.Forms.Test: asktn: fromDynamic error"
3990+--- | verify a property. if not true, throw the error message.
3992+--- It is intended to be used in a infix notation, on the right of the code,
3993+--- in order to separate the code assertions from the application code and make clearly
3994+--- visible them as a form of documentation.
3995+--- separated from it:
3997+--- > liftIO $ print (x :: Int) `verify` (return $ x > 10, "x < = 10")
3999+--- the expression is monadic to allow for complex verifications that may involve IO actions
4000+-verifyM :: Monad m => m b -> (m Bool, String) -> m b
4001+-verifyM f (mprop, msg)= do
4005+- False -> error msg
4007+--- | a pure version of verifyM
4008+-verify :: a -> (Bool, String) -> a
4009+-verify f (prop, msg)= do
4012+- False -> error msg
4017+--- marches <- readIORef matches
4018+--- return $ head map (m s) matches
4020+--- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of
4022+--- False -> Nothing
4024+---composeParams (Gen ps) form= zip (getParams form) ps
4027+--- let search name form
4028+--- | null form = mempty
4029+--- | isPrefix name form = drop (length name) form
4030+--- | otherwise= search name $ tail form
4032+--- par s= takeWhile(/='\"') . dropWhile (/='\"') . tail . dropWhile (/='=') $ s
4033+--- getPar= par $ search "name"
4037+-waction :: (Functor m, MonadIO m,Generate a, FormInput view)
4039+- -> (a -> FlowM view m b)
4042+- x <- liftIO generate
4043+- MFlow.Forms.waction (return x) f
4045+-userWidget :: ( MonadIO m, Functor m
4048+- -> View view m (Maybe (String,String), Maybe String)
4049+- -> View view m String
4050+-userWidget muser formuser= do
4051+- user <- getCurrentUser
4052+- if muser== Just user then return user
4053+- else if isJust muser then do
4054+- let user= fromJust muser
4055+- login user >> return user
4056+- else liftIO generate >>= \u -> login u >> return u
4061+- let t = mfToken st
4062+- t'= t{tuser= uname}
4063+- put st{mfToken= t'}
4066+-getUserSimple :: ( MonadIO m, FormInput view, Typeable view
4068+- => FlowM view m String
4069+-getUserSimple= getUser Nothing userFormLine
4072+-getUser :: ( FormInput view, Typeable view
4073+- , Functor m,MonadIO m)
4075+- -> View view m (Maybe (String,String), Maybe String)
4076+- -> FlowM view m String
4077+-getUser mu form= ask $ userWidget mu form
4080+--- :: (Functor m, MonadIO m, FormInput v, Generate (Maybe a)) =>
4082+--- -> ([v] -> Maybe a -> WState v m ([v], Maybe b))
4084+---wmodify formt act = do
4085+--- x <- liftIO generate
4086+--- formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act
4090+-data Test= Test{tflink:: [(Var,String)]
4091+- ,selectOptions :: [(Var,[String])]
4092+- ,tfinput :: [(Var, String)]
4093+- ,tftextarea :: [(Var, String)]
4095+- deriving(Read,Show)
4097+-type TestM = Test -> Test
4099+-instance Monoid TestM where
4103+-instance FormInput TestM where
4106+- fromStr = const id
4107+- flink var _= let(n,v)=break (=='=') var in \t ->t{tflink= (n,tail v):tflink t}
4108+- finput n _ v _ _ = \t -> t{tfinput = (n,v):tfinput t}
4109+- ftextarea n v= \t -> t{tftextarea = (n,v):tftextarea t}
4110+- fselect n _= \t -> t{selectOptions=(n,[]):selectOptions t}
4111+- foption o _ _= \t ->
4112+- let (n,opts)= head $ selectOptions t
4113+- in t{selectOptions=(n,o:opts):tail (selectOptions t)}
4114+- formAction _ _= id
4115+- addAttributes _ _= id
4117+-generateGenerate Test{..}= do
4125+- -- one on every generate is incomplete
4126+- n <- randomRIO(0,10) :: IO Int
4135+- return $ r1++r2++r3
4137+- let n = length tflink
4138+- if n == 0 then genForm
4140+- r <- randomRIO(0,n )
4141+- return [tflink !! r]
4144+- let n = length selectOptions
4147+- else mapM gen selectOptions
4151+- j <- randomRIO(0,m)
4152+- return (s, os !! j)
4155+- let n = length tftextarea
4158+- else mapM gen tfinput
4159+- where gen(n,_)= do
4164+- let n = length tfinput
4167+- else mapM gen tftextarea
4175+-instance Processable Params where
4176+- pwfname = fromMaybe noScript . lookup pwf
4177+- puser= fromMaybe anonymous . lookup cookieuser
4178+- pind = fromMaybe "0" . lookup ind
4183+-runTest nusers = do
4184+- wfs <- getMessageFlows
4185+- replicateM nusers $ gen wfs
4189+- mapM (genTraffic u) $ M.toList wfs
4191+- genTraffic u (n,_)= forkIO $ iterategenerates [(pwf,n),(cookieuser,u)] []
4193+- iterategenerates ident msg= iterate [] msg
4195+- iterate cs msg= do
4196+- (HttpData ps cooks test,_) <- msgScheduler $ ident ++ cs++ msg
4197+- let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks
4198+- resp <- generateGenerate . read $ B.unpack test
4203++ let t = Token x y z [] [] undefined undefined undefined
4206++testNumber= unsafePerformIO $ newIORef 0
4208++getTestNumber :: MonadIO m => m Int
4209++getTestNumber= liftIO $ readIORef testNumber
4211++-- | inject substitutes an expression by other. It may be used to override
4212++-- ask interaction with the user. It should bee used infix for greater readability:
4214++-- > ask something `inject` const someother
4216++-- The parameter passed is the test number
4217++-- if the flow has not been executed by runTest, inject return the original
4218++inject :: MonadIO m => m b -> (Int -> b) -> m b
4220++ n <- getTestNumber
4221++ if n== 0 then exp else exp `seq` return $ v n
4223++-- | a simulated ask that generate simulated user input of the type expected.
4225++-- It forces the web page rendering, since it is monadic and can contain
4226++-- side effects and load effects to be tested.
4228++-- it is a substitute of 'ask' from "MFlow.Forms" for testing purposes.
4230++-- execute 'runText' to initiate threads under different load conditions.
4231++ask :: (Generate a, MonadIO m, Functor m, FormInput v,Typeable v) => View v m a -> FlowM v m a
4233++ FormElm forms mx <- FlowM . lift $ runView w
4234++ r <- liftIO generate
4235++ let n= B.length $ toByteString forms
4236++ breturn $ n `seq` mx `seq` r
4237++-- let u= undefined
4238++-- liftIO $ runStateT (runView mf) s
4239++-- bool <- liftIO generate
4241++-- False -> fail ""
4243++-- b <- liftIO generate
4244++-- r <- liftIO generate
4246++-- (True,x) -> breturn x
4250++-- | instead of generating a result like `ask`, the result is given as the first parameter
4251++-- so it does not need a Generate instance.
4253++-- It forces the web page rendering, since it is monadic so it can contain
4254++-- side effects and load effects to be tested.
4255++askt :: (MonadIO m, FormInput v) => (Int -> a) -> View v m a -> FlowM v m a
4257++ FormElm forms mx <- FlowM . lift $ runView w
4258++ n <- getTestNumber
4259++ let l= B.length $ toByteString forms
4260++ breturn $ l `seq` mx `seq` v n
4262++--mvtestopts :: MVar (M.Map String (Int,Dynamic))
4263++--mvtestopts = unsafePerformIO $ newMVar M.empty
4265++--asktn :: (Typeable a,MonadIO m) => [a] -> View v m a -> FlowM v m a
4267++-- v <- liftIO $ do
4268++-- let k = addrStr xs
4269++-- opts <- takeMVar mvtestopts
4270++-- let r = M.lookup k opts
4273++-- putMVar mvtestopts $ M.singleton k (0,toDyn xs)
4274++-- return $ head xs
4275++-- Just (i,d) -> do
4276++-- putMVar mvtestopts $ M.insert k (i+1,d) opts
4277++-- return $ (fromMaybe (error err1) $ fromDynamic d) !! i
4282++-- err1= "MFlow.Forms.Test: asktn: fromDynamic error"
4285++-- | verify a property. if not true, throw the error message.
4287++-- It is intended to be used in a infix notation, on the right of the code,
4288++-- in order to separate the code assertions from the application code and make clearly
4289++-- visible them as a form of documentation.
4290++-- separated from it:
4292++-- > liftIO $ print (x :: Int) `verify` (return $ x > 10, "x < = 10")
4294++-- the expression is monadic to allow for complex verifications that may involve IO actions
4295++verifyM :: Monad m => m b -> (m Bool, String) -> m b
4296++verifyM f (mprop, msg)= do
4300++ False -> error msg
4302++-- | a pure version of verifyM
4303++verify :: a -> (Bool, String) -> a
4304++verify f (prop, msg)= do
4307++ False -> error msg
4312++-- marches <- readIORef matches
4313++-- return $ head map (m s) matches
4315++-- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of
4317++-- False -> Nothing
4319++--composeParams (Gen ps) form= zip (getParams form) ps
4322++-- let search name form
4323++-- | null form = mempty
4324++-- | isPrefix name form = drop (length name) form
4325++-- | otherwise= search name $ tail form
4327++-- par s= takeWhile(/='\"') . dropWhile (/='\"') . tail . dropWhile (/='=') $ s
4328++-- getPar= par $ search "name"
4332++waction :: (Functor m, MonadIO m,Generate a, FormInput view)
4334++ -> (a -> FlowM view m b)
4337++ x <- liftIO generate
4338++ MFlow.Forms.waction (return x) f
4340++userWidget :: ( MonadIO m, Functor m
4343++ -> View view m (Maybe (String,String), Maybe String)
4344++ -> View view m String
4345++userWidget muser formuser= do
4346++ user <- getCurrentUser
4347++ if muser== Just user then return user
4348++ else if isJust muser then do
4349++ let user= fromJust muser
4350++ login user >> return user
4351++ else liftIO generate >>= \u -> login u >> return u
4356++ let t = mfToken st
4357++ t'= t{tuser= uname}
4358++ put st{mfToken= t'}
4361++getUserSimple :: ( MonadIO m, FormInput view, Typeable view
4363++ => FlowM view m String
4364++getUserSimple= getUser Nothing userFormLine
4367++getUser :: ( FormInput view, Typeable view
4368++ , Functor m,MonadIO m)
4370++ -> View view m (Maybe (String,String), Maybe String)
4371++ -> FlowM view m String
4372++getUser mu form= ask $ userWidget mu form
4375++-- :: (Functor m, MonadIO m, FormInput v, Generate (Maybe a)) =>
4377++-- -> ([v] -> Maybe a -> WState v m ([v], Maybe b))
4379++--wmodify formt act = do
4380++-- x <- liftIO generate
4381++-- formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act
4385++data Test= Test{tflink:: [(Var,String)]
4386++ ,selectOptions :: [(Var,[String])]
4387++ ,tfinput :: [(Var, String)]
4388++ ,tftextarea :: [(Var, String)]
4390++ deriving(Read,Show)
4392++type TestM = Test -> Test
4394++instance Monoid TestM where
4398++instance FormInput TestM where
4401++ fromStr = const id
4402++ flink var _= let(n,v)=break (=='=') var in \t ->t{tflink= (n,tail v):tflink t}
4403++ finput n _ v _ _ = \t -> t{tfinput = (n,v):tfinput t}
4404++ ftextarea n v= \t -> t{tftextarea = (n,v):tftextarea t}
4405++ fselect n _= \t -> t{selectOptions=(n,[]):selectOptions t}
4406++ foption o _ _= \t ->
4407++ let (n,opts)= head $ selectOptions t
4408++ in t{selectOptions=(n,o:opts):tail (selectOptions t)}
4409++ formAction _ _= id
4410++ addAttributes _ _= id
4412++generateGenerate Test{..}= do
4420++ -- one on every generate is incomplete
4421++ n <- randomRIO(0,10) :: IO Int
4430++ return $ r1++r2++r3
4432++ let n = length tflink
4433++ if n == 0 then genForm
4435++ r <- randomRIO(0,n )
4436++ return [tflink !! r]
4439++ let n = length selectOptions
4442++ else mapM gen selectOptions
4446++ j <- randomRIO(0,m)
4447++ return (s, os !! j)
4450++ let n = length tftextarea
4453++ else mapM gen tfinput
4454++ where gen(n,_)= do
4459++ let n = length tfinput
4462++ else mapM gen tftextarea
4470++instance Processable Params where
4471++ pwfname = fromMaybe noScript . lookup pwf
4472++ puser= fromMaybe anonymous . lookup cookieuser
4473++ pind = fromMaybe "0" . lookup ind
4478++runTest nusers = do
4479++ wfs <- getMessageFlows
4480++ replicateM nusers $ gen wfs
4484++ mapM (genTraffic u) $ M.toList wfs
4486++ genTraffic u (n,_)= forkIO $ iterategenerates [(pwf,n),(cookieuser,u)] []
4488++ iterategenerates ident msg= iterate [] msg
4490++ iterate cs msg= do
4491++ (HttpData ps cooks test,_) <- msgScheduler $ ident ++ cs++ msg
4492++ let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks
4493++ resp <- generateGenerate . read $ B.unpack test
4497+diff -ru orig/src/MFlow/Forms/Widgets.hs new/src/MFlow/Forms/Widgets.hs
4498+--- orig/src/MFlow/Forms/Widgets.hs 2014-06-10 05:51:26.977015856 +0300
4499++++ new/src/MFlow/Forms/Widgets.hs 2014-06-10 05:51:25.000000000 +0300
4503+-Some dynamic widgets, widgets that dynamically edit content in other widgets,
4504+-widgets for templating, content management and multilanguage. And some primitives
4505+-to create other active widgets.
4509++Some dynamic widgets, widgets that dynamically edit content in other widgets,
4510++widgets for templating, content management and multilanguage. And some primitives
4511++to create other active widgets.
4513+ -- {-# OPTIONS -F -pgmF cpphs #-}
4514+-{-# OPTIONS -cpp -pgmPcpphs -optP--cpp #-}
4515+-{-# LANGUAGE UndecidableInstances,ExistentialQuantification
4516+- , FlexibleInstances, OverlappingInstances, FlexibleContexts
4517++{-# OPTIONS -cpp -pgmPcpphs -optP--cpp #-}
4518++{-# LANGUAGE UndecidableInstances,ExistentialQuantification
4519++ , FlexibleInstances, OverlappingInstances, FlexibleContexts
4520+ , OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables
4521+- , StandaloneDeriving #-}
4526+-module MFlow.Forms.Widgets (
4527+--- * Ajax refreshing of widgets
4528+-autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..), lazy
4530+--- * JQueryUi widgets
4531+-,datePicker, getSpinner, wautocomplete, wdialog,
4533+--- * User Management
4534+-userFormOrName,maybeLogout, wlogin,
4536+--- * Active widgets
4537+-wEditList,wautocompleteList
4538+-, wautocompleteEdit,
4540+--- * Editing widgets
4541+-delEdited, getEdited, setEdited, prependWidget,appendWidget,setWidget
4543+--- * Content Management
4544+-,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey
4550+-,insertForm, readtField, writetField
4556+-import MFlow.Forms.Internals
4558++ , StandaloneDeriving #-}
4563++module MFlow.Forms.Widgets (
4564++-- * Ajax refreshing of widgets
4565++autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..), lazy
4567++-- * JQueryUi widgets
4568++,datePicker, getSpinner, wautocomplete, wdialog,
4570++-- * User Management
4571++userFormOrName,maybeLogout, wlogin,
4573++-- * Active widgets
4574++wEditList,wautocompleteList
4575++, wautocompleteEdit,
4577++-- * Editing widgets
4578++delEdited, getEdited, setEdited, prependWidget,appendWidget,setWidget
4580++-- * Content Management
4581++,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey
4587++,insertForm, readtField, writetField
4593++import MFlow.Forms.Internals
4595+ import Data.ByteString.Lazy.UTF8 as B hiding (length,span)
4596+-import Data.ByteString.Lazy.Char8 (unpack)
4597+-import Control.Monad.Trans
4598+-import Data.Typeable
4600+-import System.IO.Unsafe
4602+-import Control.Monad.State
4604+-import Data.TCache.Defs
4605+-import Data.TCache.Memoization
4606+-import Data.RefSerialize hiding ((<|>))
4607+-import qualified Data.Map as M
4609+-import MFlow.Cookies
4612+-import Control.Monad.Identity
4613+-import Control.Workflow(killWF)
4614+-import Unsafe.Coerce
4615+-import Control.Exception
4616++import Data.ByteString.Lazy.Char8 (unpack)
4617++import Control.Monad.Trans
4618++import Data.Typeable
4620++import System.IO.Unsafe
4622++import Control.Monad.State
4624++import Data.TCache.Defs
4625++import Data.TCache.Memoization
4626++import Data.RefSerialize hiding ((<|>))
4627++import qualified Data.Map as M
4629++import MFlow.Cookies
4632++import Control.Monad.Identity
4633++import Control.Workflow(killWF)
4634++import Unsafe.Coerce
4635++import Control.Exception
4636+ import MFlow.Forms.Cache
4640+---jqueryScript= "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
4641+---jqueryScript1="//code.jquery.com/jquery-1.9.1.js"
4643+---jqueryCSS1= "//code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"
4644+---jqueryCSS= "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
4646+---jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js"
4647+---jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js"
4649+-jqueryScript= getConfig "cjqueryScript" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
4650+-jqueryCSS= getConfig "cjqueryCSS" "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
4651+-jqueryUI= getConfig "cjqueryUI" "//code.jquery.com/ui/1.10.3/jquery-ui.js"
4652+-nicEditUrl= getConfig "cnicEditUrl" "//js.nicedit.com/nicEdit-latest.js"
4653+-------- User Management ------
4655+--- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented.
4656+--- The paremeters and the behaviour are the same as 'userWidget'.
4657+--- Only the display is different
4658+-userFormOrName mode wid= userWidget mode wid `wmodify` f <** maybeLogout
4660+- f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input"
4661+- f felem Nothing = do
4662+- us <- getCurrentUser -- getEnv cookieuser
4663+- if us == anonymous
4664+- then return (felem, Nothing)
4665+- else return([fromStr us], Just us)
4667+--- | Display a logout link if the user is logged. Nothing otherwise
4668+-maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m ()
4670+- us <- getCurrentUser
4673+- cmd <- ajax $ const $ return "window.location=='/'" --refresh
4674+- fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout
4678++--jqueryScript= "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
4679++--jqueryScript1="//code.jquery.com/jquery-1.9.1.js"
4681++--jqueryCSS1= "//code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"
4682++--jqueryCSS= "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
4684++--jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js"
4685++--jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js"
4687++jqueryScript= getConfig "cjqueryScript" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
4688++jqueryCSS= getConfig "cjqueryCSS" "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
4689++jqueryUI= getConfig "cjqueryUI" "//code.jquery.com/ui/1.10.3/jquery-ui.js"
4690++nicEditUrl= getConfig "cnicEditUrl" "//js.nicedit.com/nicEdit-latest.js"
4691++------- User Management ------
4693++-- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented.
4694++-- The paremeters and the behaviour are the same as 'userWidget'.
4695++-- Only the display is different
4696++userFormOrName mode wid= userWidget mode wid `wmodify` f <** maybeLogout
4698++ f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input"
4699++ f felem Nothing = do
4700++ us <- getCurrentUser -- getEnv cookieuser
4701++ if us == anonymous
4702++ then return (felem, Nothing)
4703++ else return([fromStr us], Just us)
4705++-- | Display a logout link if the user is logged. Nothing otherwise
4706++maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m ()
4708++ us <- getCurrentUser
4711++ cmd <- ajax $ const $ return "window.location=='/'" --refresh
4712++ fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout
4717+ data Medit view m a = Medit (M.Map B.ByteString [(String,View view m a)])
4719+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4720+@@ -129,46 +129,46 @@
4721+ ta :: Medit v m a -> a
4726+--- | If not logged, it present a page flow which askm for the user name, then the password if not logged
4728+--- If logged, it present the user name and a link to logout
4730+--- normally to be used with autoRefresh and pageFlow when used with other widgets.
4731+-wlogin :: (MonadIO m,Functor m,FormInput v) => View v m ()
4733+- username <- getCurrentUser
4734+- if username /= anonymous
4737++-- | If not logged, it present a page flow which askm for the user name, then the password if not logged
4739++-- If logged, it present the user name and a link to logout
4741++-- normally to be used with autoRefresh and pageFlow when used with other widgets.
4742++wlogin :: (MonadIO m,Functor m,FormInput v) => View v m ()
4744++ username <- getCurrentUser
4745++ if username /= anonymous
4747+ private; noCache;noStore
4752+ name <- getString Nothing <! hint "login name"
4754+- <++ ftag "br" mempty
4755++ <++ ftag "br" mempty
4756+ pass <- getPassword <! hint "password"
4758+- <++ ftag "br" mempty
4759+- <** submitButton "login"
4760+- val <- userValidate (name,pass)
4762+- Just msg -> notValid msg
4763+- Nothing -> login name >> (return name)
4765+- `wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name++ " ")
4766+- ++> pageFlow "logout" (submitButton "logout")) -- wlink ("logout" :: String) (ftag "b" $ fromStr " logout"))
4767+- `wcallback` const (logout >> wlogin)
4769+-focus = [("onload","this.focus()")]
4770+-hint s= [("placeholder",s)]
4771+-size n= [("size",show n)]
4774+- Medit stored <- getSessionData `onNothing` return (Medit M.empty)
4775+- return $ fromMaybe [] $ M.lookup id stored
4777+--- | Return the list of edited widgets (added by the active widgets) for a given identifier
4779++ <++ ftag "br" mempty
4780++ <** submitButton "login"
4781++ val <- userValidate (name,pass)
4783++ Just msg -> notValid msg
4784++ Nothing -> login name >> (return name)
4786++ `wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name++ " ")
4787++ ++> pageFlow "logout" (submitButton "logout")) -- wlink ("logout" :: String) (ftag "b" $ fromStr " logout"))
4788++ `wcallback` const (logout >> wlogin)
4790++focus = [("onload","this.focus()")]
4791++hint s= [("placeholder",s)]
4792++size n= [("size",show n)]
4795++ Medit stored <- getSessionData `onNothing` return (Medit M.empty)
4796++ return $ fromMaybe [] $ M.lookup id stored
4798++-- | Return the list of edited widgets (added by the active widgets) for a given identifier
4801+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4802+@@ -181,15 +181,15 @@
4806+- B.ByteString -> m [View v m1 a]
4807++ B.ByteString -> m [View v m1 a]
4810++ r <- getEdited1 id
4811++ let (_,ws)= unzip r
4815+- r <- getEdited1 id
4816+- let (_,ws)= unzip r
4819+--- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter
4821++-- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter
4823+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4824+ :: (Typeable v, Typeable a, MonadIO m, Typeable m1,
4826+@@ -197,312 +197,312 @@
4828+ MonadState (MFlowState view) m)
4829+ => B.ByteString -- ^ identifier
4830+- -> [View v m1 a] -> m () -- ^ withess
4831+-delEdited id witness=do
4832+- Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
4833+- let (ks, ws)= unzip $ fromMaybe [] $ M.lookup id stored
4835+- return $ ws `asTypeOf` witness
4836+- liftIO $ mapM flushCached ks
4837+- let stored'= M.delete id stored
4838+- setSessionData . Medit $ stored'
4842+--- setEdited id ([] `asTypeOf` (zip (repeat "") witness))
4844+-setEdited id ws= do
4845+- Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
4846+- let stored'= M.insert id ws stored
4847+- setSessionData . Medit $ stored'
4851+- ws <- getEdited1 id
4852+- setEdited id (w:ws)
4854++ -> [View v m1 a] -> m () -- ^ withess
4855++delEdited id witness=do
4856++ Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
4857++ let (ks, ws)= unzip $ fromMaybe [] $ M.lookup id stored
4859++ return $ ws `asTypeOf` witness
4860++ liftIO $ mapM flushCached ks
4861++ let stored'= M.delete id stored
4862++ setSessionData . Medit $ stored'
4866++-- setEdited id ([] `asTypeOf` (zip (repeat "") witness))
4868++setEdited id ws= do
4869++ Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
4870++ let stored'= M.insert id ws stored
4871++ setSessionData . Medit $ stored'
4875++ ws <- getEdited1 id
4876++ setEdited id (w:ws)
4878+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4879+ modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v, Typeable Identity, Typeable m)
4881+-modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)
4883++modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)
4885+- => B.ByteString -> B.ByteString -> View v Identity a -> View v m B.ByteString
4886+-modifyWidget selector modifier w = View $ do
4887+- ws <- getEdited selector
4888+- let n = length (ws `asTypeOf` [w])
4889+- let key= "widget"++ show selector ++ show n ++ show (typeOf $ typ w)
4890+- let cw = wcached key 0 w
4891+- addEdited selector (key,cw)
4892+- FormElm form _ <- runView cw
4893+- let elem= toByteString form
4894+- return . FormElm mempty . Just $ selector <> "." <> modifier <>"('" <> elem <> "');"
4896+- typ :: View v Identity a -> a
4899+--- | Return the javascript to be executed on the browser to prepend a widget to the location
4900+--- identified by the selector (the bytestring parameter), The selector must have the form of a jquery expression
4901+--- . It stores the added widgets in the edited list, that is accessed with 'getEdited'
4903+--- The resulting string can be executed in the browser. 'ajax' will return the code to
4904+--- execute the complete ajax roundtrip. This code returned by ajax must be in an eventhabdler.
4906+--- This example will insert a widget in the div when the element with identifier
4907+--- /clickelem/ is clicked. when the form is sbmitted, the widget values are returned
4908+--- and the list of edited widgets are deleted.
4910+--- > id1<- genNewId
4911+--- > let sel= "$('#" <> fromString id1 <> "')"
4912+--- > callAjax <- ajax . const $ prependWidget sel wn
4913+--- > let installevents= "$(document).ready(function(){\
4914+--- > \$('#clickelem').click(function(){"++callAjax "''"++"});})"
4916+--- > requires [JScriptFile jqueryScript [installevents] ]
4917+--- > ws <- getEdited sel
4918+--- > r <- (div <<< manyOf ws) <! [("id",id1)]
4919+--- > delEdited sel ws'
4922++ => B.ByteString -> B.ByteString -> View v Identity a -> View v m B.ByteString
4923++modifyWidget selector modifier w = View $ do
4924++ ws <- getEdited selector
4925++ let n = length (ws `asTypeOf` [w])
4926++ let key= "widget"++ show selector ++ show n ++ show (typeOf $ typ w)
4927++ let cw = wcached key 0 w
4928++ addEdited selector (key,cw)
4929++ FormElm form _ <- runView cw
4930++ let elem= toByteString form
4931++ return . FormElm mempty . Just $ selector <> "." <> modifier <>"('" <> elem <> "');"
4933++ typ :: View v Identity a -> a
4936++-- | Return the javascript to be executed on the browser to prepend a widget to the location
4937++-- identified by the selector (the bytestring parameter), The selector must have the form of a jquery expression
4938++-- . It stores the added widgets in the edited list, that is accessed with 'getEdited'
4940++-- The resulting string can be executed in the browser. 'ajax' will return the code to
4941++-- execute the complete ajax roundtrip. This code returned by ajax must be in an eventhabdler.
4943++-- This example will insert a widget in the div when the element with identifier
4944++-- /clickelem/ is clicked. when the form is sbmitted, the widget values are returned
4945++-- and the list of edited widgets are deleted.
4947++-- > id1<- genNewId
4948++-- > let sel= "$('#" <> fromString id1 <> "')"
4949++-- > callAjax <- ajax . const $ prependWidget sel wn
4950++-- > let installevents= "$(document).ready(function(){\
4951++-- > \$('#clickelem').click(function(){"++callAjax "''"++"});})"
4953++-- > requires [JScriptFile jqueryScript [installevents] ]
4954++-- > ws <- getEdited sel
4955++-- > r <- (div <<< manyOf ws) <! [("id",id1)]
4956++-- > delEdited sel ws'
4960+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4961+ :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m)
4964+ :: (Typeable a, MonadIO m, Executable m, FormInput v)
4966+- => B.ByteString -- ^ jquery selector
4967+- -> View v Identity a -- ^ widget to prepend
4968+- -> View v m B.ByteString -- ^ string returned with the jquery string to be executed in the browser
4969+-prependWidget sel w= modifyWidget sel "prepend" w
4971+--- | Like 'prependWidget' but append the widget instead of prepend.
4974++ => B.ByteString -- ^ jquery selector
4975++ -> View v Identity a -- ^ widget to prepend
4976++ -> View v m B.ByteString -- ^ string returned with the jquery string to be executed in the browser
4977++prependWidget sel w= modifyWidget sel "prepend" w
4979++-- | Like 'prependWidget' but append the widget instead of prepend.
4981+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4982+ :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) =>
4984+ :: (Typeable a, MonadIO m, Executable m, FormInput v) =>
4986+- B.ByteString -> View v Identity a -> View v m B.ByteString
4987+-appendWidget sel w= modifyWidget sel "append" w
4989+--- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element
4991++ B.ByteString -> View v Identity a -> View v m B.ByteString
4992++appendWidget sel w= modifyWidget sel "append" w
4994++-- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element
4996+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4997+ :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable m, Typeable Identity) =>
4999+ :: (Typeable a, MonadIO m, Executable m, FormInput v) =>
5001+- B.ByteString -> View v Identity a -> View v m B.ByteString
5002+-setWidget sel w= modifyWidget sel "html" w
5005+--- | Inside a tag, it add and delete widgets of the same type. When the form is submitted
5006+--- or a wlink is pressed, this widget return the list of validated widgets.
5007+--- the event for adding a new widget is attached , as a click event to the element of the page with the identifier /wEditListAdd/
5008+--- that the user will choose.
5010+--- This example add or delete editable text boxes, with two initial boxes with
5011+--- /hi/, /how are you/ as values. Tt uses blaze-html:
5013+--- > r <- ask $ addLink
5015+--- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid"
5017+--- > <** submitButton "send"
5019+--- > ask $ p << (show r ++ " returned")
5020+--- > ++> wlink () (p << text " back to menu")
5023+--- > addLink = a ! At.id "addid"
5026+--- > delBox = input ! type_ "checkbox"
5028+--- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"
5029+--- > getString1 mx= El.div <<< delBox ++> getString mx <++ br
5031+-wEditList :: (Typeable a,Read a
5033++ B.ByteString -> View v Identity a -> View v m B.ByteString
5034++setWidget sel w= modifyWidget sel "html" w
5037++-- | Inside a tag, it add and delete widgets of the same type. When the form is submitted
5038++-- or a wlink is pressed, this widget return the list of validated widgets.
5039++-- the event for adding a new widget is attached , as a click event to the element of the page with the identifier /wEditListAdd/
5040++-- that the user will choose.
5042++-- This example add or delete editable text boxes, with two initial boxes with
5043++-- /hi/, /how are you/ as values. Tt uses blaze-html:
5045++-- > r <- ask $ addLink
5047++-- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid"
5049++-- > <** submitButton "send"
5051++-- > ask $ p << (show r ++ " returned")
5052++-- > ++> wlink () (p << text " back to menu")
5055++-- > addLink = a ! At.id "addid"
5058++-- > delBox = input ! type_ "checkbox"
5060++-- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"
5061++-- > getString1 mx= El.div <<< delBox ++> getString mx <++ br
5063++wEditList :: (Typeable a,Read a
5065+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
5066+ ,Functor m,MonadIO m, Executable m, Typeable m, Typeable Identity)
5069+ ,Functor m,MonadIO m, Executable m)
5071+- => (view ->view) -- ^ The holder tag
5072+- -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string
5073+- -> [String] -- ^ The initial list of values.
5074+- -> String -- ^ The id of the button or link that will create a new list element when clicked
5075+- -> View view m [a]
5076+-wEditList holderview w xs addId = do
5077+- let ws= map (w . Just) xs
5080+- let sel= "$('#" <> fromString id1 <> "')"
5081+- callAjax <- ajax . const $ prependWidget sel wn
5082+- let installevents= "$(document).ready(function(){$('#"++addId++"').click(function(){"++callAjax "''"++"});})"
5084+- requires [JScriptFile jqueryScript [installevents] ]
5086+- ws' <- getEdited sel
5088+- r <- (holderview <<< (allOf $ ws' ++ map changeMonad ws)) <! [("id",id1)]
5095+--- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box.
5097+- :: (Show a, MonadIO m, FormInput v)
5098+- => Maybe String -- ^ Initial value
5099+- -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings
5100+- -> View v m String
5101+-wautocomplete mv autocomplete = do
5103+- ajaxc <- ajax $ \u -> do
5104+- r <- liftIO $ autocomplete u
5105+- return $ jaddtoautocomp text1 r
5108+- requires [JScriptFile jqueryScript [] -- [events]
5109+- ,CSSFile jqueryCSS
5110+- ,JScriptFile jqueryUI []]
5113+- getString mv <! [("type", "text")
5115+- ,("oninput", ajaxc $ "$('#"++text1++"').attr('value')" )
5116+- ,("autocomplete", "off")]
5120+- jaddtoautocomp text1 us= "$('#"<>fromString text1<>"').autocomplete({ source: " <> fromString( show us) <> " });"
5123+--- | Produces a text box. It gives a autocompletion list to the textbox. When return
5124+--- is pressed in the textbox, the box content is used to create a widget of a kind defined
5125+--- by the user, which will be situated above of the textbox. When submitted, the result is the content
5126+--- of the created widgets (the validated ones).
5128+--- 'wautocompleteList' is an specialization of this widget, where
5129+--- the widget parameter is fixed, with a checkbox that delete the eleement when unselected
5130+--- . This fixed widget is as such (using generic 'FormElem' class tags):
5132+--- > ftag "div" <<< ftag "input" mempty
5133+--- > `attrs` [("type","checkbox")
5134+--- > ,("checked","")
5135+--- > ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
5136+--- > ++> ftag "span" (fromStr $ fromJust x )
5137+--- > ++> whidden( fromJust x)
5140++ => (view ->view) -- ^ The holder tag
5141++ -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string
5142++ -> [String] -- ^ The initial list of values.
5143++ -> String -- ^ The id of the button or link that will create a new list element when clicked
5144++ -> View view m [a]
5145++wEditList holderview w xs addId = do
5146++ let ws= map (w . Just) xs
5149++ let sel= "$('#" <> fromString id1 <> "')"
5150++ callAjax <- ajax . const $ prependWidget sel wn
5151++ let installevents= "$(document).ready(function(){$('#"++addId++"').click(function(){"++callAjax "''"++"});})"
5153++ requires [JScriptFile jqueryScript [installevents] ]
5155++ ws' <- getEdited sel
5157++ r <- (holderview <<< (allOf $ ws' ++ map changeMonad ws)) <! [("id",id1)]
5164++-- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box.
5166++ :: (Show a, MonadIO m, FormInput v)
5167++ => Maybe String -- ^ Initial value
5168++ -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings
5169++ -> View v m String
5170++wautocomplete mv autocomplete = do
5172++ ajaxc <- ajax $ \u -> do
5173++ r <- liftIO $ autocomplete u
5174++ return $ jaddtoautocomp text1 r
5177++ requires [JScriptFile jqueryScript [] -- [events]
5178++ ,CSSFile jqueryCSS
5179++ ,JScriptFile jqueryUI []]
5182++ getString mv <! [("type", "text")
5184++ ,("oninput", ajaxc $ "$('#"++text1++"').attr('value')" )
5185++ ,("autocomplete", "off")]
5189++ jaddtoautocomp text1 us= "$('#"<>fromString text1<>"').autocomplete({ source: " <> fromString( show us) <> " });"
5192++-- | Produces a text box. It gives a autocompletion list to the textbox. When return
5193++-- is pressed in the textbox, the box content is used to create a widget of a kind defined
5194++-- by the user, which will be situated above of the textbox. When submitted, the result is the content
5195++-- of the created widgets (the validated ones).
5197++-- 'wautocompleteList' is an specialization of this widget, where
5198++-- the widget parameter is fixed, with a checkbox that delete the eleement when unselected
5199++-- . This fixed widget is as such (using generic 'FormElem' class tags):
5201++-- > ftag "div" <<< ftag "input" mempty
5202++-- > `attrs` [("type","checkbox")
5203++-- > ,("checked","")
5204++-- > ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
5205++-- > ++> ftag "span" (fromStr $ fromJust x )
5206++-- > ++> whidden( fromJust x)
5208+ :: (Typeable a, MonadIO m,Functor m, Executable m
5209+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
5210+ , FormInput v, Typeable m, Typeable Identity)
5215+- => String -- ^ the initial text of the box
5216+- -> (String -> IO [String]) -- ^ the autocompletion procedure: receives a prefix, return a list of options.
5217+- -> (Maybe String -> View v Identity a) -- ^ the widget to add, initialized with the string entered in the box
5218+- -> [String] -- ^ initial set of values
5219+- -> View v m [a] -- ^ resulting widget
5220+-wautocompleteEdit phold autocomplete elem values= do
5222+- let textx= id1++"text"
5223+- let sel= "$('#" <> fromString id1 <> "')"
5224+- ajaxc <- ajax $ \(c:u) ->
5226+- 'f' -> prependWidget sel (elem $ Just u)
5228+- r <- liftIO $ autocomplete u
5229+- return $ jaddtoautocomp textx r
5232+- requires [JScriptFile jqueryScript [events textx ajaxc]
5233+- ,CSSFile jqueryCSS
5234+- ,JScriptFile jqueryUI []]
5236+- ws' <- getEdited sel
5238+- r<- (ftag "div" mempty `attrs` [("id", id1)]
5239+- ++> allOf (ws' ++ (map (changeMonad . elem . Just) values)))
5240+- <++ ftag "input" mempty
5241+- `attrs` [("type", "text")
5243+- ,("placeholder", phold)
5244+- ,("oninput", ajaxc $ "'n'+$('#"++textx++"').val()" )
5245+- ,("autocomplete", "off")]
5249+- events textx ajaxc=
5250+- "$(document).ready(function(){ \
5251+- \$('#"++textx++"').keydown(function(){ \
5252+- \if(event.keyCode == 13){ \
5253+- \var v= $('#"++textx++"').val(); \
5254+- \if(event.preventDefault) event.preventDefault();\
5255+- \else if(event.returnValue) event.returnValue = false;" ++
5256+- ajaxc "'f'+v"++";"++
5257+- " $('#"++textx++"').val('');\
5262+- jaddtoautocomp textx us= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> " });"
5264++ => String -- ^ the initial text of the box
5265++ -> (String -> IO [String]) -- ^ the autocompletion procedure: receives a prefix, return a list of options.
5266++ -> (Maybe String -> View v Identity a) -- ^ the widget to add, initialized with the string entered in the box
5267++ -> [String] -- ^ initial set of values
5268++ -> View v m [a] -- ^ resulting widget
5269++wautocompleteEdit phold autocomplete elem values= do
5271++ let textx= id1++"text"
5272++ let sel= "$('#" <> fromString id1 <> "')"
5273++ ajaxc <- ajax $ \(c:u) ->
5275++ 'f' -> prependWidget sel (elem $ Just u)
5277++ r <- liftIO $ autocomplete u
5278++ return $ jaddtoautocomp textx r
5281++ requires [JScriptFile jqueryScript [events textx ajaxc]
5282++ ,CSSFile jqueryCSS
5283++ ,JScriptFile jqueryUI []]
5285++ ws' <- getEdited sel
5287++ r<- (ftag "div" mempty `attrs` [("id", id1)]
5288++ ++> allOf (ws' ++ (map (changeMonad . elem . Just) values)))
5289++ <++ ftag "input" mempty
5290++ `attrs` [("type", "text")
5292++ ,("placeholder", phold)
5293++ ,("oninput", ajaxc $ "'n'+$('#"++textx++"').val()" )
5294++ ,("autocomplete", "off")]
5298++ events textx ajaxc=
5299++ "$(document).ready(function(){ \
5300++ \$('#"++textx++"').keydown(function(){ \
5301++ \if(event.keyCode == 13){ \
5302++ \var v= $('#"++textx++"').val(); \
5303++ \if(event.preventDefault) event.preventDefault();\
5304++ \else if(event.returnValue) event.returnValue = false;" ++
5305++ ajaxc "'f'+v"++";"++
5306++ " $('#"++textx++"').val('');\
5311++ jaddtoautocomp textx us= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> " });"
5314+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
5315+ deriving instance Typeable Identity
5318+--- | A specialization of 'wutocompleteEdit' which make appear each chosen option with
5319+--- a checkbox that deletes the element when uncheched. The result, when submitted, is the list of selected elements.
5321++-- | A specialization of 'wutocompleteEdit' which make appear each chosen option with
5322++-- a checkbox that deletes the element when uncheched. The result, when submitted, is the list of selected elements.
5324+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
5325+ :: (Functor m, MonadIO m, Executable m, FormInput v, Typeable m, Typeable Identity) =>
5328+ :: (Functor m, MonadIO m, Executable m, FormInput v) =>
5330+- String -> (String -> IO [String]) -> [String] -> View v m [String]
5331+-wautocompleteList phold serverproc values=
5332+- wautocompleteEdit phold serverproc wrender1 values
5334+- wrender1 x= ftag "div" <<< ftag "input" mempty
5335+- `attrs` [("type","checkbox")
5337+- ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
5338+- ++> ftag "span" (fromStr $ fromJust x )
5339+- ++> whidden( fromJust x)
5341+-------- Templating and localization ---------
5343+-data TField = TField {tfieldKey :: Key, tfieldContent :: B.ByteString} deriving (Read, Show,Typeable)
5345+-instance Indexable TField where
5346+- key (TField k _)= k
5347+- defPath _= "texts/"
5350+-instance Serializable TField where
5351+- serialize (TField k content) = content
5352+- deserialKey k content= TField k content -- applyDeserializers [des1,des2] k bs
5355+- setPersist = \_ -> Just filePersist
5359+-writetField k s= atomically $ writeDBRef (getDBRef k) $ TField k $ toByteString s
5362+-readtField text k= atomically $ do
5363+- let ref = getDBRef k
5364+- mr <- readDBRef ref
5366+- Just (TField k v) -> if v /= mempty then return $ fromStrNoEncode $ toString v else return text
5367+- Nothing -> return text
5370++ String -> (String -> IO [String]) -> [String] -> View v m [String]
5371++wautocompleteList phold serverproc values=
5372++ wautocompleteEdit phold serverproc wrender1 values
5374++ wrender1 x= ftag "div" <<< ftag "input" mempty
5375++ `attrs` [("type","checkbox")
5377++ ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
5378++ ++> ftag "span" (fromStr $ fromJust x )
5379++ ++> whidden( fromJust x)
5381++------- Templating and localization ---------
5383++data TField = TField {tfieldKey :: Key, tfieldContent :: B.ByteString} deriving (Read, Show,Typeable)
5385++instance Indexable TField where
5386++ key (TField k _)= k
5387++ defPath _= "texts/"
5390++instance Serializable TField where
5391++ serialize (TField k content) = content
5392++ deserialKey k content= TField k content -- applyDeserializers [des1,des2] k bs
5395++ setPersist = \_ -> Just filePersist
5399++writetField k s= atomically $ writeDBRef (getDBRef k) $ TField k $ toByteString s
5402++readtField text k= atomically $ do
5403++ let ref = getDBRef k
5404++ mr <- readDBRef ref
5406++ Just (TField k v) -> if v /= mempty then return $ fromStrNoEncode $ toString v else return text
5407++ Nothing -> return text
5409+ -- | Creates a rich text editor aroun a text field or a text area widget.
5412+@@ -512,221 +512,224 @@
5413+ -- > <** submitButton "enter"
5415+ -- Creates a rich text area with bold and italic buttons. The buttons are the ones alled
5416+--- in the nicEdit editor.
5417+-htmlEdit :: (Monad m, FormInput v) => [String] -> UserStr -> View v m a -> View v m a
5418+-htmlEdit buttons jsuser w = do
5421+- let installHtmlField=
5422+- "\nfunction installHtmlField(muser,cookieuser,name,buttons){\
5423+- \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\
5424+- \bkLib.onDomLoaded(function() {\
5425+- \var myNicEditor = new nicEditor({buttonList : buttons});\
5426+- \myNicEditor.panelInstance(name);\
5428+- install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"
5430+- requires [JScriptFile nicEditUrl [installHtmlField,install]]
5436+--- | A widget that display the content of an html, But if the user has edition privileges,
5437+--- it permits to edit it in place. So the editor could see the final appearance
5438+--- of what he writes.
5440+--- When the user click the save, the content is saved and
5441+--- identified by the key. Then, from now on, all the users will see the saved
5442+--- content instead of the code content.
5444+--- The content is saved in a file by default (/texts/ in this versions), but there is
5445+--- a configurable version (`tFieldGen`). The content of the element and the formatting
5446+--- is cached in memory, so the display is, theoretically, very fast.
5450+- :: (Functor m, MonadIO m, Executable m,
5452+- UserStr -> Key -> v -> View v m ()
5453+-tFieldEd muser k text= wfreeze k 0 $ do
5454+- content <- liftIO $ readtField text k
5456+- let ipanel= nam++"panel"
5458+- install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
5459+- getTexts :: (Token -> IO ())
5460+- getTexts token = do
5461+- let (k,s):_ = tenv token
5463+- writetField k $ (fromStrNoEncode s `asTypeOf` text)
5465+- sendFlush token $ HttpData [] [] ""
5468+- requires [JScriptFile nicEditUrl [install]
5469+- ,JScript ajaxSendText
5470+- ,JScript installEditField
5471+--- ,JScriptFile jqueryScript []
5472+- ,ServerProc ("_texts", transient getTexts)]
5473++-- in the nicEdit editor.
5474++htmlEdit :: (Monad m, FormInput v) => [String] -> UserStr -> View v m a -> View v m a
5475++htmlEdit buttons jsuser w = do
5478++ let installHtmlField=
5479++ "\nfunction installHtmlField(muser,cookieuser,name,buttons){\
5480++ \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\
5481++ \bkLib.onDomLoaded(function() {\
5482++ \var myNicEditor = new nicEditor({buttonList : buttons});\
5483++ \myNicEditor.panelInstance(name);\
5485++ install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"
5487++ requires [JScript installHtmlField ,JScriptFile nicEditUrl [install]]
5493++-- | A widget that display the content of an html, But if the user has edition privileges,
5494++-- it permits to edit it in place. So the editor could see the final appearance
5495++-- of what he writes.
5497++-- When the user click the save, the content is saved and
5498++-- identified by the key. Then, from now on, all the users will see the saved
5499++-- content instead of the code content.
5501++-- The content is saved in a file by default (/texts/ in this versions), but there is
5502++-- a configurable version (`tFieldGen`). The content of the element and the formatting
5503++-- is cached in memory, so the display is, theoretically, very fast.
5507++ :: (Functor m, MonadIO m, Executable m,
5509++ UserStr -> Key -> v -> View v m ()
5510++tFieldEd muser k text= wfreeze k 0 $ do
5511++ content <- liftIO $ readtField text k
5513++ let ipanel= nam++"panel"
5515++ install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
5516++ getTexts :: (Token -> IO ())
5517++ getTexts token = do
5518++ let (k,s):_ = tenv token
5520++ writetField k $ (fromStrNoEncode s `asTypeOf` text)
5522++ sendFlush token $ HttpData [] [] ""
5525++ requires [JScriptFile nicEditUrl [install]
5526++ ,JScript ajaxSendText
5527++ ,JScript installEditField
5528++ ,ServerProc ("_texts", transient getTexts)]
5530+ us <- getCurrentUser
5531+ when(us== muser) noCache
5533+- (ftag "div" mempty `attrs` [("id",ipanel)]) ++>
5534+- notValid (ftag "span" content `attrs` [("id", name)])
5539+- "\nfunction installEditField(muser,cookieuser,name,ipanel){\
5540+- \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\
5541+- \bkLib.onDomLoaded(function() {\
5542+- \var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {\
5543+- \ajaxSendText(id,content);\
5544+- \myNicEditor.removeInstance(name);\
5545+- \myNicEditor.removePanel(ipanel);\
5547+- \myNicEditor.addInstance(name);\
5548+- \myNicEditor.setPanel(ipanel);\
5551+-ajaxSendText = "\nfunction ajaxSendText(id,content){\
5552+- \var arr= id.split('-');\
5557+- \data: k + '='+ encodeURIComponent(content),\
5558+- \success: function (resp) {},\
5559+- \error: function (xhr, status, error) {\
5560+- \var msg = $('<div>' + xhr + '</div>');\
5567+--- | a text field. Read the cached field value and present it without edition.
5568+-tField :: (MonadIO m,Functor m, Executable m, FormInput v)
5571+-tField k = wfreeze k 0 $ do
5572+- content <- liftIO $ readtField (fromStrNoEncode "not found") k
5575+--- | A multilanguage version of tFieldEd. For a field with @key@ it add a suffix with the
5576+--- two characters of the language used.
5577+-mFieldEd muser k content= do
5579+- tFieldEd muser (k ++ ('-':lang)) content
5583+--- | A multilanguage version of tField
5586+- tField $ k ++ ('-':lang)
5588+-newtype IteratedId= IteratedId String deriving Typeable
5590+--- | Permits to iterate the presentation of data and//or input fields and widgets within
5591+--- a web page that does not change. The placeholders are created with dField. Both are widget
5592+--- modifiers: The latter gets a widget and create a placeholder in the page that is updated
5593+--- via ajax. The content of the update is the rendering of the widget at each iteration.
5594+--- The former gets a wider widget which contains dField elements and permit the iteration.
5595+--- Whenever a link or a form within the witerate widget is activated, the result is the
5596+--- placeholders filled with the new html content. This content can be data, a input field,
5597+--- a link or a widget. No navigation happens.
5599+--- This permits even faster updates than autoRefresh. since the latter refresh the whole
5600+--- widget and it does not permits modifications of the layout at runtime.
5602+--- When edTemplate or template is used on top of witerate, the result is editable at runtime,
5603+--- and the span placeholders generated, that are updated via ajax can be relocated within
5604+--- the layout of the template.
5606+--- Additionally, contrary to some javascript frameworks, the pages generated with this
5607+--- mechanism are searchable by web crawlers.
5610+- :: (MonadIO m, Functor m, FormInput v) =>
5611+- View v m a -> View v m a
5614+- setSessionData $ IteratedId name
5616+- let t= mfkillTime st
5617+- let installAutoEval=
5618+- "$(document).ready(function(){\
5619+- \autoEvalLink('"++name++"',0);\
5620+- \autoEvalForm('"++name++"');\
5623++ (ftag "div" mempty `attrs` [("id",ipanel)]) ++>
5624++ notValid (ftag "span" content `attrs` [("id", name)])
5629++ "\nfunction installEditField(muser,cookieuser,name,ipanel){\
5630++ \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1){\
5631++ \var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {\
5632++ \ajaxSendText(id,content);\
5633++ \myNicEditor.removeInstance(name);\
5634++ \myNicEditor.removePanel(ipanel);\
5636++ \myNicEditor.addInstance(name);\
5637++ \myNicEditor.setPanel(ipanel);\
5640++ajaxSendText = "\nfunction ajaxSendText(id,content){\
5641++ \var arr= id.split('-');\
5646++ \data: k + '='+ encodeURIComponent(content),\
5647++ \success: function (resp) {},\
5648++ \error: function (xhr, status, error) {\
5649++ \var msg = $('<div>' + xhr + '</div>');\
5656++-- | a text field. Read the cached field value and present it without edition.
5657++tField :: (MonadIO m,Functor m, Executable m, FormInput v)
5660++tField k = wfreeze k 0 $ do
5661++ content <- liftIO $ readtField (fromStrNoEncode "not found") k
5664++-- | A multilanguage version of tFieldEd. For a field with @key@ it add a suffix with the
5665++-- two characters of the language used.
5666++mFieldEd muser k content= do
5668++ tFieldEd muser (k ++ ('-':lang)) content
5672++-- | A multilanguage version of tField
5675++ tField $ k ++ ('-':lang)
5677++data IteratedId = IteratedId String String deriving (Typeable, Show)
5679++-- | Permits to iterate the presentation of data and//or input fields and widgets within
5680++-- a web page that does not change. The placeholders are created with dField. Both are widget
5681++-- modifiers: The latter gets a widget and create a placeholder in the page that is updated
5682++-- via ajax. The content of the update is the rendering of the widget at each iteration.
5683++-- The former gets a wider widget which contains dField elements and permit the iteration.
5684++-- Whenever a link or a form within the witerate widget is activated, the result is the
5685++-- placeholders filled with the new html content. This content can be data, a input field,
5686++-- a link or a widget. No navigation happens.
5688++-- This permits even faster updates than autoRefresh. since the latter refresh the whole
5689++-- widget and it does not permits modifications of the layout at runtime.
5691++-- When edTemplate or template is used on top of witerate, the result is editable at runtime,
5692++-- and the span placeholders generated, that are updated via ajax can be relocated within
5693++-- the layout of the template.
5695++-- Additionally, contrary to some javascript frameworks, the pages generated with this
5696++-- mechanism are searchable by web crawlers.
5699++ :: (MonadIO m, Functor m, FormInput v) =>
5700++ View v m a -> View v m a
5703++ setSessionData $ IteratedId name mempty
5705++ let t= mfkillTime st
5706++ let installAutoEval=
5707++ "$(document).ready(function(){\
5708++ \autoEvalLink('"++name++"',0);\
5709++ \autoEvalForm('"++name++"');\
5711+ let r = lookup ("auto"++name) $ mfEnv st
5712+ w'= w `wcallback` (const $ do
5713++ setSessionData $ IteratedId name mempty
5714+ modify $ \s -> s{mfPagePath=mfPagePath st
5715+ ,mfSequence= mfSequence st
5716+- ,mfRequirements= if r== Nothing then mfRequirements s else []
5722+- requires [JScript autoEvalLink
5723+- ,JScript autoEvalForm
5724+- ,JScript $ timeoutscript t
5729++ requires [JScript autoEvalLink
5730++ ,JScript autoEvalForm
5731++ ,JScript $ timeoutscript t
5732+ ,JScriptFile jqueryScript [installAutoEval]
5735+- (ftag "div" <<< w') <! [("id",name)]
5737+- Just sind -> View $ do
5739+- modify $ \s -> s{mfRequirements=[],mfHttpHeaders=[]} -- !> "just"
5741+- FormElm _ mr <- runView w'
5743+- reqs <- return . map ( \(Requirement r) -> unsafeCoerce r) =<< gets mfRequirements
5744+- let js = jsRequirements True reqs
5747+- liftIO . sendFlush t $ HttpData
5748+- (mfHttpHeaders st')
5749+- (mfCookies st') (fromString js)
5750+- put st'{mfAutorefresh=True, inSync=True}
5751+- return $ FormElm mempty Nothing
5753+- delSessionData $ IteratedId name
5756++ (ftag "div" <<< w') <! [("id",name)]
5758++ Just sind -> refresh $ View $ do
5759++ FormElm _ mr <- runView w'
5760++ IteratedId _ render <- getSessionData `onNothing` return (IteratedId name mempty)
5761++ return $ FormElm (fromStrNoEncode render) mr
5764++-- let t= mfToken st
5765++-- modify $ \s -> s{mfRequirements=[],mfHttpHeaders=[]} -- !> "just"
5766++-- resetCachePolicy
5767++-- FormElm _ mr <- runView w'
5770++-- reqs <- installAllRequirements
5773++-- liftIO . sendFlush t $ HttpData
5774++-- (mfHttpHeaders st')
5775++-- (mfCookies st') (toByteString reqs)
5776++-- put st'{mfAutorefresh=True, inSync=True}
5777++-- return $ FormElm mempty Nothing
5779++ delSessionData $ IteratedId name mempty
5784+-autoEvalLink = "\nfunction autoEvalLink(id,ind){\
5785+- \var id1= $('#'+id);\
5787++autoEvalLink = "\nfunction autoEvalLink(id,ind){\
5788++ \var id1= $('#'+id);\
5789+ \var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\
5790+- \ida.off('click');\
5791+- \ida.click(function () {\
5792+- \if (hadtimeout == true) return true;\
5793+- \var pdata = $(this).attr('data-value');\
5794+- \var actionurl = $(this).attr('href');\
5795+- \var dialogOpts = {\
5796++ \ida.off('click');\
5797++ \ida.click(function () {\
5798++ \if (hadtimeout == true) return true;\
5799++ \var pdata = $(this).attr('data-value');\
5800++ \var actionurl = $(this).attr('href');\
5801++ \var dialogOpts = {\
5803+- \url: actionurl+'?auto'+id+'='+ind,\
5805+- \success: function (resp) {\
5806++ \url: actionurl+'?auto'+id+'='+ind,\
5808++ \success: function (resp) {\
5810+ \autoEvalLink(id,ind);\
5811+- \autoEvalForm(id);\
5813+- \error: function (xhr, status, error) {\
5814+- \var msg = $('<div>' + xhr + '</div>');\
5818+- \$.ajax(dialogOpts);\
5822++ \autoEvalForm(id);\
5824++ \error: function (xhr, status, error) {\
5825++ \var msg = $('<div>' + xhr + '</div>');\
5829++ \$.ajax(dialogOpts);\
5834+ autoEvalForm = "\nfunction autoEvalForm(id) {\
5835+ \var buttons= $('#'+id+' input[type=\"submit\"]');\
5836+@@ -736,12 +739,12 @@
5837+ \if ($(this).attr('class') != '_noAutoRefresh'){\
5838+ \event.preventDefault();\
5839+ \if (hadtimeout == true) return true;\
5840+- \var $form = $(this).closest('form');\
5841++ \var $form = $(this).closest('form');\
5842+ \var url = $form.attr('action');\
5843+ \pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\
5844+ \postForm(id,url,pdata);\
5852+ \idform.submit(function(event) {\
5853+ \if(noajax) {noajax=false; return true;}\
5854+ \event.preventDefault();\
5855+- \var $form = $(this);\
5856++ \var $form = $(this);\
5857+ \var url = $form.attr('action');\
5858+ \var pdata = 'auto'+id+'=true&' + $form.serialize();\
5859+ \postForm(id,url,pdata);\
5860+@@ -759,290 +762,291 @@
5862+ \function postForm(id,url,pdata){\
5863+ \var id1= $('#'+id);\
5867+- \data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\
5868+- \success: function (resp) {\
5872++ \data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\
5873++ \success: function (resp) {\
5875+ \autoEvalLink(id,0);\
5876+- \autoEvalForm(id);\
5877++ \autoEvalForm(id);\
5879+- \error: function (xhr, status, error) {\
5880+- \var msg = $('<div>' + xhr + '</div>');\
5882++ \error: function (xhr, status, error) {\
5883++ \var msg = $('<div>' + xhr + '</div>');\
5892+-setId= "function setId(id,v){document.getElementById(id).innerHTML= v;};\n"
5894+--- | Present a widget via AJAX if it is within a 'witerate' context. In the first iteration it present the
5895+--- widget surrounded by a placeholder. subsequent iterations will send just the javascript code
5896+--- necessary for the refreshing of the placeholder.
5898+- :: (Monad m, FormInput view) =>
5899+- View view m b -> View view m b
5900+-dField w= View $ do
5902+- FormElm render mx <- runView w
5904+- let env = mfEnv st
5906+- IteratedId name <- getSessionData `onNothing` return (IteratedId noid)
5907+- let r = lookup ("auto"++name) env
5910++setId= "function setId(id,v){document.getElementById(id).innerHTML= v;};\n"
5912++-- | Present a widget via AJAX if it is within a 'witerate' context. In the first iteration it present the
5913++-- widget surrounded by a placeholder. subsequent iterations will send just the javascript code
5914++-- necessary for the refreshing of the placeholder.
5916++ :: (Monad m, FormInput view) =>
5917++ View view m b -> View view m b
5918++dField w= View $ do
5920++ FormElm render mx <- runView w
5922++ let env = mfEnv st
5924++ IteratedId name scripts <- getSessionData `onNothing` return (IteratedId noid mempty)
5925++ let r = lookup ("auto"++name) env
5926+ if r == Nothing || (name == noid && newAsk st== True)
5928+--- requires [JScriptFile jqueryScript ["$(document).ready(function() {setId('"++id++"','" ++ toString (toByteString render)++"')});\n"]]
5929+- return $ FormElm((ftag "span" render) `attrs` [("id",id)]) mx
5931+- requires [JScript $ "setId('"++id++"','" ++ toString (toByteString $ render)++"');\n"]
5932+- return $ FormElm mempty mx
5936++ then return $ FormElm((ftag "span" render) `attrs` [("id",id)]) mx
5938++ setSessionData $ IteratedId name $ scripts <> "setId('"++id++"','" ++ toString (toByteString $ render)++"');"
5939++ return $ FormElm mempty mx
5944+ -- | permits the edition of the rendering of a widget at run time. Once saved, the new rendering
5945+ -- becomes the new rendering of the widget for all the users. You must keep the active elements of the
5948+ -- the first parameter is the user that has permissions for edition. the second is a key that
5949+--- identifies the template.
5951+- :: (MonadIO m, FormInput v, Typeable a) =>
5952+- UserStr -> Key -> View v m a -> View v m a
5953+-edTemplate muser k w= View $ do
5956+- let ipanel= nam++"panel"
5958+- install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
5961+- requires [JScriptFile nicEditUrl [install]
5962+- ,JScript ajaxSendText
5963+- ,JScript installEditField
5964+- ,JScriptFile jqueryScript []
5965+- ,ServerProc ("_texts", transient getTexts)]
5966++-- identifies the template.
5968++ :: (MonadIO m, FormInput v, Typeable a) =>
5969++ UserStr -> Key -> View v m a -> View v m a
5970++edTemplate muser k w= View $ do
5973++ let ipanel= nam++"panel"
5975++ install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
5978++ requires [JScript installEditField
5979++ ,JScriptFile nicEditUrl [install]
5980++ ,JScript ajaxSendText
5981++ ,JScriptFile jqueryScript []
5982++ ,ServerProc ("_texts", transient getTexts)]
5983+ us <- getCurrentUser
5984+- when(us== muser) noCache
5985+- FormElm text mx <- runView w
5986+- content <- liftIO $ readtField text k
5988+- return $ FormElm (ftag "div" mempty `attrs` [("id",ipanel)] <>
5989+- ftag "span" content `attrs` [("id", name)])
5992+- getTexts :: (Token -> IO ())
5993+- getTexts token= do
5994+- let (k,s):_ = tenv token
5996+- writetField k $ (fromStrNoEncode s `asTypeOf` viewFormat w)
5998+- sendFlush token $ HttpData [] [] ""
6001+- viewFormat :: View v m a -> v
6002+- viewFormat= undefined -- is a type function
6004++ when(us== muser) noCache
6005++ FormElm text mx <- runView w
6006++ content <- liftIO $ readtField text k
6008++ return $ FormElm (ftag "div" mempty `attrs` [("id",ipanel)] <>
6009++ ftag "span" content `attrs` [("id", name)])
6012++ getTexts :: Token -> IO () -- low level server process
6013++ getTexts token= do
6014++ let (k,s):_ = tenv token
6016++ writetField k $ (fromStrNoEncode s `asTypeOf` viewFormat w)
6018++ sendFlush token $ HttpData [] [] "" --empty response
6023++ viewFormat :: View v m a -> v
6024++ viewFormat= undefined -- is a type function
6026+ -- | Does the same than template but without the edition facility
6028+- :: (MonadIO m, FormInput v, Typeable a) =>
6029+- Key -> View v m a -> View v m a
6030+-template k w= View $ do
6031+- FormElm text mx <- runView w
6032+- let content= unsafePerformIO $ readtField text k
6033+- return $ FormElm content mx
6037+-------------------- JQuery widgets -------------------
6038+--- | present the JQuery datepicker calendar to choose a date.
6039+--- The second parameter is the configuration. Use \"()\" by default.
6040+--- See http://jqueryui.com/datepicker/
6041+-datePicker :: (Monad m, FormInput v) => String -> Maybe String -> View v m (Int,Int,Int)
6042+-datePicker conf jd= do
6044+- let setit= "$(document).ready(function() {\
6045+- \$( '#"++id++"' ).datepicker "++ conf ++";\
6049+- [CSSFile jqueryCSS
6050+- ,JScriptFile jqueryScript []
6051+- ,JScriptFile jqueryUI [setit]]
6053+- s <- getString jd <! [("id",id)]
6054+- let (month,r) = span (/='/') s
6055+- let (day,r2)= span(/='/') $ tail r
6056+- return (read day,read month, read $ tail r2)
6058+--- | present a jQuery dialog with a widget. When a button is pressed it return the result.
6059+--- The first parameter is the configuration. To make it modal, use \"({modal: true})\" see <http://jqueryui.com/dialog/> for
6060+--- the available configurations.
6062+--- The enclosed widget will be wrapped within a form tag if the user do not encloses it using wform.f
6063+-wdialog :: (Monad m, FormInput v) => String -> String -> View v m a -> View v m a
6064+-wdialog conf title w= do
6066+- let setit= "$(document).ready(function() {\
6067+- \$('#"++id++"').dialog "++ conf ++";\
6068+- \var idform= $('#"++id++" form');\
6069+- \idform.submit(function(){$(this).dialog(\"close\")})\
6072+- modify $ \st -> st{needForm= HasForm}
6074+- [CSSFile jqueryCSS
6075+- ,JScriptFile jqueryScript []
6076+- ,JScriptFile jqueryUI [setit]]
6078+- (ftag "div" <<< insertForm w) <! [("id",id),("title", title)]
6084+--- | Capture the form or link submissions and send them via jQuery AJAX.
6085+--- The response is the new presentation of the widget, that is updated. No new page is generated
6086+--- but the functionality is equivalent. Only the activated widget rendering is updated
6087+--- in the client, so a widget with autoRefresh can be used in heavyweight pages.
6088+--- If AJAX/JavaScript are not available, the widget is refreshed normally, via a new page.
6090+--- autoRefresh encloses the widget in a form tag if it includes form elements.
6092+--- If there are more than one autoRefresh, they must be enclosed within 'pageFlow' elements
6098+-autoRefresh = update "html"
6100+--- | In some cases, it is neccessary that a link or form inside a 'autoRefresh' or 'update' block
6101+--- should not be autorefreshed, since it produces side effects in the rest of the page that
6102+--- affect to the rendering of the whole. If you like to refresh the whole page, simply add
6103+--- noAutoRefresh attribute to the widget to force the refresh of the whole page when it is activated.
6105+--- That behaviour is common at the last sentence of the 'autoRefresh' block.
6107+--- This is a cascade menu example.
6109+--- > r <- page $ autoRefresh $ ul <<< do
6110+--- > li <<< wlink OptionA << "option A"
6111+--- > ul <<< li <<< (wlink OptionA1 << "Option A1" <! noAutoRefresh)
6112+--- > <|> li <<< (wlink OptionA2 << "Option A2" <! noAutoRefresh)
6114+--- > maybe other content
6117+--- > OptionA1 -> pageA1
6118+--- > OptionA2 -> pageA2
6120+--- when @option A@ is clicked, the two sub-options appear with autorefresh. Only the two
6121+--- lines are returned by the server using AJAX. but when Option A1-2 is pressed we want to
6122+--- present other pages, so we add the noAutorefresh attribute.
6124+--- NOTE: the noAutoRefresh attribute should be added to the <a/> or <form/> tags.
6125+-noAutoRefresh= [("class","_noAutoRefresh")]
6127+--- | does the same than `autoRefresh` but append the result of each request to the bottom of the widget
6129+--- all the comments and remarks of `autoRefresh` apply here
6130+-appendUpdate :: (MonadIO m,
6134+-appendUpdate= update "append"
6136+--- | does the same than `autoRefresh` but prepend the result of each request before the current widget content
6138+--- all the comments and remarks of `autoRefresh` apply here
6139+-prependUpdate :: (MonadIO m,
6143+-prependUpdate= update "prepend"
6145+-update :: (MonadIO m, FormInput v)
6149+-update method w= do
6152++ :: (MonadIO m, FormInput v, Typeable a) =>
6153++ Key -> View v m a -> View v m a
6154++template k w= View $ do
6155++ FormElm text mx <- runView w
6156++ let content= unsafePerformIO $ readtField text k
6157++ return $ FormElm content mx
6161++------------------- JQuery widgets -------------------
6162++-- | present the JQuery datepicker calendar to choose a date.
6163++-- The second parameter is the configuration. Use \"()\" by default.
6164++-- See http://jqueryui.com/datepicker/
6165++datePicker :: (Monad m, FormInput v) => String -> Maybe String -> View v m (Int,Int,Int)
6166++datePicker conf jd= do
6168++ let setit= "$(document).ready(function() {\
6169++ \$( '#"++id++"' ).datepicker "++ conf ++";\
6173++ [CSSFile jqueryCSS
6174++ ,JScriptFile jqueryScript []
6175++ ,JScriptFile jqueryUI [setit]]
6177++ s <- getString jd <! [("id",id)]
6178++ let (month,r) = span (/='/') s
6179++ let (day,r2)= span(/='/') $ tail r
6180++ return (read day,read month, read $ tail r2)
6182++-- | present a jQuery dialog with a widget. When a button is pressed it return the result.
6183++-- The first parameter is the configuration. To make it modal, use \"({modal: true})\" see <http://jqueryui.com/dialog/> for
6184++-- the available configurations.
6186++-- The enclosed widget will be wrapped within a form tag if the user do not encloses it using wform.f
6187++wdialog :: (Monad m, FormInput v) => String -> String -> View v m a -> View v m a
6188++wdialog conf title w= do
6190++ let setit= "$(document).ready(function() {\
6191++ \$('#"++id++"').dialog "++ conf ++";\
6192++ \var idform= $('#"++id++" form');\
6193++ \idform.submit(function(){$(this).dialog(\"close\")})\
6196++ modify $ \st -> st{needForm= HasForm}
6198++ [CSSFile jqueryCSS
6199++ ,JScriptFile jqueryScript []
6200++ ,JScriptFile jqueryUI [setit]]
6202++ (ftag "div" <<< insertForm w) <! [("id",id),("title", title)]
6208++-- | Capture the form or link submissions and send them via jQuery AJAX.
6209++-- The response is the new presentation of the widget, that is updated. No new page is generated
6210++-- but the functionality is equivalent. Only the activated widget rendering is updated
6211++-- in the client, so a widget with autoRefresh can be used in heavyweight pages.
6212++-- If AJAX/JavaScript are not available, the widget is refreshed normally, via a new page.
6214++-- autoRefresh encloses the widget in a form tag if it includes form elements.
6216++-- If there are more than one autoRefresh, they must be enclosed within 'pageFlow' elements
6222++autoRefresh = update "html"
6224++-- | In some cases, it is neccessary that a link or form inside a 'autoRefresh' or 'update' block
6225++-- should not be autorefreshed, since it produces side effects in the rest of the page that
6226++-- affect to the rendering of the whole. If you like to refresh the whole page, simply add
6227++-- noAutoRefresh attribute to the widget to force the refresh of the whole page when it is activated.
6229++-- That behaviour is common at the last sentence of the 'autoRefresh' block.
6231++-- This is a cascade menu example.
6233++-- > r <- page $ autoRefresh $ ul <<< do
6234++-- > li <<< wlink OptionA << "option A"
6235++-- > ul <<< li <<< (wlink OptionA1 << "Option A1" <! noAutoRefresh)
6236++-- > <|> li <<< (wlink OptionA2 << "Option A2" <! noAutoRefresh)
6238++-- > maybe other content
6241++-- > OptionA1 -> pageA1
6242++-- > OptionA2 -> pageA2
6244++-- when @option A@ is clicked, the two sub-options appear with autorefresh. Only the two
6245++-- lines are returned by the server using AJAX. but when Option A1-2 is pressed we want to
6246++-- present other pages, so we add the noAutorefresh attribute.
6248++-- NOTE: the noAutoRefresh attribute should be added to the <a/> or <form/> tags.
6249++noAutoRefresh= [("class","_noAutoRefresh")]
6251++-- | does the same than `autoRefresh` but append the result of each request to the bottom of the widget
6253++-- all the comments and remarks of `autoRefresh` apply here
6254++appendUpdate :: (MonadIO m,
6258++appendUpdate= update "append"
6260++-- | does the same than `autoRefresh` but prepend the result of each request before the current widget content
6262++-- all the comments and remarks of `autoRefresh` apply here
6263++prependUpdate :: (MonadIO m,
6267++prependUpdate= update "prepend"
6269++update :: (MonadIO m, FormInput v)
6273++update method w= do
6277+- let t = mfkillTime st -1
6280+- "$(document).ready(function(){\
6281+- \ajaxGetLink('"++id++"');\
6282+- \ajaxPostForm('"++id++"');\
6284++ let t = mfkillTime st -1
6287++ "$(document).ready(function(){\
6288++ \ajaxGetLink('"++id++"');\
6289++ \ajaxPostForm('"++id++"');\
6292+ let insync = inSync st
6294+- let r= lookup ("auto"++id) env
6296++ let r= lookup ("auto"++id) env
6299+- requires [JScript $ timeoutscript t
6300+- ,JScript ajaxGetLink
6301+- ,JScript ajaxPostForm
6302+- ,JScriptFile jqueryScript [installscript]]
6303+- (ftag "div" <<< insertForm w) <! [("id",id)]
6306+- let t= mfToken st -- !> "JUST"
6307+- modify $ \s -> s{mfHttpHeaders=[]} -- !> "just"
6309+- FormElm form mr <- runView $ insertForm w
6312+- let HttpData ctype c s= toHttpData $ method <> " " <> toByteString form
6314+- (liftIO . sendFlush t $ HttpData (ctype ++
6315+- mfHttpHeaders st') (mfCookies st' ++ c) s)
6316+- put st'{mfAutorefresh=True,newAsk=True}
6318+- return $ FormElm mempty Nothing
6321+- -- | adapted from http://www.codeproject.com/Articles/341151/Simple-AJAX-POST-Form-and-AJAX-Fetch-Link-to-Modal
6323++ requires [JScript $ timeoutscript t
6324++ ,JScript ajaxGetLink
6325++ ,JScript ajaxPostForm
6326++ ,JScriptFile jqueryScript [installscript]]
6327++ (ftag "div" <<< insertForm w) <! [("id",id)]
6329++ else refresh $ fromStr (method <> " ") ++> insertForm w
6331++-- let t= mfToken st -- !> "JUST"
6332++-- modify $ \s -> s{mfHttpHeaders=[]} -- !> "just"
6333++-- resetCachePolicy
6334++-- FormElm form mr <- runView $ insertForm w
6337++-- let HttpData ctype c s= toHttpData $ method <> " " <> toByteString form
6339++-- (liftIO . sendFlush t $ HttpData (ctype ++
6340++-- mfHttpHeaders st') (mfCookies st' ++ c) s)
6341++-- put st'{mfAutorefresh=True,newAsk=True}
6343++-- return $ FormElm mempty Nothing
6346++ -- | adapted from http://www.codeproject.com/Articles/341151/Simple-AJAX-POST-Form-and-AJAX-Fetch-Link-to-Modal
6347+ -- \url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'=true',\n\
6348+ ajaxGetLink = "\nfunction ajaxGetLink(id){\
6349+- \var id1= $('#'+id);\
6350++ \var id1= $('#'+id);\
6351+ \var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\
6352+- \ida.off('click');\
6353+- \ida.click(function () {\
6354+- \if (hadtimeout == true) return true;\
6355+- \var pdata = $(this).attr('data-value');\
6356+- \var actionurl = $(this).attr('href');\
6357+- \var dialogOpts = {\
6358++ \ida.off('click');\
6359++ \ida.click(function () {\
6360++ \if (hadtimeout == true) return true;\
6361++ \var pdata = $(this).attr('data-value');\
6362++ \var actionurl = $(this).attr('href');\
6363++ \var dialogOpts = {\
6365+- \url: actionurl+'?auto'+id+'=true',\
6367+- \success: function (resp) {\
6368+- \var ind= resp.indexOf(' ');\
6369+- \var dat= resp.substr(ind);\
6370+- \var method= resp.substr(0,ind);\
6371+- \if(method== 'html')id1.html(dat);\
6372+- \else if (method == 'append') id1.append(dat);\
6373++ \url: actionurl+'?auto'+id+'=true',\
6375++ \success: function (resp) {\
6376++ \var ind= resp.indexOf(' ');\
6377++ \var dat= resp.substr(ind);\
6378++ \var method= resp.substr(0,ind);\
6379++ \if(method== 'html')id1.html(dat);\
6380++ \else if (method == 'append') id1.append(dat);\
6381+ \else if (method == 'prepend') id1.prepend(dat);\
6382+- \else $(':root').html(resp);\
6383++ \else $(':root').html(resp);\
6385+- \ajaxPostForm(id);\
6387+- \error: function (xhr, status, error) {\
6388+- \var msg = $('<div>' + xhr + '</div>');\
6392+- \$.ajax(dialogOpts);\
6396++ \ajaxPostForm(id);\
6398++ \error: function (xhr, status, error) {\
6399++ \var msg = $('<div>' + xhr + '</div>');\
6403++ \$.ajax(dialogOpts);\
6408+ ajaxPostForm = "\nfunction ajaxPostForm(id) {\
6409+ \var buttons= $('#'+id+' input[type=\"submit\"]');\
6410+@@ -1051,13 +1055,13 @@
6411+ \buttons.click(function(event) {\
6412+ \if ($(this).attr('class') != '_noAutoRefresh'){\
6413+ \event.preventDefault();\
6414+- \if (hadtimeout == true) return true;\
6415+- \var $form = $(this).closest('form');\
6416++ \if (hadtimeout == true) return true;\
6417++ \var $form = $(this).closest('form');\
6418+ \var url = $form.attr('action');\
6419+ \pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\
6420+ \postForm(id,url,pdata);\
6427+@@ -1067,197 +1071,197 @@
6428+ \idform.submit(function(event) {\
6429+ \if(noajax) {noajax=false; return true;}\
6430+ \event.preventDefault();\
6431+- \var $form = $(this);\
6432++ \var $form = $(this);\
6433+ \var url = $form.attr('action');\
6434+ \var pdata = 'auto'+id+'=true&' + $form.serialize();\
6435+ \postForm(id,url,pdata);\
6438+ \function postForm(id,url,pdata){\
6439+- \var id1= $('#'+id);\
6444+- \success: function (resp) {\
6445+- \var ind= resp.indexOf(' ');\
6446+- \var dat = resp.substr(ind);\
6447+- \var method= resp.substr(0,ind);\
6448+- \if(method== 'html')id1.html(dat);\
6449+- \else if (method == 'append') id1.append(dat);\
6450++ \var id1= $('#'+id);\
6455++ \success: function (resp) {\
6456++ \var ind= resp.indexOf(' ');\
6457++ \var dat = resp.substr(ind);\
6458++ \var method= resp.substr(0,ind);\
6459++ \if(method== 'html')id1.html(dat);\
6460++ \else if (method == 'append') id1.append(dat);\
6461+ \else if (method == 'prepend') id1.prepend(dat);\
6462+ \else $(':root').html(resp);\
6463+- \ajaxGetLink(id);\
6464+- \ajaxPostForm(id);\
6466+- \error: function (xhr, status, error) {\
6467+- \var msg = $('<div>' + xhr + '</div>');\
6477+- "\nvar hadtimeout=false;\
6478+- \if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n"
6481+-data UpdateMethod= Append | Prepend | Html deriving Show
6483+--- | continously execute a widget and update the content.
6484+--- The update method specify how the update is done. 'Html' means a substitution of content.
6485+--- The second parameter is the delay for the next retry in case of disconnection, in milliseconds.
6487+--- It can be used to show data updates in the server. The widget is executed in a different process than
6488+--- the one of the rest of the page.
6489+--- Updates in the session context are not seen by the push widget. It has his own context.
6490+--- To communicate with te widget, use DBRef's or TVar and the
6491+--- STM semantics for waiting updates using 'retry'.
6493+--- Widgets in a push can have links and forms, but since they are asunchonous, they can not
6494+--- return inputs. but they can modify the server state.
6495+--- push ever return an invalid response to the calling widget, so it never
6496+--- triggers the advance of the navigation.
6499+--- This example is a counter increased each second:
6501+--- > pushIncrease= do
6502+--- > tv <- liftIO $ newTVarIO 0
6503+--- > page $ push 0 Html $ do
6504+--- > n <- atomic $ readTVar tv
6505+--- > atomic $ writeTVar tv $ n + 1
6506+--- > liftIO $ threadDelay 1000000
6507+--- > b << (show n) ++> noWidget
6510+--- This other simulates a console output that echoes what is entered in a text box
6511+--- below. It has two widgets: a push output in append mode and a text box input.
6512+--- The communication uses a TVar. The push widget wait for updates in the TVar.
6513+--- because the second widget uses autoRefresh, all happens in the same page.
6515+--- It is recommended to add a timeout to the push widget, like in the example:
6517+--- > pushSample= do
6518+--- > tv <- liftIO $ newTVarIO $ Just "init"
6519+--- > page $ push Append 1000 (disp tv) <** input tv
6523+--- > setTimeouts 100 0
6524+--- > line <- tget tv
6525+--- > p << line ++> noWidget
6527+--- > input tv= autoRefresh $ do
6528+--- > line <- getString Nothing <** submitButton "Enter"
6531+--- > tput tv x = atomic $ writeTVar tv ( Just x) !> "WRITE"
6533+--- > tget tv= atomic $ do
6534+--- > mr <- readTVar tv
6536+--- > Nothing -> retry
6538+--- > writeTVar tv Nothing
6541+-push :: FormInput v
6546+-push method' wait w= push' . map toLower $ show method'
6551+- let token= mfToken st
6553+- procname= "_push" ++ tind token ++ id
6555+- "$(document).ready(function(){\n"
6556+- ++ "ajaxPush('"++id++"',"++show wait++");"
6559+- new <- gets newAsk
6562+- killWF procname token{twfname= procname}
6563+- let proc=runFlow . transientNav . ask $ w'
6564+- requires [ServerProc (procname, proc),
6565+- JScript $ ajaxPush procname,
6566+- JScriptFile jqueryScript [installscript]]
6568+- (ftag "div" <<< noWidget) <! [("id",id)]
6569+- <++ ftag "div" mempty `attrs` [("id",id++"status")]
6573+- modify $ \s -> s{inSync= True,newAsk=True}
6578+- ajaxPush procname=" function ajaxPush(id,waititime){\
6580+- \var id1= $('#'+id);\
6581+- \var idstatus= $('#'+id+'status');\
6582+- \var ida= $('#'+id+' a');\
6583+- \var actionurl='/"++procname++"';\
6584+- \var dialogOpts = {\
6589+- \success: function (resp) {\
6590+- \idstatus.html('')\
6592+- \id1."++method++"(resp);\
6595+- \error: function (xhr, status, error) {\
6598+- \idstatus.html('no more retries');\
6600+- \idstatus.html('waiting');\
6601+- \setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\
6605+- \function ajaxPush1(){\
6606+- \$.ajax(dialogOpts);\
6615+--- | show the jQuery spinner widget. the first parameter is the configuration . Use \"()\" by default.
6616+--- See http://jqueryui.com/spinner
6618+- :: (MonadIO m, Read a,Show a, Typeable a, FormInput view) =>
6619+- String -> Maybe a -> View view m a
6620+-getSpinner conf mv= do
6622+- let setit= "$(document).ready(function() {\
6623+- \var spinner = $( '#"++id++"' ).spinner "++conf++";\
6624+- \spinner.spinner( \"enable\" );\
6627+- [CSSFile jqueryCSS
6628+- ,JScriptFile jqueryScript []
6629+- ,JScriptFile jqueryUI [setit]]
6631+- getTextBox mv <! [("id",id)]
6632++ \ajaxGetLink(id);\
6633++ \ajaxPostForm(id);\
6635++ \error: function (xhr, status, error) {\
6636++ \var msg = $('<div>' + xhr + '</div>');\
6646++ "\nvar hadtimeout=false;\
6647++ \if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n"
6650++data UpdateMethod= Append | Prepend | Html deriving Show
6652++-- | continously execute a widget and update the content.
6653++-- The update method specify how the update is done. 'Html' means a substitution of content.
6654++-- The second parameter is the delay for the next retry in case of disconnection, in milliseconds.
6656++-- It can be used to show data updates in the server. The widget is executed in a different process than
6657++-- the one of the rest of the page.
6658++-- Updates in the session context are not seen by the push widget. It has his own context.
6659++-- To communicate with te widget, use DBRef's or TVar and the
6660++-- STM semantics for waiting updates using 'retry'.
6662++-- Widgets in a push can have links and forms, but since they are asunchonous, they can not
6663++-- return inputs. but they can modify the server state.
6664++-- push ever return an invalid response to the calling widget, so it never
6665++-- triggers the advance of the navigation.
6668++-- This example is a counter increased each second:
6670++-- > pushIncrease= do
6671++-- > tv <- liftIO $ newTVarIO 0
6672++-- > page $ push 0 Html $ do
6673++-- > n <- atomic $ readTVar tv
6674++-- > atomic $ writeTVar tv $ n + 1
6675++-- > liftIO $ threadDelay 1000000
6676++-- > b << (show n) ++> noWidget
6679++-- This other simulates a console output that echoes what is entered in a text box
6680++-- below. It has two widgets: a push output in append mode and a text box input.
6681++-- The communication uses a TVar. The push widget wait for updates in the TVar.
6682++-- because the second widget uses autoRefresh, all happens in the same page.
6684++-- It is recommended to add a timeout to the push widget, like in the example:
6686++-- > pushSample= do
6687++-- > tv <- liftIO $ newTVarIO $ Just "init"
6688++-- > page $ push Append 1000 (disp tv) <** input tv
6692++-- > setTimeouts 100 0
6693++-- > line <- tget tv
6694++-- > p << line ++> noWidget
6696++-- > input tv= autoRefresh $ do
6697++-- > line <- getString Nothing <** submitButton "Enter"
6700++-- > tput tv x = atomic $ writeTVar tv ( Just x) !> "WRITE"
6702++-- > tget tv= atomic $ do
6703++-- > mr <- readTVar tv
6705++-- > Nothing -> retry
6707++-- > writeTVar tv Nothing
6710++push :: FormInput v
6715++push method' wait w= push' . map toLower $ show method'
6720++ let token= mfToken st
6722++ procname= "_push" ++ tind token ++ id
6724++ "$(document).ready(function(){\n"
6725++ ++ "ajaxPush('"++id++"',"++show wait++");"
6728++ new <- gets newAsk
6731++ killWF procname token{twfname= procname}
6732++ let proc=runFlow . transientNav . ask $ w'
6733++ requires [ServerProc (procname, proc),
6734++ JScript $ ajaxPush procname,
6735++ JScriptFile jqueryScript [installscript]]
6737++ (ftag "div" <<< noWidget) <! [("id",id)]
6738++ <++ ftag "div" mempty `attrs` [("id",id++"status")]
6742++ modify $ \s -> s{inSync= True,newAsk=True}
6747++ ajaxPush procname=" function ajaxPush(id,waititime){\
6749++ \var id1= $('#'+id);\
6750++ \var idstatus= $('#'+id+'status');\
6751++ \var ida= $('#'+id+' a');\
6752++ \var actionurl='/"++procname++"';\
6753++ \var dialogOpts = {\
6758++ \success: function (resp) {\
6759++ \idstatus.html('');\
6761++ \id1."++method++"(resp);\
6764++ \error: function (xhr, status, error) {\
6767++ \idstatus.html('no more retries');\
6769++ \idstatus.html('waiting');\
6770++ \setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\
6774++ \function ajaxPush1(){\
6775++ \$.ajax(dialogOpts);\
6784++-- | show the jQuery spinner widget. the first parameter is the configuration . Use \"()\" by default.
6785++-- See http://jqueryui.com/spinner
6787++ :: (MonadIO m, Read a,Show a, Typeable a, FormInput view) =>
6788++ String -> Maybe a -> View view m a
6789++getSpinner conf mv= do
6791++ let setit= "$(document).ready(function() {\
6792++ \var spinner = $( '#"++id++"' ).spinner "++conf++";\
6793++ \spinner.spinner( \"enable\" );\
6796++ [CSSFile jqueryCSS
6797++ ,JScriptFile jqueryScript []
6798++ ,JScriptFile jqueryUI [setit]]
6800++ getTextBox mv <! [("id",id)]
6805+ -- | takes as argument a widget and delay the load until it is visible. The renderring to
6806+ -- be shown during the load is the specified in the first parameter. The resulting lazy
6807+@@ -1277,50 +1281,31 @@
6809+ -- lazy temprendering $ img ! href imageurl ++> noWidget
6810+ lazy :: (FormInput v,Functor m,MonadIO m) => v -> View v m a -> View v m a
6816+ let path = currentPath st
6818+- r= lookup ("auto"++id) env
6819+- t = mfkillTime st -1
6821++ r= lookup ("auto"++id) env
6822++ t = mfkillTime st -1
6823+ installscript = "$(document).ready(function(){\
6824+ \function lazyexec(){lazy('"++id++"','"++ path ++"',lazyexec)};\
6825+ \$(window).one('scroll',lazyexec);\
6826+ \$(window).trigger('scroll');\
6829+--- installscript2= "$(window).one('scroll',function(){\
6830+--- \function lazyexec(){lazy('"++id++"','"++ path ++"',lazyexec)};\
6834+- if r == Nothing then View $ do
6835+- requires [JScript lazyScript
6836++ if r == Nothing then View $ do
6837++ requires [JScript lazyScript
6838+ ,JScriptFile jqueryScript [installscript,scrollposition]]
6839+- FormElm rendering mx <- runView w
6840++ reqs <- gets mfRequirements
6841++ FormElm _ mx <- runView w
6842++ modify $ \st-> st{mfRequirements= reqs} --ignore requirements
6843+ return $ FormElm (ftag "div" v `attrs` [("id",id)]) mx
6848+- FormElm form mx <- runView w
6850+- let t= mfToken st'
6851+- reqs <- installAllRequirements
6852+- let HttpData ctype c s= toHttpData $ toByteString form
6853+- liftIO . sendFlush t $ HttpData (ctype ++
6854+- mfHttpHeaders st') (mfCookies st' ++ c)
6855+- $ toByteString reqs <> s -- !> (unpack $ toByteString reqs)
6856+- put st'{mfAutorefresh=True,inSync= True}
6858+- return $ FormElm mempty mx
6867+ scrollposition= "$.fn.scrollposition= function(){\
6868+ \var pos= $(this).position();\
6869+ \if (typeof(pos)==='undefined') {return 1;}\
6870+@@ -1339,24 +1324,37 @@
6872+ \if(id1.scrollposition() > 0){\
6873+ \$(window).one('scroll',f);}\
6875+- \var dialogOpts = {\
6877++ \var dialogOpts = {\
6879+- \url: actionurl+'?auto'+id+'=true',\
6880+- \success: function (resp) {\
6881++ \url: actionurl+'?auto'+id+'=true',\
6882++ \success: function (resp) {\
6884+- \$(window).trigger('scroll');\
6885++ \$(window).trigger('scroll');\
6887+- \error: function (xhr, status, error) {\
6888+- \var msg = $('<div>' + xhr + '</div>');\
6889++ \error: function (xhr, status, error) {\
6890++ \var msg = $('<div>' + xhr + '</div>');\
6894+- \$.ajax(dialogOpts);\
6897++ \$.ajax(dialogOpts);\
6900++refresh w= View $ do
6902++ modify $ \st -> st{mfAutorefresh=True,inSync= True}
6903++ FormElm form mx <- runView w -- !> show (mfInstalledScripts st')
6906++ let t= mfToken st'
6907++ reqs <- installAllRequirements
6908++ let HttpData ctype c s= toHttpData $ toByteString form
6909++ liftIO . sendFlush t $ HttpData (ctype ++
6910++ mfHttpHeaders st') (mfCookies st' ++ c)
6911++ $ s <> toByteString reqs
6912++ return $ FormElm mempty mx
6914+-waitAndExecute= "function waitAndExecute(sym,f) {\
6915+- \if (eval(sym)) {f();}\
6916+- \else {setTimeout(function() {waitAndExecute(sym,f)}, 50);}\
6918++--waitAndExecute= "function waitAndExecute(sym,f) {\
6919++-- \if (eval(sym)) {f();}\
6920++-- \else {setTimeout(function() {waitAndExecute(sym,f)}, 50);}\
6922+diff -ru orig/src/MFlow/Forms/XHtml.hs new/src/MFlow/Forms/XHtml.hs
6923+--- orig/src/MFlow/Forms/XHtml.hs 2014-06-10 05:51:26.973015856 +0300
6924++++ new/src/MFlow/Forms/XHtml.hs 2014-06-10 05:51:25.000000000 +0300
6926+------------------------------------------------------------------------------
6928+--- Module : Control.MessageFlow.Forms.XHtml
6929+--- Copyright : Alberto Gónez Corona
6932+--- Maintainer : agocorona@gmail.com
6933+--- Stability : experimental
6935+------------------------------------------------------------------------------
6936+-{- | Instances of `FormInput` for the 'Text.XHtml' module of the xhtml package
6939+-{-# OPTIONS -XMultiParamTypeClasses
6940+- -XFlexibleInstances
6941+- -XUndecidableInstances
6942+- -XTypeSynonymInstances
6943+- -XFlexibleContexts
6948+-module MFlow.Forms.XHtml where
6950+-import MFlow (HttpData(..))
6952+-import MFlow.Cookies(contentHtml)
6953+-import Data.ByteString.Lazy.Char8(pack,unpack)
6954+-import qualified Data.Text as T
6955+-import Text.XHtml.Strict as X
6956+-import Control.Monad.Trans
6957+-import Data.Typeable
6959+-instance Monad m => ADDATTRS (View Html m a) where
6960+- widget ! atrs= widget `wmodify` \fs mx -> return ((head fs ! atrs:tail fs), mx)
6964+-instance FormInput Html where
6965+- toByteString = pack. showHtmlFragment
6966+- toHttpData = HttpData [contentHtml] [] . toByteString
6968+- inred = X.bold ![X.thestyle "color:red"]
6969+- finput n t v f c= X.input ! ([thetype t ,name n, value v] ++ if f then [checked] else []
6970+- ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] )
6971+- ftextarea name text= X.textarea ! [X.name name] << T.unpack text
6973+- fselect name list = select ![ X.name name] << list
6974+- foption name v msel= X.option ! ([value name] ++ selected msel) << v
6976+- selected msel = if msel then [X.selected] else []
6978+- attrs tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs)
6982+- formAction action form = X.form ! [X.action action, method "post"] << form
6983+- fromStr = stringToHtml
6984+- fromStrNoEncode= primHtml
6986+- flink v str = toHtml $ hotlink ( v) << str
6988+-instance Typeable Html where
6989+- typeOf = \_ -> mkTyConApp (mkTyCon3 "xhtml" "Text.XHtml.Strict" "Html") []
6992++-----------------------------------------------------------------------------
6994++-- Module : Control.MessageFlow.Forms.XHtml
6995++-- Copyright : Alberto Gónez Corona
6998++-- Maintainer : agocorona@gmail.com
6999++-- Stability : experimental
7001++-----------------------------------------------------------------------------
7002++{- | Instances of `FormInput` for the 'Text.XHtml' module of the xhtml package
7005++{-# OPTIONS -XMultiParamTypeClasses
7006++ -XFlexibleInstances
7007++ -XUndecidableInstances
7008++ -XTypeSynonymInstances
7009++ -XFlexibleContexts
7014++module MFlow.Forms.XHtml where
7016++import MFlow (HttpData(..))
7018++import MFlow.Cookies(contentHtml)
7019++import Data.ByteString.Lazy.Char8(pack,unpack)
7020++import qualified Data.Text as T
7021++import Text.XHtml.Strict as X
7022++import Control.Monad.Trans
7023++import Data.Typeable
7025++instance Monad m => ADDATTRS (View Html m a) where
7026++ widget ! atrs= widget `wmodify` \fs mx -> return ((head fs ! atrs:tail fs), mx)
7030++instance FormInput Html where
7031++ toByteString = pack. showHtmlFragment
7032++ toHttpData = HttpData [contentHtml] [] . toByteString
7034++ inred = X.bold ![X.thestyle "color:red"]
7035++ finput n t v f c= X.input ! ([thetype t ,name n, value v] ++ if f then [checked] else []
7036++ ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] )
7037++ ftextarea name text= X.textarea ! [X.name name] << T.unpack text
7039++ fselect name list = select ![ X.name name] << list
7040++ foption name v msel= X.option ! ([value name] ++ selected msel) << v
7042++ selected msel = if msel then [X.selected] else []
7044++ attrs tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs)
7048++ formAction action form = X.form ! [X.action action, method "post"] << form
7049++ fromStr = stringToHtml
7050++ fromStrNoEncode= primHtml
7052++ flink v str = toHtml $ hotlink ( v) << str
7054++instance Typeable Html where
7055++ typeOf = \_ -> mkTyConApp (mkTyCon3 "xhtml" "Text.XHtml.Strict" "Html") []
7058+diff -ru orig/src/MFlow/Forms.hs new/src/MFlow/Forms.hs
7059+--- orig/src/MFlow/Forms.hs 2014-06-10 05:51:26.961015857 +0300
7060++++ new/src/MFlow/Forms.hs 2014-06-10 05:51:25.000000000 +0300
7061+@@ -1,1039 +1,1047 @@
7062+-{-# OPTIONS -XDeriveDataTypeable
7063+- -XUndecidableInstances
7064+- -XExistentialQuantification
7065+- -XMultiParamTypeClasses
7066+- -XTypeSynonymInstances
7067+- -XFlexibleInstances
7068+- -XScopedTypeVariables
7069+- -XFunctionalDependencies
7070+- -XFlexibleContexts
7072+- -XIncoherentInstances
7075+- -XOverloadedStrings
7077+- -XNoMonomorphismRestriction
7082+-MFlow run stateful server processes. This version is the first stateful web framework
7083+-that is as RESTful as a web framework can be.
7085+-The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links
7086+-point to alternative routes within this monadic computation just like a textual menu
7087+-in a console application. Any GET page is directly reachable by means of a RESTful URL.
7089+-At any moment the flow can respond to the back button or to any RESTful path that the user may paste in the navigation bar.
7090+-If the procedure is waiting for another different page, the FlowM monad backtrack until the path partially match
7091+-. From this position the execution goes forward until the rest of the path match. This way the
7092+-statelessness is optional. However, it is possible to store a session state, which may backtrack or
7093+-not when the navigation goes back and forth. It is upto the programmer.
7096+-All the flow of requests and responses are coded by the programmer in a single procedure.
7097+-Allthoug single request-response flows are possible. Therefore, the code is
7098+-more understandable. It is not continuation based. It uses a log for thread state persistence and backtracking for
7099+-handling the back button. Back button state syncronization is supported out-of-the-box
7101+-The MFlow architecture is scalable, since the state is serializable and small
7103+-The processes are stopped and restarted by the
7104+-application server on demand, including the execution state (if the Wokflow monad is used).
7105+-Therefore session management is automatic. State consistence and transactions are given by the TCache package.
7107+-The processes interact trough widgets, that are an extension of formlets with
7108+-additional applicative combinators, formatting, link management, callbacks, modifiers, caching,
7109+-byteString conversion and AJAX. All is coded in pure haskell.
7111+-The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString
7112+-, Hack and WAI but it can be extended to non Web based architectures.
7114+-Bindings for hack, and hsp >= 0.8, are not compiled by Hackage, and do not appear, but are included in the package files.
7115+-To use them, add then to the exported modules and execute cabal install
7117+-It is designed for applications that can be run with no deployment with runghc in order
7118+-to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html>
7120+-This module implement stateful processes (flows) that are optionally persistent.
7121+-This means that they automatically store and recover his execution state. They are executed by the MFlow app server.
7122+-defined in the "MFlow" module.
7124+-These processses interact with the user trough user interfaces made of widgets (see below) that return back statically typed responses to
7125+-the calling process. Because flows are stateful, not request-response, the code is more understandable, because
7126+-all the flow of request and responses is coded by the programmer in a single procedure in the FlowM monad. Allthoug
7127+-single request-response flows and callbacks are possible.
7129+-This module is abstract with respect to the formatting (here referred with the type variable @view@) . For an
7130+-instantiation for "Text.XHtml" import "MFlow.Forms.XHtml", "MFlow.Hack.XHtml.All" or "MFlow.Wai.XHtml.All" .
7131+-To use Haskell Server Pages import "MFlow.Forms.HSP". However the functionalities are documented here.
7133+-`ask` is the only method for user interaction. It run in the @MFlow view m@ monad, with @m@ the monad chosen by the user, usually IO.
7134+-It send user interfaces (in the @View view m@ monad) and return statically
7135+-typed responses. The user interface definitions are based on a extension of
7136+-formLets (<http://www.haskell.org/haskellwiki/Formlets>) with the addition of caching, links, formatting, attributes,
7137+- extra combinators, callbaks and modifiers.
7138+-The interaction with the user is stateful. In the same computation there may be many
7139+-request-response interactions, in the same way than in the case of a console applications.
7141+-* APPLICATION SERVER
7143+-Therefore, session and state management is simple and transparent: it is in the haskell
7144+-structures in the scope of the computation. `transient` (normal) procedures have no persistent session state
7145+-and `stateless` procedures accept a single request and return a single response.
7147+-`MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that
7148+-remember the execution state even after system shutdowns by using the package workflow (<http://hackage.haskell.org/package/Workflow>) internally.
7149+-This state management is transparent. There is no programer interface for session management.
7151+-The programmer set the process timeout and the session timeout with `setTimeouts`.
7152+-If the procedure has been stopped due to the process timeout or due to a system shutdowm,
7153+-the procedure restart in the last state when a request for this procedure arrives
7154+-(if the procedure uses the `step` monad transformer)
7158+-The correctness of the web responses is assured by the use of formLets.
7159+-But unlike formLets in its current form, it permits the definition of widgets.
7160+-/A widget is a combination of formLets and links within its own formatting template/, all in
7161+-the same definition in the same source file, in plain declarative Haskell style.
7163+-The formatting is abstract. It has to implement the 'FormInput' class.
7164+-There are instances for Text.XHtml ("MFlow.Forms.XHtml"), Haskell Server Pages ("MFlow.Forms.HSP")
7165+-and ByteString. So widgets
7166+-can use any formatting that is instance of `FormInput`.
7167+-It is possible to use more than one format in the same widget.
7169+-Links defined with `wlink` are treated the same way than forms. They are type safe and return values
7170+- to the same flow of execution.
7171+-It is posssible to combine links and forms in the same widget by using applicative combinators but also
7172+-additional applicative combinators like \<+> !*> , |*|. Widgets are also monoids, so they can
7173+-be combined as such.
7175+-* NEW IN THIS RELEASE
7177+-[@Runtime templates@] 'template', 'edTemplate', 'witerate' and 'dField' permit the edition of
7178+-the widget content at runtime, and the management of placeholders with input fields and data fields
7179+-within the template with no navigation in the client, little bandwidth usage and little server load. Enven less
7180+-than using 'autoRefresh'.
7182+-* IN PREVIOUS RELEASES
7184+-{@AutoRefresh@] Using `autoRefresh`, Dynamic widgets can refresh themselves with new information without forcing a refresh of the whole page
7186+-[@Push@] With `push` a widget can push new content to the browser when something in the server happens
7188+-[@Error traces@] using the monadloc package, now each runtime error (in a monadic statement) has a complete execution trace.
7191+-[@RESTful URLs@] Now each page is directly reachable by means of a intuitive, RESTful url, whose path is composed by the sucession
7192+-of links clicked to reach such page and such point in the procedure. Just what you would expect.
7194+-[@Page flows@] each widget-formlet can have its own independent behaviour within the page. They can
7195+-refresh independently trough AJAX by means of 'autoRefresh'. Additionally, 'pageFlow' initiates the page flow mode or a
7196+-subpage flow by adding a well know indetifier prefix for links and form parameters.
7198+-[@Modal Dialogs@] 'wdialog' present a widget within a modal or non modal jQuery dialog. while a monadic
7199+-widget-formlet can add different form elements depending on the user responses, 'wcallback' can
7200+-substitute the widget by other. (See 'Demos/demos.blaze.hs' for some examples)
7202+-[@JQuery widgets@] with MFlow interface: 'getSpinner', 'datePicker', 'wdialog'
7204+-[@WAI interface@] Now MFlow works with Snap and other WAI developments. Include "MFlow.Wai" or "MFlow.Wai.Blaze.Html.All" to use it.
7206+-[@blaze-html support@] see <http://hackage.haskell.org/package/blaze-html> import "MFlow.Forms.Blaze.Html" or "MFlow.Wai.Blaze.Html.All" to use Blaze-Html
7208+-[@AJAX@] Now an ajax procedures (defined with 'ajax' can perform many interactions with the browser widgets, instead
7209+-of a single request-response (see 'ajaxSend').
7211+-[@Active widgets@] "MFlow.Forms.Widgets" contains active widgets that interact with the
7212+-server via Ajax and dynamically control other widgets: 'wEditList', 'autocomplete' 'autocompleteEdit' and others.
7214+-[@Requirements@] a widget can specify javaScript files, JavasScript online scipts, CSS files, online CSS and server processes
7215+- and any other instance of the 'Requrement' class. See 'requires' and 'WebRequirements'
7217+-[@content-management@] for templating and online edition of the content template. See 'tFieldEd' 'tFieldGen' and 'tField'
7219+-[@multilanguage@] see 'mField' and 'mFieldEd'
7221+-[@URLs to internal states@] if the web navigation is trough GET forms or links,
7222+- an URL can express a direct path to the n-th step of a flow, So this URL can be shared with other users.
7223+-Just like in the case of an ordinary stateless application.
7226+-[@Back Button@] This is probably the first implementation in any language where the navigation
7227+-can be expressed procedurally and still it works well with the back button, thanks
7228+-to monad magic. (See <http://haskell-web.blogspot.com.es/2012/03//failback-monad.html>)
7231+-[@Cached widgets@] with `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)
7232+-, the caching can be permanent or for a certain time. this is very useful for complex widgets that present information. Specially if
7233+-the widget content comes from a database and it is shared by all users.
7236+-[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated.
7237+-The callback may initate a flow of interactions with the user or simply executes an internal computation.
7238+-Callbacks are necessary for the creation of abstract container
7239+-widgets that may not know the behaviour of its content. with callbacks, the widget manages its content as black boxes.
7242+-[@Modifiers@] `wmodify` change the visualization and result returned by the widget. For example it may hide a
7243+-login form and substitute it by the username if already logged.
7247+-@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@
7250+-[@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator
7253+-[@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the
7254+- ByteString level, and to permit many formatring styles
7255+-in the same page, there are operators that combine different formats which are converted to ByteStrings.
7256+-For example the header and footer may be coded in XML, while the formlets may be formatted using Text.XHtml.
7258+-[@File Server@] With file caching. See "MFlow.FileServer"
7263+-module MFlow.Forms(
7265+--- * Basic definitions
7267+-FlowM, View(..), FormElm(..), FormInput(..)
7270+-, Auth(..), userRegister, setAuthMethod, userValidate, isLogged, setAdminUser, getAdminName
7271+-,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, paranoidLogout
7272+-,encryptedLogout, userWidget, paranoidUserWidget, encryptedUserWidget, login, paranoidLogin, encryptedLogin,
7274+--- * User interaction
7275+-ask, page, askt, clearEnv, wstateless, pageFlow,
7277+--- | They usually produce the HTML form elements (depending on the FormInput instance used)
7278+--- It is possible to modify their attributes with the `<!` operator.
7279+--- They are combined with applicative ombinators and some additional ones
7280+--- formatting can be added with the formatting combinators.
7281+--- modifiers change their presentation and behaviour
7282+-getString,getInt,getInteger, getTextBox
7283+-,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,
7284+-getRadio, setRadio, setRadioActive, wlabel, getCheckBoxes, genCheckBoxes, setCheckBox,
7285+-submitButton,resetButton, whidden, wlink, absLink, getKeyValueParam,
7286++{-# OPTIONS -XDeriveDataTypeable
7287++ -XUndecidableInstances
7288++ -XExistentialQuantification
7289++ -XMultiParamTypeClasses
7290++ -XTypeSynonymInstances
7291++ -XFlexibleInstances
7292++ -XScopedTypeVariables
7293++ -XFunctionalDependencies
7294++ -XFlexibleContexts
7296++ -XIncoherentInstances
7299++ -XOverloadedStrings
7301++ -XNoMonomorphismRestriction
7306++MFlow run stateful server processes. This version is the first stateful web framework
7307++that is as RESTful as a web framework can be.
7309++The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links
7310++point to alternative routes within this monadic computation just like a textual menu
7311++in a console application. Any GET page is directly reachable by means of a RESTful URL.
7313++At any moment the flow can respond to the back button or to any RESTful path that the user may paste in the navigation bar.
7314++If the procedure is waiting for another different page, the FlowM monad backtrack until the path partially match
7315++. From this position the execution goes forward until the rest of the path match. This way the
7316++statelessness is optional. However, it is possible to store a session state, which may backtrack or
7317++not when the navigation goes back and forth. It is upto the programmer.
7320++All the flow of requests and responses are coded by the programmer in a single procedure.
7321++Allthoug single request-response flows are possible. Therefore, the code is
7322++more understandable. It is not continuation based. It uses a log for thread state persistence and backtracking for
7323++handling the back button. Back button state syncronization is supported out-of-the-box
7325++The MFlow architecture is scalable, since the state is serializable and small
7327++The processes are stopped and restarted by the
7328++application server on demand, including the execution state (if the Wokflow monad is used).
7329++Therefore session management is automatic. State consistence and transactions are given by the TCache package.
7331++The processes interact trough widgets, that are an extension of formlets with
7332++additional applicative combinators, formatting, link management, callbacks, modifiers, caching,
7333++byteString conversion and AJAX. All is coded in pure haskell.
7335++The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString
7336++, Hack and WAI but it can be extended to non Web based architectures.
7338++Bindings for hack, and hsp >= 0.8, are not compiled by Hackage, and do not appear, but are included in the package files.
7339++To use them, add then to the exported modules and execute cabal install
7341++It is designed for applications that can be run with no deployment with runghc in order
7342++to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html>
7344++This module implement stateful processes (flows) that are optionally persistent.
7345++This means that they automatically store and recover his execution state. They are executed by the MFlow app server.
7346++defined in the "MFlow" module.
7348++These processses interact with the user trough user interfaces made of widgets (see below) that return back statically typed responses to
7349++the calling process. Because flows are stateful, not request-response, the code is more understandable, because
7350++all the flow of request and responses is coded by the programmer in a single procedure in the FlowM monad. Allthoug
7351++single request-response flows and callbacks are possible.
7353++This module is abstract with respect to the formatting (here referred with the type variable @view@) . For an
7354++instantiation for "Text.XHtml" import "MFlow.Forms.XHtml", "MFlow.Hack.XHtml.All" or "MFlow.Wai.XHtml.All" .
7355++To use Haskell Server Pages import "MFlow.Forms.HSP". However the functionalities are documented here.
7357++`ask` is the only method for user interaction. It run in the @MFlow view m@ monad, with @m@ the monad chosen by the user, usually IO.
7358++It send user interfaces (in the @View view m@ monad) and return statically
7359++typed responses. The user interface definitions are based on a extension of
7360++formLets (<http://www.haskell.org/haskellwiki/Formlets>) with the addition of caching, links, formatting, attributes,
7361++ extra combinators, callbaks and modifiers.
7362++The interaction with the user is stateful. In the same computation there may be many
7363++request-response interactions, in the same way than in the case of a console applications.
7365++* APPLICATION SERVER
7367++Therefore, session and state management is simple and transparent: it is in the haskell
7368++structures in the scope of the computation. `transient` (normal) procedures have no persistent session state
7369++and `stateless` procedures accept a single request and return a single response.
7371++`MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that
7372++remember the execution state even after system shutdowns by using the package workflow (<http://hackage.haskell.org/package/Workflow>) internally.
7373++This state management is transparent. There is no programer interface for session management.
7375++The programmer set the process timeout and the session timeout with `setTimeouts`.
7376++If the procedure has been stopped due to the process timeout or due to a system shutdowm,
7377++the procedure restart in the last state when a request for this procedure arrives
7378++(if the procedure uses the `step` monad transformer)
7382++The correctness of the web responses is assured by the use of formLets.
7383++But unlike formLets in its current form, it permits the definition of widgets.
7384++/A widget is a combination of formLets and links within its own formatting template/, all in
7385++the same definition in the same source file, in plain declarative Haskell style.
7387++The formatting is abstract. It has to implement the 'FormInput' class.
7388++There are instances for Text.XHtml ("MFlow.Forms.XHtml"), Haskell Server Pages ("MFlow.Forms.HSP")
7389++and ByteString. So widgets
7390++can use any formatting that is instance of `FormInput`.
7391++It is possible to use more than one format in the same widget.
7393++Links defined with `wlink` are treated the same way than forms. They are type safe and return values
7394++ to the same flow of execution.
7395++It is posssible to combine links and forms in the same widget by using applicative combinators but also
7396++additional applicative combinators like \<+> !*> , |*|. Widgets are also monoids, so they can
7397++be combined as such.
7399++* NEW IN THIS RELEASE
7401++[@Runtime templates@] 'template', 'edTemplate', 'witerate' and 'dField' permit the edition of
7402++the widget content at runtime, and the management of placeholders with input fields and data fields
7403++within the template with no navigation in the client, little bandwidth usage and little server load. Enven less
7404++than using 'autoRefresh'.
7406++* IN PREVIOUS RELEASES
7408++{@AutoRefresh@] Using `autoRefresh`, Dynamic widgets can refresh themselves with new information without forcing a refresh of the whole page
7410++[@Push@] With `push` a widget can push new content to the browser when something in the server happens
7412++[@Error traces@] using the monadloc package, now each runtime error (in a monadic statement) has a complete execution trace.
7415++[@RESTful URLs@] Now each page is directly reachable by means of a intuitive, RESTful url, whose path is composed by the sucession
7416++of links clicked to reach such page and such point in the procedure. Just what you would expect.
7418++[@Page flows@] each widget-formlet can have its own independent behaviour within the page. They can
7419++refresh independently trough AJAX by means of 'autoRefresh'. Additionally, 'pageFlow' initiates the page flow mode or a
7420++subpage flow by adding a well know indetifier prefix for links and form parameters.
7422++[@Modal Dialogs@] 'wdialog' present a widget within a modal or non modal jQuery dialog. while a monadic
7423++widget-formlet can add different form elements depending on the user responses, 'wcallback' can
7424++substitute the widget by other. (See 'Demos/demos.blaze.hs' for some examples)
7426++[@JQuery widgets@] with MFlow interface: 'getSpinner', 'datePicker', 'wdialog'
7428++[@WAI interface@] Now MFlow works with Snap and other WAI developments. Include "MFlow.Wai" or "MFlow.Wai.Blaze.Html.All" to use it.
7430++[@blaze-html support@] see <http://hackage.haskell.org/package/blaze-html> import "MFlow.Forms.Blaze.Html" or "MFlow.Wai.Blaze.Html.All" to use Blaze-Html
7432++[@AJAX@] Now an ajax procedures (defined with 'ajax' can perform many interactions with the browser widgets, instead
7433++of a single request-response (see 'ajaxSend').
7435++[@Active widgets@] "MFlow.Forms.Widgets" contains active widgets that interact with the
7436++server via Ajax and dynamically control other widgets: 'wEditList', 'autocomplete' 'autocompleteEdit' and others.
7438++[@Requirements@] a widget can specify javaScript files, JavasScript online scipts, CSS files, online CSS and server processes
7439++ and any other instance of the 'Requrement' class. See 'requires' and 'WebRequirements'
7441++[@content-management@] for templating and online edition of the content template. See 'tFieldEd' 'tFieldGen' and 'tField'
7443++[@multilanguage@] see 'mField' and 'mFieldEd'
7445++[@URLs to internal states@] if the web navigation is trough GET forms or links,
7446++ an URL can express a direct path to the n-th step of a flow, So this URL can be shared with other users.
7447++Just like in the case of an ordinary stateless application.
7450++[@Back Button@] This is probably the first implementation in any language where the navigation
7451++can be expressed procedurally and still it works well with the back button, thanks
7452++to monad magic. (See <http://haskell-web.blogspot.com.es/2012/03//failback-monad.html>)
7455++[@Cached widgets@] with `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)
7456++, the caching can be permanent or for a certain time. this is very useful for complex widgets that present information. Specially if
7457++the widget content comes from a database and it is shared by all users.
7460++[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated.
7461++The callback may initate a flow of interactions with the user or simply executes an internal computation.
7462++Callbacks are necessary for the creation of abstract container
7463++widgets that may not know the behaviour of its content. with callbacks, the widget manages its content as black boxes.
7466++[@Modifiers@] `wmodify` change the visualization and result returned by the widget. For example it may hide a
7467++login form and substitute it by the username if already logged.
7471++@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@
7474++[@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator
7477++[@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the
7478++ ByteString level, and to permit many formatring styles
7479++in the same page, there are operators that combine different formats which are converted to ByteStrings.
7480++For example the header and footer may be coded in XML, while the formlets may be formatted using Text.XHtml.
7482++[@File Server@] With file caching. See "MFlow.FileServer"
7487++module MFlow.Forms(
7489++-- * Basic definitions
7491++FlowM, View(..), FormElm(..), FormInput(..)
7494++, Auth(..), userRegister, setAuthMethod, userValidate, isLogged, setAdminUser, getAdminName
7495++,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, paranoidLogout
7496++,encryptedLogout, userWidget, paranoidUserWidget, encryptedUserWidget, login, paranoidLogin, encryptedLogin,
7498++-- * User interaction
7499++ask, page, askt, clearEnv, wstateless, pageFlow,
7501++-- | They usually produce the HTML form elements (depending on the FormInput instance used)
7502++-- It is possible to modify their attributes with the `<!` operator.
7503++-- They are combined with applicative ombinators and some additional ones
7504++-- formatting can be added with the formatting combinators.
7505++-- modifiers change their presentation and behaviour
7506++getString,getInt,getInteger, getTextBox
7507++,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,
7508++getRadio, setRadio, setRadioActive, wlabel, getCheckBoxes, genCheckBoxes, setCheckBox,
7509++submitButton,resetButton, whidden, wlink, absLink, getKeyValueParam, fileUpload,
7510+ getRestParam, returning, wform, firstOf, manyOf, allOf, wraw, wrender, notValid
7511+--- * FormLet modifiers
7512+-,validate, noWidget, stop, waction, wcallback, wmodify,
7514+--- * Caching widgets
7515+-cachedWidget, wcached, wfreeze,
7517+--- * Widget combinators
7518+-(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)
7520+----- * Normalized (convert to ByteString) widget combinators
7521+----- | These dot operators are indentical to the non dot operators, with the addition of the conversion of the arguments to lazy byteStrings
7523+----- The purpose is to combine heterogeneous formats into byteString-formatted widgets that
7524+----- can be cached with `cachedWidget`
7525+---,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
7527+--- * Formatting combinators
7528+-,(<<<),(++>),(<++),(<!)
7530+----- * Normalized (convert to ByteString) formatting combinators
7531+----- | Some combinators that convert the formatting of their arguments to lazy byteString
7532+-----(.<<.),(.<++.),(.++>.)
7534+--- * ByteString tags
7538+-,flatten, normalize
7540+--- * Running the flow monad
7541+-,runFlow, transientNav, runFlowOnce, runFlowIn
7542+-,runFlowConf,MFlow.Forms.Internals.step
7543+--- * controlling backtracking
7544+-,goingBack,returnIfForward, breturn, preventGoingBack, compensate, onBacktrack, retry
7546++-- * FormLet modifiers
7547++,validate, noWidget, stop, waction, wcallback, wmodify,
7549++-- * Caching widgets
7550++cachedWidget, wcached, wfreeze,
7552++-- * Widget combinators
7553++(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)
7555++---- * Normalized (convert to ByteString) widget combinators
7556++---- | These dot operators are indentical to the non dot operators, with the addition of the conversion of the arguments to lazy byteStrings
7558++---- The purpose is to combine heterogeneous formats into byteString-formatted widgets that
7559++---- can be cached with `cachedWidget`
7560++--,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
7562++-- * Formatting combinators
7563++,(<<<),(++>),(<++),(<!)
7565++---- * Normalized (convert to ByteString) formatting combinators
7566++---- | Some combinators that convert the formatting of their arguments to lazy byteString
7567++----(.<<.),(.<++.),(.++>.)
7569++-- * ByteString tags
7573++,flatten, normalize
7575++-- * Running the flow monad
7576++,runFlow, transientNav, runFlowOnce, runFlowIn
7577++,runFlowConf,MFlow.Forms.Internals.step
7578++-- * controlling backtracking
7579++,goingBack,returnIfForward, breturn, preventGoingBack, compensate, onBacktrack, retry
7581+ -- * Setting parameters
7600+-,setEncryptedCookie
7607+-,WebRequirement(..)
7616++,setEncryptedCookie
7623++,WebRequirement(..)
7638+-import Data.RefSerialize hiding ((<|>),empty)
7640+-import Data.TCache.Memoization
7642+-import MFlow.Forms.Internals
7643+-import MFlow.Cookies
7656++import Data.RefSerialize hiding ((<|>),empty)
7658++import Data.TCache.Memoization
7660++import MFlow.Forms.Internals
7661++import MFlow.Cookies
7662+ import Data.ByteString.Lazy.Char8 as B(ByteString,cons,append,empty,fromChunks,unpack)
7663+ import Data.ByteString.Lazy.UTF8 hiding (length, take)
7664+-import qualified Data.String as S
7665+-import qualified Data.Text as T
7666+-import Data.Text.Encoding
7668+---import qualified Data.CaseInsensitive as CI
7669+-import Data.Typeable
7671+-import Control.Monad.State.Strict
7673+-import Control.Applicative
7674+-import Control.Exception
7675+-import Control.Concurrent
7676+-import Control.Workflow as WF
7677+-import Control.Monad.Identity
7678+-import Unsafe.Coerce
7679+-import Data.List(intersperse)
7681+-import qualified Data.Map as M
7682+-import System.IO.Unsafe
7683+-import Data.Char(isNumber,toLower)
7684+-import Network.HTTP.Types.Header
7685+-import MFlow.Forms.Cache
7687+--- | Validates a form or widget result against a validating procedure
7689+--- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@
7691+- :: (FormInput view, Monad m) =>
7693+- -> (a -> WState view m (Maybe view))
7695+-validate formt val= View $ do
7696+- FormElm form mx <- runView formt
7700+- modify (\s -> s{inSync= True})
7703+- return $ FormElm ( form <> inred str) Nothing
7704+- Nothing -> return $ FormElm form mx
7705+- _ -> return $ FormElm form mx
7707+--- | Actions are callbacks that are executed when a widget is validated.
7708+--- A action may be a complete flow in the flowM monad. It takes complete control of the navigation
7709+--- while it is executed. At the end it return the result to the caller and display the original
7711+--- It is useful when the widget is inside widget containers that may treat it as a black box.
7713+--- It returns a result that can be significative or, else, be ignored with '<**' and '**>'.
7714+--- An action may or may not initiate his own dialog with the user via `ask`
7716+- :: (FormInput view, Monad m)
7718+- -> (a -> FlowM view m b)
7724+- let seq = mfSequence s
7725+- put s{mfSequence=mfSequence s+ 100,mfEnv=[],newAsk=True}
7726+- r <- flowToView $ ac x
7727+- modify $ \s-> s{mfSequence= seq, mfEnv= env}
7732+- r <- runSup $ runFlowM x
7735+- return (FormElm mempty $ Just x)
7737+- return (FormElm mempty $ Just x)
7739+- modify $ \s ->s{notSyncInAction= True}
7740+- return (FormElm mempty Nothing)
7742+--- | change the rendering and the return value of a page. This is superseeded by page flows.
7743+-wmodify :: (Monad m, FormInput v)
7745+- -> (v -> Maybe a -> WState v m (v, Maybe b))
7747+-wmodify formt act = View $ do
7748+- FormElm f mx <- runView formt
7749+- (f',mx') <- act f mx
7750+- return $ FormElm f' mx'
7752+--- | Display a text box and return a non empty String
7753+-getString :: (FormInput view,Monad m) =>
7754+- Maybe String -> View view m String
7755+-getString ms = getTextBox ms
7757+- \s -> if null s then return (Just $ fromStr "")
7758+- else return Nothing
7760+--- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation)
7761+-getInteger :: (FormInput view, MonadIO m) =>
7762+- Maybe Integer -> View view m Integer
7763+-getInteger = getTextBox
7765+--- | Display a text box and return a Int (if the value entered is not an Int, fails the validation)
7766+-getInt :: (FormInput view, MonadIO m) =>
7767+- Maybe Int -> View view m Int
7768+-getInt = getTextBox
7770+--- | Display a password box
7771+-getPassword :: (FormInput view,
7773+- View view m String
7774+-getPassword = getParam Nothing "password" Nothing
7776+-newtype Radio a= Radio a
7778+--- | Implement a radio button that perform a submit when pressed.
7779+--- the parameter is the name of the radio group
7780+-setRadioActive :: (FormInput view, MonadIO m,
7781+- Read a, Typeable a, Eq a, Show a) =>
7782+- a -> String -> View view m (Radio a)
7783+-setRadioActive v n = View $ do
7785+- put st{needForm= HasElems}
7786+- let env = mfEnv st
7787+- mn <- getParam1 n env
7788+- let str = if typeOf v == typeOf(undefined :: String)
7789+- then unsafeCoerce v else show v
7790+- return $ FormElm (finput n "radio" str
7791+- ( isValidated mn && v== fromValidated mn) (Just "this.form.submit()"))
7792+- (fmap Radio $ valToMaybe mn)
7795+--- | Implement a radio button
7796+--- the parameter is the name of the radio group
7797+-setRadio :: (FormInput view, MonadIO m,
7798+- Read a, Typeable a, Eq a, Show a) =>
7799+- a -> String -> View view m (Radio a)
7800+-setRadio v n= View $ do
7802+- put st{needForm= HasElems}
7803+- let env = mfEnv st
7804+- mn <- getParam1 n env
7805+- let str = if typeOf v == typeOf(undefined :: String)
7806+- then unsafeCoerce v else show v
7807+- return $ FormElm (finput n "radio" str
7808+- ( isValidated mn && v== fromValidated mn) Nothing)
7809+- (fmap Radio $ valToMaybe mn)
7811+--- | encloses a set of Radio boxes. Return the option selected
7813+- :: (Monad m, Functor m, FormInput view) =>
7814+- [String -> View view m (Radio a)] -> View view m a
7817+- Radio r <- firstOf $ map (\r -> r id) rs
7820+-data CheckBoxes = CheckBoxes [String]
7822+-instance Monoid CheckBoxes where
7823+- mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
7824+- mempty= CheckBoxes []
7826+---instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where
7827+--- mappend x y= mappend <$> x <*> y
7828+--- mempty= return (CheckBoxes [])
7831+--- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation)
7832+-setCheckBox :: (FormInput view, MonadIO m) =>
7833+- Bool -> String -> View view m CheckBoxes
7834+-setCheckBox checked v= View $ do
7837+- put st{needForm= HasElems}
7838+- let env = mfEnv st
7839+- strs= map snd $ filter ((==) n . fst) env
7840+- mn= if null strs then Nothing else Just $ head strs
7842+- let ret= case val of -- !> show val of
7843+- True -> Just $ CheckBoxes strs -- !> show strs
7846+- ( finput n "checkbox" v
7847+- ( checked || (isJust mn && v== fromJust mn)) Nothing)
7850+--- | Read the checkboxes dinamically created by JavaScript within the view parameter
7851+--- see for example `selectAutocomplete` in "MFlow.Forms.Widgets"
7852+-genCheckBoxes :: (Monad m, FormInput view) => view -> View view m CheckBoxes
7853+-genCheckBoxes v= View $ do
7856+- put st{needForm= HasElems}
7857+- let env = mfEnv st
7858+- strs= map snd $ filter ((==) n . fst) env
7859+- mn= if null strs then Nothing else Just $ head strs
7861+- val <- gets inSync
7862+- let ret= case val of
7863+- True -> Just $ CheckBoxes strs
7865+- return $ FormElm (ftag "span" v `attrs`[("id",n)]) ret
7867+-whidden :: (Monad m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
7868+-whidden x= View $ do
7871+- let showx= case cast x of
7874+- r <- getParam1 n env
7875+- return . FormElm (finput n "hidden" showx False Nothing) $ valToMaybe r
7877+-getCheckBoxes :: (FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]
7878+-getCheckBoxes boxes = View $ do
7881+- let env = mfEnv st
7882+- let form= finput n "hidden" "" False Nothing
7883+- mr <- getParam1 n env
7885+- let env = mfEnv st
7886+- modify $ \st -> st{needForm= HasElems}
7887+- FormElm form2 mr2 <- runView boxes
7888+- return $ FormElm (form <> form2) $
7889+- case (mr `asTypeOf` Validated ("" :: String),mr2) of
7890+- (NoParam,_) -> Nothing
7891+- (Validated _,Nothing) -> Just []
7892+- (Validated _, Just (CheckBoxes rs)) -> Just rs
7899+- :: (FormInput view,
7904+- Maybe a -> View view m a
7905+-getTextBox ms = getParam Nothing "text" ms
7909+- :: (FormInput view,
7914+- Maybe String -> String -> Maybe a -> View view m a
7915+-getParam look type1 mvalue = View $ do
7916+- tolook <- case look of
7917+- Nothing -> genNewId
7918+- Just n -> return n
7919+- let nvalue x = case x of
7926+- let env = mfEnv st
7927+- put st{needForm= HasElems}
7928+- r <- getParam1 tolook env
7930+- Validated x -> return $ FormElm (finput tolook type1 (nvalue $ Just x) False Nothing) $ Just x
7931+- NotValidated s err -> return $ FormElm (finput tolook type1 s False Nothing <> err) $ Nothing
7932+- NoParam -> return $ FormElm (finput tolook type1 (nvalue mvalue) False Nothing) $ Nothing
7936+---getCurrentName :: MonadState (MFlowState view) m => m String
7937+---getCurrentName= do
7939+--- let parm = mfSequence st
7940+--- return $ "p"++show parm
7943+--- | Display a multiline text box and return its content
7944+-getMultilineText :: (FormInput view
7947+- -> View view m T.Text
7948+-getMultilineText nvalue = View $ do
7949+- tolook <- genNewId
7951+- r <- getParam1 tolook env
7953+- Validated x -> return $ FormElm (ftextarea tolook x) $ Just x
7954+- NotValidated s err -> return $ FormElm (ftextarea tolook (T.pack s)) Nothing
7955+- NoParam -> return $ FormElm (ftextarea tolook nvalue) Nothing
7958+---instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where
7959+--- digest mv = getBool b "True" "False"
7962+--- Nothing -> Nothing
7963+--- Just bool -> Just $ case bool of
7965+--- False -> "False"
7967+--- | Display a dropdown box with the two values (second (true) and third parameter(false))
7968+--- . With the value of the first parameter selected.
7969+-getBool :: (FormInput view,
7970+- Monad m, Functor m) =>
7971+- Bool -> String -> String -> View view m Bool
7972+-getBool mv truestr falsestr= do
7973+- r <- getSelect $ setOption truestr (fromStr truestr) <! (if mv then [("selected","true")] else [])
7974+- <|> setOption falsestr(fromStr falsestr) <! if not mv then [("selected","true")] else []
7975+- if r == truestr then return True else return False
7979+--- | Display a dropdown box with the options in the first parameter is optionally selected
7980+--- . It returns the selected option.
7981+-getSelect :: (FormInput view,
7982+- Monad m,Typeable a, Read a) =>
7983+- View view m (MFOption a) -> View view m a
7984+-getSelect opts = View $ do
7985+- tolook <- genNewId
7987+- let env = mfEnv st
7988+- put st{needForm= HasElems}
7989+- r <- getParam1 tolook env
7990+- setSessionData $ fmap MFOption $ valToMaybe r
7991+- FormElm form mr <- (runView opts)
7993+- return $ FormElm (fselect tolook form) $ valToMaybe r
7996+-newtype MFOption a= MFOption a deriving Typeable
7998+-instance (FormInput view,Monad m, Functor m) => Monoid (View view m (MFOption a)) where
8000+- mempty = Control.Applicative.empty
8002+--- | Set the option for getSelect. Options are concatenated with `<|>`
8004+- :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
8005+- a -> view -> View view m (MFOption a)
8007+- mo <- getSessionData
8009+- Nothing -> setOption1 n v False
8010+- Just Nothing -> setOption1 n v False
8011+- Just (Just (MFOption o)) -> setOption1 n v $ n == o
8013+--- | Set the selected option for getSelect. Options are concatenated with `<|>`
8015+- :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
8016+- a -> view -> View view m (MFOption a)
8017+-setSelectedOption n v= do
8018+- mo <- getSessionData
8020+- Nothing -> setOption1 n v True
8021+- Just Nothing -> setOption1 n v True
8022+- Just (Just o) -> setOption1 n v $ n == o
8025+-setOption1 :: (FormInput view,
8026+- Monad m, Typeable a, Eq a, Show a) =>
8027+- a -> view -> Bool -> View view m (MFOption a)
8028+-setOption1 nam val check= View $ do
8030+- let env = mfEnv st
8031+- put st{needForm= HasElems}
8032+- let n = if typeOf nam == typeOf(undefined :: String)
8033+- then unsafeCoerce nam
8036+- return . FormElm (foption n val check) . Just $ MFOption nam
8038+---fileUpload :: (FormInput view,
8040+--- View view m T.Text
8041+---fileUpload= getParam Nothing "file" Nothing
8044+--- | Enclose Widgets within some formating.
8045+--- @view@ is intended to be instantiated to a particular format
8047+--- NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate,
8048+--- unless the we want to enclose all the widgets in the right side.
8049+--- Most of the type errors in the DSL are due to the low priority of this operator.
8051+--- This is a widget, which is a table with some links. it returns an Int
8053+--- > import MFlow.Forms.Blaze.Html
8055+--- > tableLinks :: View Html Int
8056+--- > table ! At.style "border:1;width:20%;margin-left:auto;margin-right:auto"
8057+--- > <<< caption << text "choose an item"
8058+--- > ++> thead << tr << ( th << b << text "item" <> th << b << text "times chosen")
8060+--- > <<< tr ! rowspan "2" << td << linkHome
8061+--- > ++> (tr <<< td <<< wlink IPhone (b << text "iphone") <++ td << ( b << text (fromString $ show ( cart V.! 0)))
8062+--- > <|> tr <<< td <<< wlink IPod (b << text "ipad") <++ td << ( b << text (fromString $ show ( cart V.! 1)))
8063+--- > <|> tr <<< td <<< wlink IPad (b << text "ipod") <++ td << ( b << text (fromString $ show ( cart V.! 2))))
8065+-(<<<) :: (Monad m, Monoid view)
8069+-(<<<) v form= View $ do
8070+- FormElm f mx <- runView form
8071+- return $ FormElm (v f) mx
8081+--- | Append formatting code to a widget
8083+--- @ getString "hi" <++ H1 << "hi there"@
8085+--- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
8086+-(<++) :: (Monad m, Monoid v)
8090+-(<++) form v= View $ do
8091+- FormElm f mx <- runView form
8092+- return $ FormElm ( f <> v) mx
8096+--- | Prepend formatting code to a widget
8098+--- @bold << "enter name" ++> getString Nothing @
8100+--- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
8101+-(++>) :: (Monad m, Monoid view)
8102+- => view -> View view m a -> View view m a
8103+-html ++> w = -- (html <>) <<< digest
8105+- FormElm f mx <- runView w
8106+- return $ FormElm (html <> f) mx
8110+--- | Add attributes to the topmost tag of a widget
8112+--- it has a fixity @infix 8@
8114+-widget <! attribs= View $ do
8115+- FormElm fs mx <- runView widget
8116+- return $ FormElm (fs `attrs` attribs) mx -- (head fs `attrs` attribs:tail fs) mx
8118+--- [hfs] -> return $ FormElm [hfs `attrs` attribs] mx
8119+--- _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs
8122+--- | Is an example of login\/register validation form needed by 'userWidget'. In this case
8123+--- the form field appears in a single line. it shows, in sequence, entries for the username,
8124+--- password, a button for loging, a entry to repeat password necesary for registering
8125+--- and a button for registering.
8126+--- The user can build its own user login\/validation forms by modifying this example
8129+--- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\")
8130+--- \<\+\> fromStr \" password again\" \+\> getPassword \<\* submitButton \"register\"
8132+-userFormLine :: (FormInput view, Functor m, Monad m)
8133+- => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr)
8135+- ((,) <$> getString (Just "enter user") <! [("size","5")]
8136+- <*> getPassword <! [("size","5")]
8137+- <** submitButton "login")
8138+- <+> (fromStr " password again" ++> getPassword <! [("size","5")]
8139+- <** submitButton "register")
8141+--- | Example of user\/password form (no validation) to be used with 'userWidget'
8142+-userLogin :: (FormInput view, Functor m, Monad m)
8143+- => View view m (Maybe (UserStr,PasswdStr), Maybe String)
8145+- ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")]
8146+- <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]
8147+- <** submitButton "login")
8153+--- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets.
8155+--- It returns a non valid value.
8156+-noWidget :: (FormInput view,
8157+- Monad m, Functor m) =>
8159+-noWidget= Control.Applicative.empty
8160++import qualified Data.String as S
8161++import qualified Data.Text as T
8162++import Data.Text.Encoding
8164++--import qualified Data.CaseInsensitive as CI
8165++import Data.Typeable
8167++import Control.Monad.State.Strict
8169++import Control.Applicative
8170++import Control.Exception
8171++import Control.Concurrent
8172++import Control.Workflow as WF
8173++import Control.Monad.Identity
8174++import Unsafe.Coerce
8175++import Data.List(intersperse)
8177++import qualified Data.Map as M
8178++import System.IO.Unsafe
8179++import Data.Char(isNumber,toLower)
8180++import Network.HTTP.Types.Header
8181++import MFlow.Forms.Cache
8183++-- | Validates a form or widget result against a validating procedure
8185++-- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@
8187++ :: (FormInput view, Monad m) =>
8189++ -> (a -> WState view m (Maybe view))
8191++validate formt val= View $ do
8192++ FormElm form mx <- runView formt
8196++ modify (\s -> s{inSync= True})
8199++ return $ FormElm ( form <> inred str) Nothing
8200++ Nothing -> return $ FormElm form mx
8201++ _ -> return $ FormElm form mx
8203++-- | Actions are callbacks that are executed when a widget is validated.
8204++-- A action may be a complete flow in the flowM monad. It takes complete control of the navigation
8205++-- while it is executed. At the end it return the result to the caller and display the original
8207++-- It is useful when the widget is inside widget containers that may treat it as a black box.
8209++-- It returns a result that can be significative or, else, be ignored with '<**' and '**>'.
8210++-- An action may or may not initiate his own dialog with the user via `ask`
8212++ :: (FormInput view, Monad m)
8214++ -> (a -> FlowM view m b)
8220++ let seq = mfSequence s
8221++ put s{mfSequence=mfSequence s+ 100,mfEnv=[],newAsk=True}
8222++ r <- flowToView $ ac x
8223++ modify $ \s-> s{mfSequence= seq, mfEnv= env}
8228++ r <- runSup $ runFlowM x
8231++ return (FormElm mempty $ Just x)
8233++ return (FormElm mempty $ Just x)
8235++ modify $ \s ->s{notSyncInAction= True}
8236++ return (FormElm mempty Nothing)
8238++-- | change the rendering and the return value of a page. This is superseeded by page flows.
8239++wmodify :: (Monad m, FormInput v)
8241++ -> (v -> Maybe a -> WState v m (v, Maybe b))
8243++wmodify formt act = View $ do
8244++ FormElm f mx <- runView formt
8245++ (f',mx') <- act f mx
8246++ return $ FormElm f' mx'
8248++-- | Display a text box and return a non empty String
8249++getString :: (FormInput view,Monad m) =>
8250++ Maybe String -> View view m String
8251++getString ms = getTextBox ms
8253++ \s -> if null s then return (Just $ fromStr "")
8254++ else return Nothing
8256++-- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation)
8257++getInteger :: (FormInput view, MonadIO m) =>
8258++ Maybe Integer -> View view m Integer
8259++getInteger = getTextBox
8261++-- | Display a text box and return a Int (if the value entered is not an Int, fails the validation)
8262++getInt :: (FormInput view, MonadIO m) =>
8263++ Maybe Int -> View view m Int
8264++getInt = getTextBox
8266++-- | Display a password box
8267++getPassword :: (FormInput view,
8269++ View view m String
8270++getPassword = getParam Nothing "password" Nothing
8272++newtype Radio a= Radio a
8274++-- | Implement a radio button that perform a submit when pressed.
8275++-- the parameter is the name of the radio group
8276++setRadioActive :: (FormInput view, MonadIO m,
8277++ Read a, Typeable a, Eq a, Show a) =>
8278++ a -> String -> View view m (Radio a)
8279++setRadioActive v n = View $ do
8281++ put st{needForm= HasElems }
8282++ let env = mfEnv st
8283++ mn <- getParam1 n env
8284++ let str = if typeOf v == typeOf(undefined :: String)
8285++ then unsafeCoerce v else show v
8286++ return $ FormElm (finput n "radio" str
8287++ ( isValidated mn && v== fromValidated mn) (Just "this.form.submit()"))
8288++ (fmap Radio $ valToMaybe mn)
8291++-- | Implement a radio button
8292++-- the parameter is the name of the radio group
8293++setRadio :: (FormInput view, MonadIO m,
8294++ Read a, Typeable a, Eq a, Show a) =>
8295++ a -> String -> View view m (Radio a)
8296++setRadio v n= View $ do
8298++ put st{needForm= HasElems}
8299++ let env = mfEnv st
8300++ mn <- getParam1 n env
8301++ let str = if typeOf v == typeOf(undefined :: String)
8302++ then unsafeCoerce v else show v
8303++ return $ FormElm (finput n "radio" str
8304++ ( isValidated mn && v== fromValidated mn) Nothing)
8305++ (fmap Radio $ valToMaybe mn)
8307++-- | encloses a set of Radio boxes. Return the option selected
8309++ :: (Monad m, Functor m, FormInput view) =>
8310++ [String -> View view m (Radio a)] -> View view m a
8313++ Radio r <- firstOf $ map (\r -> r id) rs
8316++data CheckBoxes = CheckBoxes [String]
8318++instance Monoid CheckBoxes where
8319++ mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
8320++ mempty= CheckBoxes []
8322++--instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where
8323++-- mappend x y= mappend <$> x <*> y
8324++-- mempty= return (CheckBoxes [])
8327++-- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation)
8328++setCheckBox :: (FormInput view, MonadIO m) =>
8329++ Bool -> String -> View view m CheckBoxes
8330++setCheckBox checked v= View $ do
8333++ put st{needForm= HasElems}
8334++ let env = mfEnv st
8335++ strs= map snd $ filter ((==) n . fst) env
8336++ mn= if null strs then Nothing else Just $ head strs
8338++ let ret= case val of -- !> show val of
8339++ True -> Just $ CheckBoxes strs -- !> show strs
8342++ ( finput n "checkbox" v
8343++ ( checked || (isJust mn && v== fromJust mn)) Nothing)
8346++-- | Read the checkboxes dinamically created by JavaScript within the view parameter
8347++-- see for example `selectAutocomplete` in "MFlow.Forms.Widgets"
8348++genCheckBoxes :: (Monad m, FormInput view) => view -> View view m CheckBoxes
8349++genCheckBoxes v= View $ do
8352++ put st{needForm= HasElems}
8353++ let env = mfEnv st
8354++ strs= map snd $ filter ((==) n . fst) env
8355++ mn= if null strs then Nothing else Just $ head strs
8357++ val <- gets inSync
8358++ let ret= case val of
8359++ True -> Just $ CheckBoxes strs
8361++ return $ FormElm (ftag "span" v `attrs`[("id",n)]) ret
8363++whidden :: (Monad m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
8364++whidden x= View $ do
8367++ let showx= case cast x of
8370++ r <- getParam1 n env
8371++ return . FormElm (finput n "hidden" showx False Nothing) $ valToMaybe r
8373++getCheckBoxes :: (FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]
8374++getCheckBoxes boxes = View $ do
8377++ let env = mfEnv st
8378++ let form= finput n "hidden" "" False Nothing
8379++ mr <- getParam1 n env
8381++ let env = mfEnv st
8382++ modify $ \st -> st{needForm= HasElems}
8383++ FormElm form2 mr2 <- runView boxes
8384++ return $ FormElm (form <> form2) $
8385++ case (mr `asTypeOf` Validated ("" :: String),mr2) of
8386++ (NoParam,_) -> Nothing
8387++ (Validated _,Nothing) -> Just []
8388++ (Validated _, Just (CheckBoxes rs)) -> Just rs
8395++ :: (FormInput view,
8400++ Maybe a -> View view m a
8401++getTextBox ms = getParam Nothing "text" ms
8405++ :: (FormInput view,
8410++ Maybe String -> String -> Maybe a -> View view m a
8411++getParam look type1 mvalue = View $ do
8412++ tolook <- case look of
8413++ Nothing -> genNewId
8414++ Just n -> return n
8415++ let nvalue x = case x of
8422++ let env = mfEnv st
8423++ put st{needForm= HasElems}
8424++ r <- getParam1 tolook env
8426++ Validated x -> return $ FormElm (finput tolook type1 (nvalue $ Just x) False Nothing) $ Just x
8427++ NotValidated s err -> return $ FormElm (finput tolook type1 s False Nothing <> err) $ Nothing
8428++ NoParam -> return $ FormElm (finput tolook type1 (nvalue mvalue) False Nothing) $ Nothing
8432++--getCurrentName :: MonadState (MFlowState view) m => m String
8433++--getCurrentName= do
8435++-- let parm = mfSequence st
8436++-- return $ "p"++show parm
8439++-- | Display a multiline text box and return its content
8440++getMultilineText :: (FormInput view
8443++ -> View view m T.Text
8444++getMultilineText nvalue = View $ do
8445++ tolook <- genNewId
8447++ r <- getParam1 tolook env
8449++ Validated x -> return $ FormElm (ftextarea tolook x) $ Just x
8450++ NotValidated s err -> return $ FormElm (ftextarea tolook (T.pack s)) Nothing
8451++ NoParam -> return $ FormElm (ftextarea tolook nvalue) Nothing
8454++--instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where
8455++-- digest mv = getBool b "True" "False"
8458++-- Nothing -> Nothing
8459++-- Just bool -> Just $ case bool of
8461++-- False -> "False"
8463++-- | Display a dropdown box with the two values (second (true) and third parameter(false))
8464++-- . With the value of the first parameter selected.
8465++getBool :: (FormInput view,
8466++ Monad m, Functor m) =>
8467++ Bool -> String -> String -> View view m Bool
8468++getBool mv truestr falsestr= do
8469++ r <- getSelect $ setOption truestr (fromStr truestr) <! (if mv then [("selected","true")] else [])
8470++ <|> setOption falsestr(fromStr falsestr) <! if not mv then [("selected","true")] else []
8471++ if r == truestr then return True else return False
8475++-- | Display a dropdown box with the options in the first parameter is optionally selected
8476++-- . It returns the selected option.
8477++getSelect :: (FormInput view,
8478++ Monad m,Typeable a, Read a) =>
8479++ View view m (MFOption a) -> View view m a
8480++getSelect opts = View $ do
8481++ tolook <- genNewId
8483++ let env = mfEnv st
8484++ put st{needForm= HasElems}
8485++ r <- getParam1 tolook env
8486++ setSessionData $ fmap MFOption $ valToMaybe r
8487++ FormElm form mr <- (runView opts)
8489++ return $ FormElm (fselect tolook form) $ valToMaybe r
8492++newtype MFOption a= MFOption a deriving Typeable
8494++instance (FormInput view,Monad m, Functor m) => Monoid (View view m (MFOption a)) where
8496++ mempty = Control.Applicative.empty
8498++-- | Set the option for getSelect. Options are concatenated with `<|>`
8500++ :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
8501++ a -> view -> View view m (MFOption a)
8503++ mo <- getSessionData
8505++ Nothing -> setOption1 n v False
8506++ Just Nothing -> setOption1 n v False
8507++ Just (Just (MFOption o)) -> setOption1 n v $ n == o
8509++-- | Set the selected option for getSelect. Options are concatenated with `<|>`
8511++ :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
8512++ a -> view -> View view m (MFOption a)
8513++setSelectedOption n v= do
8514++ mo <- getSessionData
8516++ Nothing -> setOption1 n v True
8517++ Just Nothing -> setOption1 n v True
8518++ Just (Just o) -> setOption1 n v $ n == o
8521++setOption1 :: (FormInput view,
8522++ Monad m, Typeable a, Eq a, Show a) =>
8523++ a -> view -> Bool -> View view m (MFOption a)
8524++setOption1 nam val check= View $ do
8526++ let env = mfEnv st
8527++ put st{needForm= HasElems}
8528++ let n = if typeOf nam == typeOf(undefined :: String)
8529++ then unsafeCoerce nam
8532++ return . FormElm (foption n val check) . Just $ MFOption nam
8534++-- | upload a file to a temporary file in the server
8536++-- The user can move, rename it etc.
8537++fileUpload :: (FormInput view,
8538++ Monad m,Functor m) =>
8539++ View view m (String
8542++ ) -- ^ ( original file, file type, temporal uploaded)
8544++ getParam Nothing "file" Nothing <** modify ( \st -> st{mfFileUpload = True})
8548++-- | Enclose Widgets within some formating.
8549++-- @view@ is intended to be instantiated to a particular format
8551++-- NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate,
8552++-- unless the we want to enclose all the widgets in the right side.
8553++-- Most of the type errors in the DSL are due to the low priority of this operator.
8555++-- This is a widget, which is a table with some links. it returns an Int
8557++-- > import MFlow.Forms.Blaze.Html
8559++-- > tableLinks :: View Html Int
8560++-- > table ! At.style "border:1;width:20%;margin-left:auto;margin-right:auto"
8561++-- > <<< caption << text "choose an item"
8562++-- > ++> thead << tr << ( th << b << text "item" <> th << b << text "times chosen")
8564++-- > <<< tr ! rowspan "2" << td << linkHome
8565++-- > ++> (tr <<< td <<< wlink IPhone (b << text "iphone") <++ td << ( b << text (fromString $ show ( cart V.! 0)))
8566++-- > <|> tr <<< td <<< wlink IPod (b << text "ipad") <++ td << ( b << text (fromString $ show ( cart V.! 1)))
8567++-- > <|> tr <<< td <<< wlink IPad (b << text "ipod") <++ td << ( b << text (fromString $ show ( cart V.! 2))))
8569++(<<<) :: (Monad m, Monoid view)
8573++(<<<) v form= View $ do
8574++ FormElm f mx <- runView form
8575++ return $ FormElm (v f) mx
8585++-- | Append formatting code to a widget
8587++-- @ getString "hi" '<++' H1 '<<' "hi there"@
8589++-- It has a infix prority: @infixr 6@ higher than '<<<' and most other operators.
8590++(<++) :: (Monad m, Monoid v)
8594++(<++) form v= View $ do
8595++ FormElm f mx <- runView form
8596++ return $ FormElm ( f <> v) mx
8600++-- | Prepend formatting code to a widget
8602++-- @bold '<<' "enter name" '++>' 'getString' 'Nothing' @
8604++-- It has a infix prority: @infixr 6@ higher than '<<<' and most other operators
8605++(++>) :: (Monad m, Monoid view)
8606++ => view -> View view m a -> View view m a
8607++html ++> w = -- (html <>) <<< digest
8609++ FormElm f mx <- runView w
8610++ return $ FormElm (html <> f) mx
8614++-- | Add attributes to the topmost tag of a widget
8616++-- It has a fixity @infix 8@
8618++widget <! attribs= View $ do
8619++ FormElm fs mx <- runView widget
8620++ return $ FormElm (fs `attrs` attribs) mx -- (head fs `attrs` attribs:tail fs) mx
8622++-- [hfs] -> return $ FormElm [hfs `attrs` attribs] mx
8623++-- _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs
8626++-- | Is an example of login\/register validation form needed by 'userWidget'. In this case
8627++-- the form field appears in a single line. it shows, in sequence, entries for the username,
8628++-- password, a button for loging, a entry to repeat password necesary for registering
8629++-- and a button for registering.
8630++-- The user can build its own user login\/validation forms by modifying this example
8633++-- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\")
8634++-- \<\+\> fromStr \" password again\" \+\> getPassword \<\* submitButton \"register\"
8636++userFormLine :: (FormInput view, Functor m, Monad m)
8637++ => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr)
8639++ ((,) <$> getString (Just "enter user") <! [("size","5")]
8640++ <*> getPassword <! [("size","5")]
8641++ <** submitButton "login")
8642++ <+> (fromStr " password again" ++> getPassword <! [("size","5")]
8643++ <** submitButton "register")
8645++-- | Example of user\/password form (no validation) to be used with 'userWidget'
8646++userLogin :: (FormInput view, Functor m, Monad m)
8647++ => View view m (Maybe (UserStr,PasswdStr), Maybe String)
8649++ ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")]
8650++ <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]
8651++ <** submitButton "login")
8657++-- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets.
8659++-- It returns a non valid value.
8660++noWidget :: (FormInput view,
8661++ Monad m, Functor m) =>
8663++noWidget= Control.Applicative.empty
8665+ -- | a sinonym of noWidget that can be used in a monadic expression in the View monad does not continue
8666+-stop :: (FormInput view,
8667+- Monad m, Functor m) =>
8668++stop :: (FormInput view,
8669++ Monad m, Functor m) =>
8671+ stop= Control.Applicative.empty
8673+--- | Render a Show-able value and return it
8675+- :: (Monad m, Functor m, Show a, FormInput view) =>
8676+- a -> View view m a
8677+-wrender x = (fromStr $ show x) ++> return x
8679+--- | Render raw view formatting. It is useful for displaying information.
8680+-wraw :: Monad m => view -> View view m ()
8681+-wraw x= View . return . FormElm x $ Just ()
8683+--- To display some rendering and return a no valid value
8684+-notValid :: Monad m => view -> View view m a
8685+-notValid x= View . return $ FormElm x Nothing
8687+--- | Wether the user is logged or is anonymous
8688+-isLogged :: MonadState (MFlowState v) m => m Bool
8690+- rus <- return . tuser =<< gets mfToken
8691+- return . not $ rus == anonymous
8693+--- | return the result if going forward
8695+--- If the process is backtraking, it does not validate,
8696+--- in order to continue the backtracking
8697+-returnIfForward :: (Monad m, FormInput view,Functor m) => b -> View view m b
8698+-returnIfForward x = do
8700+- if back then noWidget else return x
8702+--- | forces backtracking if the widget validates, because a previous page handle this widget response
8703+--- . This is useful for recurrent cached widgets or `absLink`s that are present in multiple pages. For example
8704+--- in the case of menus or common options. The active elements of this widget must be cached with no timeout.
8705+-retry :: Monad m => View v m a -> View v m ()
8706+-retry w = View $ do
8707+- FormElm v mx <- runView w
8708+- when (isJust mx) $ modify $ \st -> st{inSync = False}
8709+- return $ FormElm v Nothing
8711+--- | It creates a widget for user login\/registering. If a user name is specified
8712+--- in the first parameter, it is forced to login\/password as this specific user.
8713+--- If this user was already logged, the widget return the user without asking.
8714+--- If the user press the register button, the new user-password is registered and the
8717+-userWidget :: ( MonadIO m, Functor m
8720+- -> View view m (Maybe (UserStr,PasswdStr), Maybe String)
8721+- -> View view m String
8722+-userWidget muser formuser = userWidget' muser formuser login1
8724+--- | Uses 4 different keys to encrypt the 4 parts of a MFlow cookie.
8726+-paranoidUserWidget muser formuser = userWidget' muser formuser paranoidLogin1
8728+--- | Uses a single key to encrypt the MFlow cookie.
8730+-encryptedUserWidget muser formuser = userWidget' muser formuser encryptedLogin1
8732+-userWidget' muser formuser login1Func = do
8733+- user <- getCurrentUser
8734+- if muser== Just user || isNothing muser && user/= anonymous
8735+- then returnIfForward user
8736+- else formuser `validate` val muser `wcallback` login1Func
8738+- val _ (Nothing,_) = return . Just $ fromStr "Plese fill in the user/passwd to login, or user/passwd/passwd to register"
8740+- val mu (Just us, Nothing)=
8741+- if isNothing mu || isJust mu && fromJust mu == fst us
8742+- then userValidate us
8743+- else return . Just $ fromStr "This user has no permissions for this task"
8745+- val mu (Just us, Just p)=
8746+- if isNothing mu || isJust mu && fromJust mu == fst us
8747+- then if Data.List.length p > 0 && snd us== p
8748+- then return Nothing
8749+- else return . Just $ fromStr "The passwords do not match"
8750+- else return . Just $ fromStr "wrong user for the operation"
8752+--- val _ _ = return . Just $ fromStr "Please fill in the fields for login or register"
8755+- :: (MonadIO m, MonadState (MFlowState view) m) =>
8756+- (Maybe (UserStr, PasswdStr), Maybe t) -> m UserStr
8757+-login1 uname = login1' uname login
8759+-paranoidLogin1 uname = login1' uname paranoidLogin
8761+-encryptedLogin1 uname = login1' uname encryptedLogin
8763+-login1' (Just (uname,_), Nothing) loginFunc= loginFunc uname >> return uname
8764+-login1' (Just us@(u,p), Just _) loginFunc= do -- register button pressed
8769+--- | change the user
8771+--- It is supposed that the user has been validated
8773+-login uname = login' uname setCookie
8775+-paranoidLogin uname = login' uname setParanoidCookie
8777+-encryptedLogin uname = login' uname setEncryptedCookie
8780+- :: (Num a1, S.IsString a, MonadIO m,
8781+- MonadState (MFlowState view) m) =>
8782+- String -> (String -> String -> a -> Maybe a1 -> m ()) -> m ()
8783+-login' uname setCookieFunc = do
8785+- if back then return () else do
8787+- let t = mfToken st
8789+- when (u /= uname) $ do
8790+- let t'= t{tuser= uname}
8791+- -- moveState (twfname t) t t'
8792+- put st{mfToken= t'}
8793+- liftIO $ deleteTokenInList t
8794+- liftIO $ addTokenToList t'
8795+- setCookieFunc cookieuser uname "/" (Just $ 365*24*60*60)
8797+-logout = logout' setCookie
8799+-paranoidLogout = logout' setParanoidCookie
8801+-encryptedLogout = logout' setEncryptedCookie
8804+--- | logout. The user is reset to the `anonymous` user
8806+- :: (Num a1,S.IsString a, MonadIO m,
8807+- MonadState (MFlowState view) m) =>
8808+- (String -> [Char] -> a -> Maybe a1 -> m ()) -> m ()
8810++-- | Render a Show-able value and return it
8812++ :: (Monad m, Functor m, Show a, FormInput view) =>
8813++ a -> View view m a
8814++wrender x = (fromStr $ show x) ++> return x
8816++-- | Render raw view formatting. It is useful for displaying information.
8817++wraw :: Monad m => view -> View view m ()
8818++wraw x= View . return . FormElm x $ Just ()
8820++-- To display some rendering and return a no valid value
8821++notValid :: Monad m => view -> View view m a
8822++notValid x= View . return $ FormElm x Nothing
8824++-- | Wether the user is logged or is anonymous
8825++isLogged :: MonadState (MFlowState v) m => m Bool
8827++ rus <- return . tuser =<< gets mfToken
8828++ return . not $ rus == anonymous
8830++-- | return the result if going forward
8832++-- If the process is backtraking, it does not validate,
8833++-- in order to continue the backtracking
8834++returnIfForward :: (Monad m, FormInput view,Functor m) => b -> View view m b
8835++returnIfForward x = do
8837++ if back then noWidget else return x
8839++-- | forces backtracking if the widget validates, because a previous page handle this widget response
8840++-- . This is useful for recurrent cached widgets or `absLink`s that are present in multiple pages. For example
8841++-- in the case of menus or common options. The active elements of this widget must be cached with no timeout.
8842++retry :: Monad m => View v m a -> View v m ()
8843++retry w = View $ do
8844++ FormElm v mx <- runView w
8845++ when (isJust mx) $ modify $ \st -> st{inSync = False}
8846++ return $ FormElm v Nothing
8848++-- | It creates a widget for user login\/registering. If a user name is specified
8849++-- in the first parameter, it is forced to login\/password as this specific user.
8850++-- If this user was already logged, the widget return the user without asking.
8851++-- If the user press the register button, the new user-password is registered and the
8854++userWidget :: ( MonadIO m, Functor m
8857++ -> View view m (Maybe (UserStr,PasswdStr), Maybe String)
8858++ -> View view m String
8859++userWidget muser formuser = userWidget' muser formuser login1
8861++-- | Uses 4 different keys to encrypt the 4 parts of a MFlow cookie.
8863++paranoidUserWidget muser formuser = userWidget' muser formuser paranoidLogin1
8865++-- | Uses a single key to encrypt the MFlow cookie.
8867++encryptedUserWidget muser formuser = userWidget' muser formuser encryptedLogin1
8869++userWidget' muser formuser login1Func = do
8870++ user <- getCurrentUser
8871++ if muser== Just user || isNothing muser && user/= anonymous
8872++ then returnIfForward user
8873++ else formuser `validate` val muser `wcallback` login1Func
8875++ val _ (Nothing,_) = return . Just $ fromStr "Plese fill in the user/passwd to login, or user/passwd/passwd to register"
8877++ val mu (Just us, Nothing)=
8878++ if isNothing mu || isJust mu && fromJust mu == fst us
8879++ then userValidate us
8880++ else return . Just $ fromStr "This user has no permissions for this task"
8882++ val mu (Just us, Just p)=
8883++ if isNothing mu || isJust mu && fromJust mu == fst us
8884++ then if Data.List.length p > 0 && snd us== p
8885++ then return Nothing
8886++ else return . Just $ fromStr "The passwords do not match"
8887++ else return . Just $ fromStr "wrong user for the operation"
8889++-- val _ _ = return . Just $ fromStr "Please fill in the fields for login or register"
8892++ :: (MonadIO m, MonadState (MFlowState view) m) =>
8893++ (Maybe (UserStr, PasswdStr), Maybe t) -> m UserStr
8894++login1 uname = login1' uname login
8896++paranoidLogin1 uname = login1' uname paranoidLogin
8898++encryptedLogin1 uname = login1' uname encryptedLogin
8900++login1' (Just (uname,_), Nothing) loginFunc= loginFunc uname >> return uname
8901++login1' (Just us@(u,p), Just _) loginFunc= do -- register button pressed
8906++-- | change the user
8908++-- It is supposed that the user has been validated
8910++login uname = login' uname setCookie
8912++paranoidLogin uname = login' uname setParanoidCookie
8914++encryptedLogin uname = login' uname setEncryptedCookie
8917++ :: (Num a1, S.IsString a, MonadIO m,
8918++ MonadState (MFlowState view) m) =>
8919++ String -> (String -> String -> a -> Maybe a1 -> m ()) -> m ()
8920++login' uname setCookieFunc = do
8922++ if back then return () else do
8924++ let t = mfToken st
8926++ when (u /= uname) $ do
8927++ let t'= t{tuser= uname}
8928++ -- moveState (twfname t) t t'
8929++ put st{mfToken= t'}
8930++ liftIO $ deleteTokenInList t
8931++ liftIO $ addTokenToList t'
8932++ setCookieFunc cookieuser uname "/" (Just $ 365*24*60*60)
8934++logout = logout' setCookie
8936++paranoidLogout = logout' setParanoidCookie
8938++encryptedLogout = logout' setEncryptedCookie
8941++-- | logout. The user is reset to the `anonymous` user
8943++ :: (Num a1,S.IsString a, MonadIO m,
8944++ MonadState (MFlowState view) m) =>
8945++ (String -> [Char] -> a -> Maybe a1 -> m ()) -> m ()
8946+ logout' setCookieFunc = do
8949+- if back then return () else do
8951+- let t = mfToken st
8952+- t'= t{tuser= anonymous}
8953+- when (tuser t /= anonymous) $ do
8954+--- moveState (twfname t) t t'
8955+- put st{mfToken= t'}
8956+--- liftIO $ deleteTokenInList t
8957+- liftIO $ addTokenToList t'
8958+- setCookieFunc cookieuser anonymous "/" (Just $ -1000)
8960+--- | If not logged, perform login. otherwise return the user
8962+--- @getUserSimple= getUser Nothing userFormLine@
8963+-getUserSimple :: ( FormInput view, Typeable view)
8964+- => FlowM view IO String
8965+-getUserSimple= getUser Nothing userFormLine
8967+--- | Very basic user authentication. The user is stored in a cookie.
8968+--- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed
8969+--- user-password combination.
8970+--- The user-password combination is only asked if the user has not logged already
8971+--- otherwise, the stored username is returned.
8973+--- @getUser mu form= ask $ userWidget mu form@
8974+-getUser :: ( FormInput view, Typeable view)
8976+- -> View view IO (Maybe (UserStr,PasswdStr), Maybe String)
8977+- -> FlowM view IO String
8978+-getUser mu form= ask $ userWidget mu form
8980+--- | Authentication against `userRegister`ed users.
8981+--- to be used with `validate`
8982+-userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view)
8983+-userValidate (u,p) = liftIO $ do
8984+- Auth _ val <- getAuthMethod
8985+- val u p >>= return . fmap fromStr
8989+--- | for compatibility with the same procedure in 'MFLow.Forms.Test.askt'.
8990+--- This is the non testing version
8992+--- > askt v w= ask w
8994+--- hide one or the other
8995+-askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a
8999+--- | It is the way to interact with the user.
9000+--- It takes a widget and return the input result. If the widget is not validated (return @Nothing@)
9001+--- , the page is presented again
9003+--- If the environment or the URL has the parameters being looked at, maybe as a result of a previous interaction,
9004+--- it will not ask to the user and return the result.
9005+--- To force asking in any case, add an `clearEnv` statement before.
9006+--- It also handles ajax requests
9008+--- 'ask' also synchronizes the execution of the flow with the user page navigation by
9010+--- * Backtracking (invoking previous 'ask' staement in the flow) when detecting mismatches between
9011+--- get and post parameters and what is expected by the widgets
9012+--- until a total or partial match is found.
9014+--- * Advancing in the flow by matching a single requests with one or more sucessive ask statements
9016+--- Backtracking and advancing can occur in a single request, so the flow in any state can reach any
9017+--- other state in the flow if the request has the required parameters.
9018+-ask :: (FormInput view) =>
9019+- View view IO a -> FlowM view IO a
9022++ if back then return () else do
9024++ let t = mfToken st
9025++ t'= t{tuser= anonymous}
9026++ when (tuser t /= anonymous) $ do
9027++-- moveState (twfname t) t t'
9028++ put st{mfToken= t'}
9029++-- liftIO $ deleteTokenInList t
9030++ liftIO $ addTokenToList t'
9031++ setCookieFunc cookieuser anonymous "/" (Just $ -1000)
9033++-- | If not logged, perform login. otherwise return the user
9035++-- @getUserSimple= getUser Nothing userFormLine@
9036++getUserSimple :: ( FormInput view, Typeable view)
9037++ => FlowM view IO String
9038++getUserSimple= getUser Nothing userFormLine
9040++-- | Very basic user authentication. The user is stored in a cookie.
9041++-- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed
9042++-- user-password combination.
9043++-- The user-password combination is only asked if the user has not logged already
9044++-- otherwise, the stored username is returned.
9046++-- @getUser mu form= ask $ userWidget mu form@
9047++getUser :: ( FormInput view, Typeable view)
9049++ -> View view IO (Maybe (UserStr,PasswdStr), Maybe String)
9050++ -> FlowM view IO String
9051++getUser mu form= ask $ userWidget mu form
9053++-- | Authentication against `userRegister`ed users.
9054++-- to be used with `validate`
9055++userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view)
9056++userValidate (u,p) = liftIO $ do
9057++ Auth _ val <- getAuthMethod
9058++ val u p >>= return . fmap fromStr
9062++-- | for compatibility with the same procedure in 'MFLow.Forms.Test.askt'.
9063++-- This is the non testing version
9065++-- > askt v w= ask w
9067++-- hide one or the other
9068++askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a
9072++-- | It is the way to interact with the user.
9073++-- It takes a widget and return the input result. If the widget is not validated (return @Nothing@)
9074++-- , the page is presented again
9076++-- If the environment or the URL has the parameters being looked at, maybe as a result of a previous interaction,
9077++-- it will not ask to the user and return the result.
9078++-- To force asking in any case, add an `clearEnv` statement before.
9079++-- It also handles ajax requests
9081++-- 'ask' also synchronizes the execution of the flow with the user page navigation by
9083++-- * Backtracking (invoking previous 'ask' staement in the flow) when detecting mismatches between
9084++-- get and post parameters and what is expected by the widgets
9085++-- until a total or partial match is found.
9087++-- * Advancing in the flow by matching a single requests with one or more sucessive ask statements
9089++-- Backtracking and advancing can occur in a single request, so the flow in any state can reach any
9090++-- other state in the flow if the request has the required parameters.
9091++ask :: (FormInput view) =>
9092++ View view IO a -> FlowM view IO a
9096+ st1 <- get >>= \s -> return s{mfSequence=
9097+ let seq= mfSequence s in
9098+ if seq ==inRecovery then 0 else seq
9099+- ,mfHttpHeaders =[],mfAutorefresh= False }
9100+- if not . null $ mfTrace st1 then fail "" else do
9102+- let env= mfEnv st1
9103+- mv1= lookup "ajax" env
9104+- majax1= mfAjax st1
9106+- case (majax1,mv1,M.lookup (fromJust mv1)(fromJust majax1), lookup "val" env) of
9107+- (Just ajaxl,Just v1,Just f, Just v2) -> do
9108+- FlowM . lift $ (unsafeCoerce f) v2
9109+- FlowM $ lift nextMessage
9113++ ,mfHttpHeaders =[],mfAutorefresh= False }
9114++ if not . null $ mfTrace st1 then fail "" else do
9116++ let env= mfEnv st1
9117++ mv1= lookup "ajax" env
9118++ majax1= mfAjax st1
9120++ case (majax1,mv1,M.lookup (fromJust mv1)(fromJust majax1), lookup "val" env) of
9121++ (Just ajaxl,Just v1,Just f, Just v2) -> do
9122++ FlowM . lift $ (unsafeCoerce f) v2
9123++ FlowM $ lift nextMessage
9129+ -- mfPagePath : contains the REST path of the page.
9130+@@ -1044,252 +1052,250 @@
9131+ -- if exist and it is not prefix of the current path being navigated to, backtrack
9132+ else if not $ pagepath `isPrefixOf` mfPath st1 then fail "" -- !> ("pagepath fail with "++ show (mfPath st1))
9135+- let st= st1{needForm= NoElems, inSync= False, mfRequirements= [], linkMatched= False}
9137+- FormElm forms mx <- FlowM . lift $ runView w
9140+- if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w
9145+- put st'{newAsk= True, mfEnv=[]}
9146+- breturn x -- !> ("BRETURN "++ show (mfPagePath st') )
9149+- if not (inSync st') && not (newAsk st')
9150+- -- !> ("insync="++show (inSync st'))
9151+- -- !> ("newask="++show (newAsk st'))
9152+- then fail "" -- !> "FAIL sync"
9153+- else if mfAutorefresh st' then do
9154+- resetState st st' -- !> ("EN AUTOREFRESH" ++ show [ mfPagePath st,mfPath st,mfPagePath st'])
9156++ let st= st1{needForm= NoElems, inSync= False, linkMatched= False
9157++ ,mfRequirements= []
9158++ ,mfInstalledScripts= if newAsk st1 then [] else mfInstalledScripts st1}
9160++ FormElm forms mx <- FlowM . lift $ runView w
9163++ if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w
9168++ put st'{newAsk= True, mfEnv=[]}
9169++ breturn x -- !> ("BRETURN "++ show (mfPagePath st') )
9172++ if not (inSync st') && not (newAsk st')
9173++ -- !> ("insync="++show (inSync st'))
9174++ -- !> ("newask="++show (newAsk st'))
9175++ then fail "" -- !> "FAIL sync"
9176++ else if mfAutorefresh st' then do
9177++ resetState st st' -- !> ("EN AUTOREFRESH" ++ show [ mfPagePath st,mfPath st,mfPagePath st'])
9178+ -- modify $ \st -> st{mfPagePath=mfPagePath st'} !> "REPEAT"
9179+- FlowM $ lift nextMessage
9182++ FlowM $ lift nextMessage
9185+ reqs <- FlowM $ lift installAllRequirements -- !> "REPEAT"
9187+- let header= mfHeader st'
9189+- cont <- case (needForm1 st') of
9191+- frm <- formPrefix st' forms False -- !> ("formPrefix="++ show(mfPagePath st'))
9192+- return . header $ reqs <> frm
9193+- _ -> return . header $ reqs <> forms
9195+- let HttpData ctype c s= toHttpData cont
9196+- liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s
9201++ let header= mfHeader st'
9203++ cont <- case (needForm st') of
9205++ frm <- formPrefix st' forms False -- !> ("formPrefix="++ show(mfPagePath st'))
9206++ return . header $ reqs <> frm
9207++ _ -> return . header $ reqs <> forms
9209++ let HttpData ctype c s= toHttpData cont
9210++ liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s
9213+ FlowM $ lift nextMessage -- !> "NEXTMESSAGE"
9216+- resetState st st'=
9217+- put st{mfCookies=[]
9218+- -- ,mfHttpHeaders=[]
9220+- ,mfToken= mfToken st'
9221+- ,mfPageFlow= mfPageFlow st'
9222+- ,mfAjax= mfAjax st'
9223+--- ,mfSeqCache= mfSeqCache st'
9224+- ,mfData= mfData st' }
9227+--- | A synonym of ask.
9229+--- Maybe more appropiate for pages with long interactions with the user
9230+--- while the result has little importance.
9232+- :: (FormInput view) =>
9233+- View view IO a -> FlowM view IO a
9236+-nextMessage :: MonadIO m => WState view m ()
9241+- t2= mfSessionTime st
9242+- msg <- liftIO ( receiveReqTimeout t1 t2 t)
9243+- let req= getParams msg
9244+- env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow)
9245+- npath= pwfPath msg
9247+- inPageFlow= mfPagePath st `isPrefixOf` npath
9249+- put st{ mfPath= npath
9252+- , mfPageFlow= inPageFlow
9259+- comparePaths _ n [] xs= n
9260+- comparePaths o n _ [] = o
9261+- comparePaths o n (v:path) (v': npath) | v== v' = comparePaths o (n+1)path npath
9264+- updateParams :: Bool -> Params -> Params -> Params
9265+- updateParams False _ req= req
9266+- updateParams True env req=
9267+- let params= takeWhile isparam env
9268+- fs= fst $ head req
9269+- parms= (case findIndex (\p -> fst p == fs) params of
9271+- Just i -> Data.List.take i params)
9274+--- !> "IN PAGE FLOW" !> ("parms=" ++ show parms )
9275+--- !> ("env=" ++ show env)
9276+--- !> ("req=" ++ show req)
9280+-isparam ('p': r:_,_)= isNumber r
9281+-isparam ('c': r:_,_)= isNumber r
9284+--- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a
9285+--- higuer level form of the latter
9287+- :: (Typeable view, FormInput view) =>
9288+- View view IO () -> Flow
9289+-wstateless w = runFlow . transientNav . ask $ w **> (stop `asTypeOf` w)
9296+--- | Wrap a widget with form element within a form-action element.
9297+--- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad, unless
9298+--- there are more than one form in the page.
9299+-wform :: (Monad m, FormInput view)
9300+- => View view m b -> View view m b
9301+-wform x = View $ do
9302+- FormElm form mr <- (runView $ x )
9304+- form1 <- formPrefix st form True
9305+- put st{needForm=HasForm}
9306+- return $ FormElm form1 mr
9311+-resetButton :: (FormInput view, Monad m) => String -> View view m ()
9314++ resetState st st'=
9315++ put st{mfCookies=[]
9316++ ,mfInstalledScripts= mfInstalledScripts st'
9318++ ,mfToken= mfToken st'
9319++ ,mfPageFlow= mfPageFlow st'
9320++ ,mfAjax= mfAjax st'
9321++ ,mfData= mfData st' }
9324++-- | A synonym of ask.
9326++-- Maybe more appropiate for pages with long interactions with the user
9327++-- while the result has little importance.
9329++ :: (FormInput view) =>
9330++ View view IO a -> FlowM view IO a
9333++nextMessage :: MonadIO m => WState view m ()
9338++ t2= mfSessionTime st
9339++ msg <- liftIO ( receiveReqTimeout t1 t2 t)
9340++ let req= getParams msg
9341++ env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow)
9342++ npath= pwfPath msg
9344++ inPageFlow= mfPagePath st `isPrefixOf` npath
9346++ put st{ mfPath= npath
9347++ , mfPageFlow= inPageFlow
9352++-- comparePaths _ n [] xs= n
9353++-- comparePaths o n _ [] = o
9354++-- comparePaths o n (v:path) (v': npath) | v== v' = comparePaths o (n+1)path npath
9357++ updateParams :: Bool -> Params -> Params -> Params
9358++ updateParams False _ req= req
9359++ updateParams True env req=
9360++ let params= takeWhile isparam req -- env
9361++ fs= fst $ head req
9362++ parms= (case findIndex (\p -> fst p == fs) params of
9364++ Just i -> Data.List.take i params)
9367++-- !> "IN PAGE FLOW" !> ("parms=" ++ show parms )
9368++-- !> ("env=" ++ show env)
9369++-- !> ("req=" ++ show req)
9373++isparam ('p': r:_,_)= isNumber r
9374++isparam ('c': r:_,_)= isNumber r
9377++-- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a
9378++-- higuer level form of the latter
9380++ :: (Typeable view, FormInput view) =>
9381++ View view IO () -> Flow
9382++wstateless w = runFlow . transientNav . ask $ w **> (stop `asTypeOf` w)
9389++-- | Wrap a widget with form element within a form-action element.
9390++-- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad, unless
9391++-- there are more than one form in the page.
9392++wform :: (Monad m, FormInput view)
9393++ => View view m b -> View view m b
9395++--wform x = View $ do
9396++-- FormElm form mr <- (runView $ x )
9398++-- form1 <- formPrefix st form True
9399++-- put st{needForm=HasForm}
9400++-- return $ FormElm form1 mr
9405++resetButton :: (FormInput view, Monad m) => String -> View view m ()
9406+ resetButton label= View $ return $ FormElm (finput "reset" "reset" label False Nothing)
9409+-submitButton :: (FormInput view, Monad m) => String -> View view m String
9410+-submitButton label= getParam Nothing "submit" $ Just label
9412+-newtype AjaxSessionId= AjaxSessionId String deriving Typeable
9414+--- | Install the server code and return the client code for an AJAX interaction.
9415+--- It is very lightweight, It does no t need jQuery.
9417+--- This example increases the value of a text box each time the box is clicked
9420+--- > let elemval= "document.getElementById('text1').value"
9421+--- > ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'"
9422+--- > b << text "click the box"
9423+--- > ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]
9424+-ajax :: (MonadIO m, FormInput v)
9425+- => (String -> View v m ByteString) -- ^ user defined procedure, executed in the server.Receives the value of the javascript expression and must return another javascript expression that will be executed in the web browser
9426+- -> View v m (String -> String) -- ^ returns a function that accept a javascript expression and return a javascript event handler expression that invokes the ajax server procedure
9428+- requires[JScript ajaxScript]
9431+- installServerControl id $ \x-> do
9432+- setSessionData $ AjaxSessionId id
9434+- liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r )
9437+-installServerControl :: (FormInput v,MonadIO m) => String -> (String -> View v m ()) -> View v m (String -> String)
9438+-installServerControl id f= do
9441+- let ajxl = fromMaybe M.empty $ mfAjax st
9442+- let ajxl'= M.insert id (unsafeCoerce f ) ajxl
9443+- put st{mfAjax=Just ajxl'}
9444+- return $ \param -> "doServer("++"'" ++ twfname t ++"','"++id++"',"++ param++")"
9446+--- | Send the javascript expression, generated by the procedure parameter as a ByteString, execute it in the browser and the result is returned back
9448+--- The @ajaxSend@ invocation must be inside a ajax procedure or else a /No ajax session set/ error will be produced
9450+- :: (Read a,Monoid v, MonadIO m) => View v m ByteString -> View v m a
9451+-ajaxSend cmd= View $ do
9452+- AjaxSessionId id <- getSessionData `onNothing` error "no AjaxSessionId set"
9455+- case (lookup "ajax" $ env, lookup "val" env) of
9456+- (Nothing,_) -> return $ FormElm mempty Nothing
9457+- (Just id, Just _) -> do
9458+- FormElm __ (Just str) <- runView cmd
9459+- liftIO $ sendFlush t $ HttpData [("Content-Type", "text/plain")][] $ str <> readEvalLoop t id "''"
9462+- case (lookup "ajax" $ env,lookup "val" env) of
9463+- (Nothing,_) -> return $ FormElm mempty Nothing
9464+- (Just id, Just v2) -> do
9465+- return $ FormElm mempty . Just $ read v2
9467+- readEvalLoop t id v = "doServer('"<> fromString (twfname t)<>"','"<> fromString id<>"',"<>v<>");" :: ByteString
9469+--- | Like @ajaxSend@ but the result is ignored
9471+- :: (MonadIO m, Monoid v) => View v m ByteString -> View v m ()
9472+-ajaxSend_ = ajaxSend
9475+- :: (Monad m, FormInput view) => view -> View view m a -> View view m a
9478+- ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)]
9483++submitButton :: (FormInput view, Monad m) => String -> View view m String
9484++submitButton label= getParam Nothing "submit" $ Just label
9486++newtype AjaxSessionId= AjaxSessionId String deriving Typeable
9488++-- | Install the server code and return the client code for an AJAX interaction.
9489++-- It is very lightweight, It does no t need jQuery.
9491++-- This example increases the value of a text box each time the box is clicked
9494++-- > let elemval= "document.getElementById('text1').value"
9495++-- > ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'"
9496++-- > b << text "click the box"
9497++-- > ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]
9498++ajax :: (MonadIO m, FormInput v)
9499++ => (String -> View v m ByteString) -- ^ user defined procedure, executed in the server.Receives the value of the javascript expression and must return another javascript expression that will be executed in the web browser
9500++ -> View v m (String -> String) -- ^ returns a function that accept a javascript expression and return a javascript event handler expression that invokes the ajax server procedure
9502++ requires[JScript ajaxScript]
9505++ installServerControl id $ \x-> do
9506++ setSessionData $ AjaxSessionId id
9508++ liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r )
9511++installServerControl :: (FormInput v,MonadIO m) => String -> (String -> View v m ()) -> View v m (String -> String)
9512++installServerControl id f= do
9515++ let ajxl = fromMaybe M.empty $ mfAjax st
9516++ let ajxl'= M.insert id (unsafeCoerce f ) ajxl
9517++ put st{mfAjax=Just ajxl'}
9518++ return $ \param -> "doServer("++"'" ++ twfname t ++"','"++id++"',"++ param++")"
9520++-- | Send the javascript expression, generated by the procedure parameter as a ByteString, execute it in the browser and the result is returned back
9522++-- The @ajaxSend@ invocation must be inside a ajax procedure or else a /No ajax session set/ error will be produced
9524++ :: (Read a,Monoid v, MonadIO m) => View v m ByteString -> View v m a
9525++ajaxSend cmd= View $ do
9526++ AjaxSessionId id <- getSessionData `onNothing` error "no AjaxSessionId set"
9529++ case (lookup "ajax" $ env, lookup "val" env) of
9530++ (Nothing,_) -> return $ FormElm mempty Nothing
9531++ (Just id, Just _) -> do
9532++ FormElm __ (Just str) <- runView cmd
9533++ liftIO $ sendFlush t $ HttpData [("Content-Type", "text/plain")][] $ str <> readEvalLoop t id "''"
9536++ case (lookup "ajax" $ env,lookup "val" env) of
9537++ (Nothing,_) -> return $ FormElm mempty Nothing
9538++ (Just id, Just v2) -> do
9539++ return $ FormElm mempty . Just $ read v2
9541++ readEvalLoop t id v = "doServer('"<> fromString (twfname t)<>"','"<> fromString id<>"',"<>v<>");" :: ByteString
9543++-- | Like @ajaxSend@ but the result is ignored
9545++ :: (MonadIO m, Monoid v) => View v m ByteString -> View v m ()
9546++ajaxSend_ = ajaxSend
9549++ :: (Monad m, FormInput view) => view -> View view m a -> View view m a
9552++ ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)]
9555+ -- | Creates a link to a the next step within the flow.
9556+ -- A link can be composed with other widget elements.
9557+ -- It can not be broken by its own definition.
9558+--- It points to the page that created it.
9559+-wlink :: (Typeable a, Show a, MonadIO m, FormInput view)
9560+- => a -> view -> View view m a
9561+-wlink x v= View $ do
9563++-- It points to the page that created it.
9564++wlink :: (Typeable a, Show a, MonadIO m, FormInput view)
9565++ => a -> view -> View view m a
9566++wlink x v= View $ do
9570+- let name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String)
9571+- then unsafeCoerce x
9574++ let name = --mfPrefix st ++
9575++ (map toLower $ if typeOf x== typeOf(undefined :: String)
9576++ then unsafeCoerce x
9579+- newPath= mfPagePath st ++ [name]
9581+- r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
9583+- case newPath `isPrefixOf` lpath of
9585+- modify $ \s -> s{inSync= True
9586++ newPath= mfPagePath st ++ [name]
9588++ r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
9590++ case newPath `isPrefixOf` lpath of
9592++ modify $ \s -> s{inSync= True
9594+- ,mfPagePath= newPath }
9596++ ,mfPagePath= newPath }
9599+--- !> (name ++ "<-" ++ "link path=" ++show newPath)
9600++-- !> (name ++ "<-" ++ "link path=" ++show newPath)
9601+ False -> return Nothing
9602+ -- !> ( "NOT MATCHED "++name++" link path= "++show newPath
9603+--- ++ "path="++ show lpath)
9604++-- ++ "path="++ show lpath)
9606+- let path= concat ['/':v| v <- newPath ]
9607+- return $ FormElm (flink path v) r
9608++ let path= concat ['/':v| v <- newPath ]
9609++ return $ FormElm (flink path v) r
9611+ -- Creates an absolute link. While a `wlink` path depend on the page where it is located and
9612+ -- ever points to the code of the page that had it inserted, an absLink point to the first page
9613+@@ -1313,299 +1319,300 @@
9614+ -- > p << "third statement" ++> (absLink "here" << p << "will present the first statement alone")
9615+ -- > p << "fourth statement" ++> wlink () << p << "will not reach here"
9616+ --absLink x = wcached (show x) 0 . wlink x
9617+-absLink x v= View $ do
9619++absLink x v= View $ do
9623+- let name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String)
9624+- then unsafeCoerce x
9627++ let name = -- mfPrefix st
9628++ (map toLower $ if typeOf x== typeOf(undefined :: String)
9629++ then unsafeCoerce x
9633+- newPath= mfPagePath st ++ [name]
9634+- r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
9636+- case newPath `isPrefixOf` lpath of
9638+- modify $ \s -> s{inSync= True
9639++ newPath= mfPagePath st ++ [name]
9640++ r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
9642++ case newPath `isPrefixOf` lpath of
9644++ modify $ \s -> s{inSync= True
9646+- ,mfPagePath= newPath }
9648+- return $ Just x -- !> (name ++ "<- abs" ++ "lpath=" ++show lpath)
9649+- False -> return Nothing -- !> ( "NOT MATCHED "++name++" LP= "++show lpath)
9651+- path <- liftIO $ cachedByKey (show x) 0 . return $ currentPath st ++ ('/':name)
9653+- return $ FormElm (flink path v) r -- !> name
9657+--- | When some user interface return some response to the server, but it is not produced by
9658+--- a form or a link, but for example by an script, @returning@ convert this code into a
9661+--- At runtime the parameter is read from the environment and validated.
9663+--- . The parameter is the visualization code, that accept a serialization function that generate
9664+--- the server invocation string, used by the visualization to return the value by means
9665+--- of an script, usually.
9666+-returning :: (Typeable a, Read a, Show a,Monad m, FormInput view)
9667+- => ((a->String) ->view) -> View view m a
9668+-returning expr=View $ do
9673+- let showx= case cast x of
9676+- in (verb ++ "?" ++ name ++ "=" ++ showx)
9677+- toSend= expr string
9678+- r <- getParam1 name env
9679+- return $ FormElm toSend $ valToMaybe r
9685+---instance (Widget a b m view, Monoid view) => Widget [a] b m view where
9686+--- widget xs = View $ do
9687+--- forms <- mapM(\x -> (runView $ widget x )) xs
9688+--- let vs = concatMap (\(FormElm v _) -> v) forms
9689+--- res = filter isJust $ map (\(FormElm _ r) -> r) forms
9690+--- res1= if null res then Nothing else head res
9691+--- return $ FormElm [mconcat vs] res1
9693+--- | Concat a list of widgets of the same type, return a the first validated result
9694+-firstOf :: (FormInput view, Monad m, Functor m)=> [View view m a] -> View view m a
9695++ ,mfPagePath= newPath }
9697++ return $ Just x -- !> (name ++ "<- abs" ++ "lpath=" ++show lpath)
9698++ False -> return Nothing -- !> ( "NOT MATCHED "++name++" LP= "++show lpath)
9700++ path <- liftIO $ cachedByKey (show x) 0 . return $ currentPath st ++ ('/':name)
9702++ return $ FormElm (flink path v) r -- !> name
9706++-- | When some user interface return some response to the server, but it is not produced by
9707++-- a form or a link, but for example by an script, @returning@ convert this code into a
9710++-- At runtime the parameter is read from the environment and validated.
9712++-- . The parameter is the visualization code, that accept a serialization function that generate
9713++-- the server invocation string, used by the visualization to return the value by means
9714++-- of an script, usually.
9715++returning :: (Typeable a, Read a, Show a,Monad m, FormInput view)
9716++ => ((a->String) ->view) -> View view m a
9717++returning expr=View $ do
9722++ let showx= case cast x of
9725++ in (verb ++ "?" ++ name ++ "=" ++ showx)
9726++ toSend= expr string
9727++ r <- getParam1 name env
9728++ return $ FormElm toSend $ valToMaybe r
9734++--instance (Widget a b m view, Monoid view) => Widget [a] b m view where
9735++-- widget xs = View $ do
9736++-- forms <- mapM(\x -> (runView $ widget x )) xs
9737++-- let vs = concatMap (\(FormElm v _) -> v) forms
9738++-- res = filter isJust $ map (\(FormElm _ r) -> r) forms
9739++-- res1= if null res then Nothing else head res
9740++-- return $ FormElm [mconcat vs] res1
9742++-- | Concat a list of widgets of the same type, return a the first validated result
9743++firstOf :: (FormInput view, Monad m, Functor m)=> [View view m a] -> View view m a
9744+ firstOf xs= foldl' (<|>) noWidget xs
9746+--- forms <- mapM runView xs
9747+--- let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms
9748+--- res = filter isJust $ map (\(FormElm _ r) -> r) forms
9749+--- res1= if null res then Nothing else head res
9750+--- return $ FormElm vs res1
9752+--- | from a list of widgets, it return the validated ones.
9753+-manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a] -> View view m [a]
9754+-manyOf xs= whidden () *> (View $ do
9755+- forms <- mapM runView xs
9756+- let vs = mconcat $ map (\(FormElm v _) -> v) forms
9757+- res1= catMaybes $ map (\(FormElm _ r) -> r) forms
9758+- return . FormElm vs $ Just res1)
9760++-- forms <- mapM runView xs
9761++-- let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms
9762++-- res = filter isJust $ map (\(FormElm _ r) -> r) forms
9763++-- res1= if null res then Nothing else head res
9764++-- return $ FormElm vs res1
9766++-- | from a list of widgets, it return the validated ones.
9767++manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a] -> View view m [a]
9768++manyOf xs= whidden () *> (View $ do
9769++ forms <- mapM runView xs
9770++ let vs = mconcat $ map (\(FormElm v _) -> v) forms
9771++ res1= catMaybes $ map (\(FormElm _ r) -> r) forms
9772++ return . FormElm vs $ Just res1)
9774+ -- | like manyOf, but does not validate if one or more of the widgets does not validate
9775+ allOf xs= manyOf xs `validate` \rs ->
9776+ if length rs== length xs
9777+ then return Nothing
9778+ else return $ Just mempty
9780+-(>:>) :: (Monad m, Monoid v) => View v m a -> View v m [a] -> View v m [a]
9781+-(>:>) w ws = View $ do
9782+- FormElm fs mxs <- runView $ ws
9783+- FormElm f1 mx <- runView w
9784+- return $ FormElm (f1 <> fs)
9785+- $ case( mx,mxs) of
9786+- (Just x, Just xs) -> Just $ x:xs
9787+- (Nothing, mxs) -> mxs
9788+- (Just x, _) -> Just [x]
9790+--- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types.
9792+--- it has a infix priority @infixr 5@
9793+-(|*>) :: (MonadIO m, Functor m, FormInput view)
9795+- -> [View view m r']
9796+- -> View view m (Maybe r,Maybe r')
9797+-(|*>) x xs= View $ do
9798+- fs <- mapM runView xs
9799+- FormElm fx rx <- runView x
9801++(>:>) :: (Monad m, Monoid v) => View v m a -> View v m [a] -> View v m [a]
9802++(>:>) w ws = View $ do
9803++ FormElm fs mxs <- runView $ ws
9804++ FormElm f1 mx <- runView w
9805++ return $ FormElm (f1 <> fs)
9806++ $ case( mx,mxs) of
9807++ (Just x, Just xs) -> Just $ x:xs
9808++ (Nothing, mxs) -> mxs
9809++ (Just x, _) -> Just [x]
9811++-- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types.
9813++-- it has a infix priority @infixr 5@
9814++(|*>) :: (MonadIO m, Functor m, FormInput view)
9816++ -> [View view m r']
9817++ -> View view m (Maybe r,Maybe r')
9818++(|*>) x xs= View $ do
9819++ fs <- mapM runView xs
9820++ FormElm fx rx <- runView x
9821+ let (fxs, rxss) = unzip $ map (\(FormElm v r) -> (v,r)) fs
9822+ rs= filter isJust rxss
9823+- rxs= if null rs then Nothing else head rs
9824+- return $ FormElm (fx <> mconcat (intersperse fx fxs) <> fx)
9825+- $ case (rx,rxs) of
9826+- (Nothing, Nothing) -> Nothing
9827+- other -> Just other
9833+--- | Put a widget before and after other. Useful for navigation links in a page that appears at toAdd
9834+--- and at the bottom of a page.
9836+--- It has a low infix priority: @infixr 1@
9837+-(|+|) :: (Functor m, FormInput view, MonadIO m)
9840+- -> View view m (Maybe r, Maybe r')
9841+-(|+|) w w'= w |*> [w']
9846+--- | Flatten a binary tree of tuples of Maybe results produced by the \<+> operator
9847+--- into a single tuple with the same elements in the same order.
9848+--- This is useful for easing matching. For example:
9850+--- @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@
9854+--- @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@
9856+--- but @flatten res@ has type:
9858+--- @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@
9860+-flatten :: Flatten (Maybe tree) list => tree -> list
9861+-flatten res= doflat $ Just res
9863+-class Flatten tree list where
9864+- doflat :: tree -> list
9867+-type Tuple2 a b= Maybe (Maybe a, Maybe b)
9868+-type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c)
9869+-type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d)
9870+-type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e)
9871+-type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f)
9873+-instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where
9874+- doflat (Just(ma,mb))= (ma,mb)
9875+- doflat Nothing= (Nothing,Nothing)
9877+-instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where
9878+- doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc)
9879+- doflat Nothing= (Nothing,Nothing,Nothing)
9881+-instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where
9882+- doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc)
9883+- doflat Nothing= (Nothing,Nothing,Nothing,Nothing)
9885+-instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where
9886+- doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc)
9887+- doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing)
9889+-instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where
9890+- doflat (Just(mx,mc))= let(ma,mb,md,me,mf)= doflat mx in (ma,mb,md,me,mf,mc)
9891+- doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)
9894+----- | > (.<<.) w x = w $ toByteString x
9895+---(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString
9896+---(.<<.) w x = w ( toByteString x)
9898+----- | > (.<+>.) x y = normalize x <+> normalize y
9900+--- :: (Monad m, FormInput v, FormInput v1) =>
9901+--- View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b)
9902+---(.<+>.) x y = normalize x <+> normalize y
9904+----- | > (.|*>.) x y = normalize x |*> map normalize y
9906+--- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
9908+--- -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')
9909+---(.|*>.) x y = normalize x |*> map normalize y
9911+----- | > (.|+|.) x y = normalize x |+| normalize y
9913+--- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
9914+--- View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r')
9915+---(.|+|.) x y = normalize x |+| normalize y
9917+----- | > (.**>.) x y = normalize x **> normalize y
9919+--- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
9920+--- View v m a -> View v1 m b -> View ByteString m b
9921+---(.**>.) x y = normalize x **> normalize y
9923+----- | > (.<**.) x y = normalize x <** normalize y
9925+--- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
9926+--- View v m a -> View v1 m b -> View ByteString m a
9927+---(.<**.) x y = normalize x <** normalize y
9929+----- | > (.<|>.) x y= normalize x <|> normalize y
9931+--- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
9932+--- View v m a -> View v1 m a -> View ByteString m a
9933+---(.<|>.) x y= normalize x <|> normalize y
9935+----- | > (.<++.) x v= normalize x <++ toByteString v
9936+---(.<++.) :: (Monad m, FormInput v, FormInput v') => View v m a -> v' -> View ByteString m a
9937+---(.<++.) x v= normalize x <++ toByteString v
9939+----- | > (.++>.) v x= toByteString v ++> normalize x
9940+---(.++>.) :: (Monad m, FormInput v, FormInput v') => v -> View v' m a -> View ByteString m a
9941+---(.++>.) v x= toByteString v ++> normalize x
9944+-instance FormInput ByteString where
9946+- toHttpData = HttpData [contentHtml ] []
9948+- inred = btag "b" [("style", "color:red")]
9949+- finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else []
9950+- ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) ""
9951+- ftextarea name text= btag "textarea" [("name", name)] $ fromChunks [encodeUtf8 text]
9953+- fselect name options= btag "select" [("name", name)] options
9955+- foption value content msel= btag "option" ([("value", value)] ++ selected msel) content
9957+- selected msel = if msel then [("selected","true")] else []
9962+- formAction action form = btag "form" [("action", action),("method", "post")] form
9963+- fromStr = fromString
9964+- fromStrNoEncode= fromString
9966+- flink v str = btag "a" [("href", v)] str
9968+------- page Flows ----
9970+--- | Prepares the state for a page flow. It add a prefix to every form element or link identifier for the formlets and also
9971+--- keep the state of the links clicked and form imput entered within the widget.
9972+--- If the computation within the widget has branches @if@ @case@ etc, each branch must have its pageFlow with a distinct identifier.
9973+--- See <http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html>
9975+- :: (Monad m, Functor m, FormInput view) =>
9976+- String -> View view m a -> View view m a
9977+-pageFlow str widget=do
9980+- if mfPageFlow s == False
9982+- put s{mfPrefix= str ++ mfPrefix s
9984++ rxs= if null rs then Nothing else head rs
9985++ return $ FormElm (fx <> mconcat (intersperse fx fxs) <> fx)
9986++ $ case (rx,rxs) of
9987++ (Nothing, Nothing) -> Nothing
9988++ other -> Just other
9994++-- | Put a widget before and after other. Useful for navigation links in a page that appears at toAdd
9995++-- and at the bottom of a page.
9997++-- It has a low infix priority: @infixr 1@
9998++(|+|) :: (Functor m, FormInput view, MonadIO m)
10000++ -> View view m r'
10001++ -> View view m (Maybe r, Maybe r')
10002++(|+|) w w'= w |*> [w']
10007++-- | Flatten a binary tree of tuples of Maybe results produced by the \<+> operator
10008++-- into a single tuple with the same elements in the same order.
10009++-- This is useful for easing matching. For example:
10011++-- @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@
10013++-- @res@ has type:
10015++-- @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@
10017++-- but @flatten res@ has type:
10019++-- @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@
10021++flatten :: Flatten (Maybe tree) list => tree -> list
10022++flatten res= doflat $ Just res
10024++class Flatten tree list where
10025++ doflat :: tree -> list
10028++type Tuple2 a b= Maybe (Maybe a, Maybe b)
10029++type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c)
10030++type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d)
10031++type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e)
10032++type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f)
10034++instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where
10035++ doflat (Just(ma,mb))= (ma,mb)
10036++ doflat Nothing= (Nothing,Nothing)
10038++instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where
10039++ doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc)
10040++ doflat Nothing= (Nothing,Nothing,Nothing)
10042++instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where
10043++ doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc)
10044++ doflat Nothing= (Nothing,Nothing,Nothing,Nothing)
10046++instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where
10047++ doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc)
10048++ doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing)
10050++instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where
10051++ doflat (Just(mx,mc))= let(ma,mb,md,me,mf)= doflat mx in (ma,mb,md,me,mf,mc)
10052++ doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)
10055++---- | > (.<<.) w x = w $ toByteString x
10056++--(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString
10057++--(.<<.) w x = w ( toByteString x)
10059++---- | > (.<+>.) x y = normalize x <+> normalize y
10061++-- :: (Monad m, FormInput v, FormInput v1) =>
10062++-- View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b)
10063++--(.<+>.) x y = normalize x <+> normalize y
10065++---- | > (.|*>.) x y = normalize x |*> map normalize y
10067++-- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
10069++-- -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')
10070++--(.|*>.) x y = normalize x |*> map normalize y
10072++---- | > (.|+|.) x y = normalize x |+| normalize y
10074++-- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
10075++-- View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r')
10076++--(.|+|.) x y = normalize x |+| normalize y
10078++---- | > (.**>.) x y = normalize x **> normalize y
10080++-- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
10081++-- View v m a -> View v1 m b -> View ByteString m b
10082++--(.**>.) x y = normalize x **> normalize y
10084++---- | > (.<**.) x y = normalize x <** normalize y
10086++-- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
10087++-- View v m a -> View v1 m b -> View ByteString m a
10088++--(.<**.) x y = normalize x <** normalize y
10090++---- | > (.<|>.) x y= normalize x <|> normalize y
10092++-- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
10093++-- View v m a -> View v1 m a -> View ByteString m a
10094++--(.<|>.) x y= normalize x <|> normalize y
10096++---- | > (.<++.) x v= normalize x <++ toByteString v
10097++--(.<++.) :: (Monad m, FormInput v, FormInput v') => View v m a -> v' -> View ByteString m a
10098++--(.<++.) x v= normalize x <++ toByteString v
10100++---- | > (.++>.) v x= toByteString v ++> normalize x
10101++--(.++>.) :: (Monad m, FormInput v, FormInput v') => v -> View v' m a -> View ByteString m a
10102++--(.++>.) v x= toByteString v ++> normalize x
10105++instance FormInput ByteString where
10107++ toHttpData = HttpData [contentHtml ] []
10108++ ftag x= btag x []
10109++ inred = btag "b" [("style", "color:red")]
10110++ finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else []
10111++ ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) ""
10112++ ftextarea name text= btag "textarea" [("name", name)] $ fromChunks [encodeUtf8 text]
10114++ fselect name options= btag "select" [("name", name)] options
10116++ foption value content msel= btag "option" ([("value", value)] ++ selected msel) content
10118++ selected msel = if msel then [("selected","true")] else []
10123++ formAction action method form = btag "form" [("action", action),("method", method)] form
10124++ fromStr = fromString
10125++ fromStrNoEncode= fromString
10127++ flink v str = btag "a" [("href", v)] str
10129++------ page Flows ----
10131++-- | Prepares the state for a page flow. It add a prefix to every form element or link identifier for the formlets and also
10132++-- keep the state of the links clicked and form imput entered within the widget.
10133++-- If the computation within the widget has branches @if@ @case@ etc, each branch must have its pageFlow with a distinct identifier.
10134++-- See <http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html>
10136++ :: (Monad m, Functor m, FormInput view) =>
10137++ String -> View view m a -> View view m a
10138++pageFlow str widget=do
10141++ if mfPageFlow s == False
10143++ put s{mfPrefix= str ++ mfPrefix s
10146+- } -- !> ("PARENT pageflow. prefix="++ str)
10148+- r<- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
10149++ } -- !> ("PARENT pageflow. prefix="++ str)
10151++ r<- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
10152+ ,mfPrefix= mfPrefix s
10155+ modify (\s -> s{mfPageFlow=False} )
10156+- return r -- !> ("END PARENT pageflow. prefix="++ str))
10160+- put s{mfPrefix= str++ mfPrefix s,mfSequence=0} -- !> ("PARENT pageflow. prefix="++ str) -- !> ("CHILD pageflow. prefix="++ str)
10162+- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
10163+- ,mfPrefix= mfPrefix s}))
10164+- -- !> ("END CHILD pageflow. prefix="++ str))
10168+---acum map []= map
10169+---acum map (x:xs) =
10170+--- let map' = case M.lookup x map of
10171+--- Nothing -> M.insert x 1 map
10172+--- Just n -> M.insert x (n+1) map
10173+--- in acum map' xs
10175++ return r -- !> ("END PARENT pageflow. prefix="++ str))
10179++ put s{mfPrefix= str++ mfPrefix s,mfSequence=0} -- !> ("PARENT pageflow. prefix="++ str) -- !> ("CHILD pageflow. prefix="++ str)
10181++ widget <** (modify (\s' -> s'{mfSequence= mfSequence s
10182++ ,mfPrefix= mfPrefix s}))
10183++ -- !> ("END CHILD pageflow. prefix="++ str))
10187++--acum map []= map
10188++--acum map (x:xs) =
10189++-- let map' = case M.lookup x map of
10190++-- Nothing -> M.insert x 1 map
10191++-- Just n -> M.insert x (n+1) map
10192++-- in acum map' xs
10194+diff -ru orig/src/MFlow/Hack/Response.hs new/src/MFlow/Hack/Response.hs
10195+--- orig/src/MFlow/Hack/Response.hs 2014-06-10 05:51:26.969015857 +0300
10196++++ new/src/MFlow/Hack/Response.hs 2014-06-10 05:51:25.000000000 +0300
10198+ {-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances
10199+- -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
10200+-module MFlow.Hack.Response where
10202++ -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
10203++module MFlow.Hack.Response where
10206+-import MFlow.Cookies
10207++import MFlow.Cookies
10208+ import Data.ByteString.Lazy.Char8 as B
10211+-import Data.Typeable
10213++import Data.Typeable
10214+ import Data.Monoid
10215+ import System.IO.Unsafe
10216+ import Data.Map as M
10218+ --(!>)= flip trace
10222+-class ToResponse a where
10223+- toResponse :: a -> Response
10225++class ToResponse a where
10226++ toResponse :: a -> Response
10230+@@ -31,28 +31,28 @@
10231+ mappend (TResp x) (TResp y)=
10233+ Just y' -> TResp $ mappend x y'
10234+- Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
10236++ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
10239+ instance ToResponse TResp where
10240+- toResponse (TResp x)= toResponse x
10241++ toResponse (TResp x)= toResponse x
10242+ toResponse (TRespR r)= toResponse r
10244+-instance ToResponse Response where
10247+-instance ToResponse ByteString where
10248+- toResponse x= Response{status=200, headers=[contentHtml {-,("Content-Length",show $ B.length x) -}], body= x}
10250+-instance ToResponse String where
10252++instance ToResponse Response where
10255++instance ToResponse ByteString where
10256++ toResponse x= Response{status=200, headers=[contentHtml {-,("Content-Length",show $ B.length x) -}], body= x}
10258++instance ToResponse String where
10259+ toResponse x= Response{status=200, headers=[contentHtml{-,("Content-Length",show $ B.length x) -}], body= B.pack x}
10261+ instance ToResponse HttpData where
10262+ toResponse (HttpData hs cookies x)= (toResponse x) {headers= hs++ cookieHeaders cookies}
10263+- toResponse (Error NotFound str)= Response{status=404, headers=[], body= getNotFoundResponse str}
10265+-instance Typeable Env where
10266+- typeOf = \_-> mkTyConApp (mkTyCon3 "hack-handler-simpleserver" "Hack" "Env") []
10268+---instance Typeable Response where
10269+--- typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[]
10270++ toResponse (Error NotFound str)= Response{status=404, headers=[], body= getNotFoundResponse str}
10272++instance Typeable Env where
10273++ typeOf = \_-> mkTyConApp (mkTyCon3 "hack-handler-simpleserver" "Hack" "Env") []
10275++--instance Typeable Response where
10276++-- typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[]
10277+diff -ru orig/src/MFlow/Hack/XHtml.hs new/src/MFlow/Hack/XHtml.hs
10278+--- orig/src/MFlow/Hack/XHtml.hs 2014-06-10 05:51:26.969015857 +0300
10279++++ new/src/MFlow/Hack/XHtml.hs 2014-06-10 05:51:25.000000000 +0300
10280+@@ -27,14 +27,14 @@
10282+ import Data.Typeable
10283+ import Data.ByteString.Lazy.Char8 as B(pack,unpack, length, ByteString)
10285+-instance ToResponse Html where
10287++instance ToResponse Html where
10288+ toResponse x= Response{ status=200, headers=[]
10289+- , Hack.body= pack $ showHtml x}
10290++ , Hack.body= pack $ showHtml x}
10292+---instance Typeable Html where
10293+--- typeOf = \_ -> mkTyConApp (mkTyCon "Text.XHtml.Strict.Html") []
10294++--instance Typeable Html where
10295++-- typeOf = \_ -> mkTyConApp (mkTyCon "Text.XHtml.Strict.Html") []
10297+---instance ConvertTo Html TResp where
10298++--instance ConvertTo Html TResp where
10299+ -- convert = TResp
10301+diff -ru orig/src/MFlow/Hack.hs new/src/MFlow/Hack.hs
10302+--- orig/src/MFlow/Hack.hs 2014-06-10 05:51:26.957015857 +0300
10303++++ new/src/MFlow/Hack.hs 2014-06-10 05:51:25.000000000 +0300
10306+ see <http://hackage.haskell.org/package/hack>
10310+ module MFlow.Hack(
10311+ module MFlow.Cookies
10316+-import Data.Typeable
10319+-import Control.Concurrent.MVar(modifyMVar_, readMVar)
10320+-import Control.Monad(when)
10323+-import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString)
10324+-import Control.Concurrent(ThreadId(..))
10325+-import System.IO.Unsafe
10327++import Data.Typeable
10330++import Control.Concurrent.MVar(modifyMVar_, readMVar)
10331++import Control.Monad(when)
10334++import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString)
10335++import Control.Concurrent(ThreadId(..))
10336++import System.IO.Unsafe
10337+ import Control.Concurrent.MVar
10338+-import Control.Concurrent
10339+-import Control.Exception
10340++import Control.Concurrent
10341++import Control.Exception
10342+ import qualified Data.Map as M
10345+ import Data.TCache
10346+-import Data.TCache.DefaultPersistence
10347+-import Control.Workflow hiding (Indexable(..))
10350++import Data.TCache.DefaultPersistence
10351++import Control.Workflow hiding (Indexable(..))
10354+ import MFlow.Cookies
10356+ import MFlow.Hack.Response
10357+@@ -46,13 +46,13 @@
10362+-instance Processable Env where
10363+- pwfname env= if null sc then noScript else sc
10366++instance Processable Env where
10367++ pwfname env= if null sc then noScript else sc
10369+ sc= tail $ pathInfo env
10370+- puser env = fromMaybe anonymous $ lookup cookieuser $ http env
10372++ puser env = fromMaybe anonymous $ lookup cookieuser $ http env
10374+ pind env= fromMaybe (error ": No FlowID") $ lookup flow $ http env
10376+ -- getServer env= serverName env
10377+@@ -60,38 +60,38 @@
10378+ -- getPort env= serverPort env
10382+----------------------------------------------
10387+---instance ConvertTo String TResp where
10388+--- convert = TResp . pack
10390++---------------------------------------------
10395+---instance ConvertTo ByteString TResp where
10396++--instance ConvertTo String TResp where
10397++-- convert = TResp . pack
10399++--instance ConvertTo ByteString TResp where
10400+ -- convert = TResp
10403+---instance ConvertTo Error TResp where
10405++--instance ConvertTo Error TResp where
10406+ -- convert (Error e)= TResp . pack $ errorResponse e
10408+ --instance ToResponse v =>ConvertTo (HttpData v) TResp where
10409+--- convert= TRespR
10410++-- convert= TRespR
10413++--webScheduler :: Env
10415++-- -> IO (TResp, ThreadId)
10416++--webScheduler = msgScheduler
10418++--theDir= unsafePerformIO getCurrentDirectory
10420++wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response)
10421++wFMiddleware filter f = \ env -> if filter env then hackMessageFlow env else f env -- !> "new message"
10424+---webScheduler :: Env
10426+--- -> IO (TResp, ThreadId)
10427+---webScheduler = msgScheduler
10429+---theDir= unsafePerformIO getCurrentDirectory
10431+-wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response)
10432+-wFMiddleware filter f = \ env -> if filter env then hackMessageFlow env else f env -- !> "new message"
10434+ -- | An instance of the abstract "MFlow" scheduler to the Hack interface
10435+--- it accept the list of processes being scheduled and return a hack handler
10436++-- it accept the list of processes being scheduled and return a hack handler
10440+@@ -107,112 +107,112 @@
10441+ -- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs]
10443+ --hackMessageFlow :: [(String, (Token -> Workflow IO ()))]
10444+--- -> (Env -> IO Response)
10445+---hackMessageFlow messageFlows =
10446+--- unsafePerformIO (addMessageFlows messageFlows) `seq`
10447+--- hackWorkflow -- wFMiddleware f other
10448++-- -> (Env -> IO Response)
10449++--hackMessageFlow messageFlows =
10450++-- unsafePerformIO (addMessageFlows messageFlows) `seq`
10451++-- hackWorkflow -- wFMiddleware f other
10453+ -- f env = unsafePerformIO $ do
10454+ -- paths <- getMessageFlows >>=
10455+ -- return (pwfname env `elem` paths)
10457+--- other= (\env -> defaultResponse $ "options: " ++ opts)
10458++-- other= (\env -> defaultResponse $ "options: " ++ opts)
10459+ -- (paths,_)= unzip messageFlows
10460+ -- opts= concatMap (\s -> "<a href=\""++ s ++"\">"++s ++"</a>, ") paths
10463+-splitPath ""= ("","","")
10466+- strr= reverse str
10467+- (ext, rest)= span (/= '.') strr
10468+- (mod, path)= span(/='/') $ tail rest
10469+- in (tail $ reverse path, reverse mod, reverse ext)
10473+-hackMessageFlow :: Env -> IO Response
10474+-hackMessageFlow req1= do
10475+- let httpreq1= http req1
10476+- let cookies= {-# SCC "getCookies" #-} getCookies httpreq1
10478+- (flowval , retcookies) <- case lookup ( flow) cookies of
10479+- Just fl -> return (fl, [])
10484++splitPath ""= ("","","")
10487++ strr= reverse str
10488++ (ext, rest)= span (/= '.') strr
10489++ (mod, path)= span(/='/') $ tail rest
10490++ in (tail $ reverse path, reverse mod, reverse ext)
10494++hackMessageFlow :: Env -> IO Response
10495++hackMessageFlow req1= do
10496++ let httpreq1= http req1
10497++ let cookies= {-# SCC "getCookies" #-} getCookies httpreq1
10499++ (flowval , retcookies) <- case lookup ( flow) cookies of
10500++ Just fl -> return (fl, [])
10503+ return ( fl, [( flow, fl, "/",(Just $ show $ 365*24*60*60))])
10505+-{- for state persistence in cookies
10506+- putStateCookie req1 cookies
10507+- let retcookies= case getStateCookie req1 of
10508+- Nothing -> retcookies1
10509+- Just ck -> ck:retcookies1
10513+- case ( requestMethod req1, lookup "Content-Type" httpreq1 ) of
10514+- (POST,Just "application/x-www-form-urlencoded") -> urlDecode . unpack $ hackInput req1
10515+- (GET, _) -> urlDecode . queryString $ req1
10518+- let req = case retcookies of
10519+- [] -> req1{http= (input ++ cookies) ++ http req1} -- !> "REQ"
10520+- _ -> req1{http=(flow, flowval): ( input ++ cookies ) ++ http req1} -- !> "REQ"
10524++{- for state persistence in cookies
10525++ putStateCookie req1 cookies
10526++ let retcookies= case getStateCookie req1 of
10527++ Nothing -> retcookies1
10528++ Just ck -> ck:retcookies1
10532++ case ( requestMethod req1, lookup "Content-Type" httpreq1 ) of
10533++ (POST,Just "application/x-www-form-urlencoded") -> urlDecode . unpack $ hackInput req1
10534++ (GET, _) -> urlDecode . queryString $ req1
10537++ let req = case retcookies of
10538++ [] -> req1{http= (input ++ cookies) ++ http req1} -- !> "REQ"
10539++ _ -> req1{http=(flow, flowval): ( input ++ cookies ) ++ http req1} -- !> "REQ"
10542+ (resp',th) <- msgScheduler req
10545+- let resp''= toResponse resp'
10547++ let resp''= toResponse resp'
10548+ let headers1= case retcookies of [] -> headers resp''; _ -> (cookieHeaders retcookies)
10549+- let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}}
10551++ let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}}
10556+-------persistent state in cookies (not tested)
10558+-tvresources :: MVar (Maybe ( M.Map string string))
10559+-tvresources= unsafePerformIO $ newMVar Nothing
10560+-statCookieName= "stat"
10562+-putStateCookie req cookies=
10563+- case lookup statCookieName cookies of
10564+- Nothing -> return ()
10565+- Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $
10566+- \mmap -> case mmap of
10567+- Just map -> return $ Just $ M.insert (keyResource req) str map
10568+- Nothing -> return $ Just $ M.fromList [((keyResource req), str) ]
10570+-getStateCookie req= do
10571+- mr<- readMVar tvresources
10573+- Nothing -> return Nothing
10574+- Just map -> case M.lookup (keyResource req) map of
10575+- Nothing -> return Nothing
10577+- swapMVar tvresources Nothing
10578+- return $ Just (statCookieName, str , "/")
10581+-persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
10583+- writeResource stat= modifyMVar_ tvresources $ \mmap ->
10585+- Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map
10586+- Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ]
10587+- readResource stat= do
10588+- mstr <- withMVar tvresources $ \mmap ->
10590+- Just map -> return $ M.lookup (keyResource stat) map
10591+- Nothing -> return Nothing
10593+- Nothing -> return Nothing
10594+- Just str -> return $ deserialize str
10596+- deleteResource stat= modifyMVar_ tvresources $ \mmap->
10598+- Just map -> return $ Just $ M.delete (keyResource stat) map
10599+- Nothing -> return $ Nothing
10601++------persistent state in cookies (not tested)
10603++tvresources :: MVar (Maybe ( M.Map string string))
10604++tvresources= unsafePerformIO $ newMVar Nothing
10605++statCookieName= "stat"
10607++putStateCookie req cookies=
10608++ case lookup statCookieName cookies of
10609++ Nothing -> return ()
10610++ Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $
10611++ \mmap -> case mmap of
10612++ Just map -> return $ Just $ M.insert (keyResource req) str map
10613++ Nothing -> return $ Just $ M.fromList [((keyResource req), str) ]
10615++getStateCookie req= do
10616++ mr<- readMVar tvresources
10618++ Nothing -> return Nothing
10619++ Just map -> case M.lookup (keyResource req) map of
10620++ Nothing -> return Nothing
10622++ swapMVar tvresources Nothing
10623++ return $ Just (statCookieName, str , "/")
10626++persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
10628++ writeResource stat= modifyMVar_ tvresources $ \mmap ->
10630++ Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map
10631++ Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ]
10632++ readResource stat= do
10633++ mstr <- withMVar tvresources $ \mmap ->
10635++ Just map -> return $ M.lookup (keyResource stat) map
10636++ Nothing -> return Nothing
10638++ Nothing -> return Nothing
10639++ Just str -> return $ deserialize str
10641++ deleteResource stat= modifyMVar_ tvresources $ \mmap->
10643++ Just map -> return $ Just $ M.delete (keyResource stat) map
10644++ Nothing -> return $ Nothing
10647+diff -ru orig/src/MFlow/Wai/Blaze/Html/All.hs new/src/MFlow/Wai/Blaze/Html/All.hs
10648+--- orig/src/MFlow/Wai/Blaze/Html/All.hs 2014-06-10 05:51:26.969015857 +0300
10649++++ new/src/MFlow/Wai/Blaze/Html/All.hs 2014-06-10 05:51:25.000000000 +0300
10651+-----------------------------------------------------------------------------
10653+--- Module : MFlow.Wai.Blaze.Html.All
10657+--- Maintainer : agocorona@gmail.com
10658+--- Stability : experimental
10663+------------------------------------------------------------------------------
10665+-module MFlow.Wai.Blaze.Html.All (
10666+- module Data.TCache
10668+-,module MFlow.Forms
10669+-,module MFlow.Forms.Widgets
10670+-,module MFlow.Forms.Blaze.Html
10671+-,module MFlow.Forms.Admin
10672+-,module Control.Applicative
10673+-,module Text.Blaze.Html5
10674+-,module Text.Blaze.Html5.Attributes
10675+-,module Control.Monad.IO.Class
10676+-,module MFlow.Forms.WebApi
10677+-,module MFlow.Forms.Cache
10679+-,runSecureNavigation
10684+-import MFlow.Forms
10685+-import MFlow.Forms.Widgets
10686+-import MFlow.Forms.Admin
10687+-import MFlow.Forms.Blaze.Html
10688+-import MFlow.Forms.WebApi
10689+-import MFlow.Forms.Cache
10690+-import Text.Blaze.Html5 hiding (map)
10691+-import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form)
10692+-import Network.Wai
10693+-import Network.Wai.Handler.Warp hiding (getPort) --(run,defaultSettings,Settings ,setPort)
10694+-import Data.TCache
10695+-import Text.Blaze.Internal(text)
10697+-import Control.Workflow (Workflow, unsafeIOtoWF)
10700+-import Control.Applicative
10701+-import Control.Monad(when, unless)
10702+-import Control.Monad.IO.Class
10703+-import System.Environment
10704+-import Data.Maybe(fromMaybe)
10705+-import Data.Char(isNumber)
10706+-import Network.Wai.Handler.WarpTLS as TLS
10708+--- | The port is read from the first exectution parameter.
10709+--- If no parameter, it is read from the PORT environment variable.
10710+--- if this does not exist, the port 80 is used.
10713+- port <- case args of
10714+- port:xs -> return port
10716+- env <- getEnvironment
10717+- return $ fromMaybe "80" $ lookup "PORT" env
10718+- let porti= if and $ map isNumber port then fromIntegral $ read port
10720+- putStr "using port "
10724+--- | run a persistent flow. It uses `getPort` to get the port
10725+--- The first parameter is the first element in the URL path.
10726+--- It also set the home page
10727+-runNavigation :: String -> FlowM Html (Workflow IO) () -> IO ()
10728+-runNavigation n f= do
10729+- unless (null n) $ setNoScript n
10730+- addMessageFlows[(n, runFlow f)]
10732+- wait $ run porti waiMessageFlow
10733+- --runSettings defaultSettings{settingsTimeout = 20, settingsPort= porti} waiMessageFlow
10735+--- | Exactly the same as runNavigation, but with TLS added.
10736+--- Expects certificate.pem and key.pem in project directory.
10738+-runSecureNavigation = runSecureNavigation' TLS.defaultTlsSettings defaultSettings
10740+-runSecureNavigation' :: TLSSettings -> Settings -> String -> FlowM Html (Workflow IO) () -> IO ()
10741+-runSecureNavigation' t s n f = do
10742+- unless (null n) $ setNoScript n
10743+- addMessageFlows[(n, runFlow f)]
10745+--- let s' = setPort porti s
10746++----------------------------------------------------------------------------
10748++-- Module : MFlow.Wai.Blaze.Html.All
10752++-- Maintainer : agocorona@gmail.com
10753++-- Stability : experimental
10758++-----------------------------------------------------------------------------
10760++module MFlow.Wai.Blaze.Html.All (
10761++ module Data.TCache
10763++,module MFlow.Forms
10764++,module MFlow.Forms.Widgets
10765++,module MFlow.Forms.Blaze.Html
10766++,module MFlow.Forms.Admin
10767++,module Control.Applicative
10768++,module Text.Blaze.Html5
10769++,module Text.Blaze.Html5.Attributes
10770++,module Control.Monad.IO.Class
10771++,module MFlow.Forms.WebApi
10772++,module MFlow.Forms.Cache
10774++,runSecureNavigation
10775++,runSecureNavigation'
10780++import MFlow.Forms
10781++import MFlow.Forms.Widgets
10782++import MFlow.Forms.Admin
10783++import MFlow.Forms.Blaze.Html
10784++import MFlow.Forms.WebApi
10785++import MFlow.Forms.Cache
10786++import Text.Blaze.Html5 hiding (map)
10787++import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form)
10788++import Network.Wai
10789++import Network.Wai.Handler.Warp --(run,defaultSettings,Settings ,setPort)
10790++import Data.TCache
10791++import Text.Blaze.Internal(text)
10793++import Control.Workflow (Workflow, unsafeIOtoWF)
10796++import Control.Applicative
10797++import Control.Monad(when, unless)
10798++import Control.Monad.IO.Class
10799++import System.Environment
10800++import Data.Maybe(fromMaybe)
10801++import Data.Char(isNumber)
10802++import Network.Wai.Handler.WarpTLS as TLS
10807++ port <- case args of
10808++ port:xs -> return port
10810++ env <- getEnvironment
10811++ return $ fromMaybe "80" $ lookup "PORT" env
10812++ let porti= if and $ map isNumber port then fromIntegral $ read port
10814++ putStr "using port "
10818++-- | run a persistent flow. It uses `getPortW` to get the port
10819++-- The first parameter is the first element in the URL path.
10820++-- It also set the home page
10821++-- The port is read from the first parameter passed to the executable.
10822++-- If no parameter, it is read from the PORT environment variable.
10823++-- if this does not exist, the port 80 is used.
10824++runNavigation :: String -> FlowM Html (Workflow IO) () -> IO ()
10825++runNavigation n f= do
10826++ unless (null n) $ setNoScript n
10827++ addMessageFlows[(n, runFlow f)]
10828++ porti <- getPortW
10829++ wait $ run porti waiMessageFlow
10830++ --runSettings defaultSettings{settingsTimeout = 20, settingsPort= porti} waiMessageFlow
10832++-- | Exactly the same as runNavigation, but with TLS added.
10833++-- Expects certificate.pem and key.pem in project directory.
10835++runSecureNavigation = runSecureNavigation' TLS.defaultTlsSettings defaultSettings
10837++runSecureNavigation' :: TLSSettings -> Settings -> String -> FlowM Html (Workflow IO) () -> IO ()
10838++runSecureNavigation' t s n f = do
10839++ unless (null n) $ setNoScript n
10840++ addMessageFlows[(n, runFlow f)]
10841++ porti <- getPortW
10842++-- let s' = setPort porti s
10843+ -- wait $ TLS.runTLS t s' waiMessageFlow
10844+- wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow
10845++ wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow
10846+diff -ru orig/src/MFlow/Wai/Response.hs new/src/MFlow/Wai/Response.hs
10847+--- orig/src/MFlow/Wai/Response.hs 2014-06-10 05:51:26.965015857 +0300
10848++++ new/src/MFlow/Wai/Response.hs 2014-06-10 05:51:25.000000000 +0300
10850+-{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances
10851+- -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
10852+-module MFlow.Wai.Response where
10854+-import Network.Wai
10855+-import MFlow.Cookies
10857+-import Data.ByteString.Lazy.UTF8
10859+-import Data.Typeable
10860+-import Data.Monoid
10861+-import System.IO.Unsafe
10862+-import Data.Map as M
10863+-import Data.CaseInsensitive
10864+-import Network.HTTP.Types
10865+-import Control.Workflow(WFErrors(..))
10866+---import Data.String
10867+---import Debug.Trace
10869+---(!>)= flip trace
10873+-class ToResponse a where
10874+- toResponse :: a -> Response
10878+-data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable
10880+-instance Monoid TResp where
10882+- mappend (TResp x) (TResp y)=
10884+- Just y' -> TResp $ mappend x y'
10885+- Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
10888+-mkParams = Prelude.map mkparam
10889+-mkparam (x,y)= (mk x, y)
10891+-instance ToResponse TResp where
10892+- toResponse (TResp x)= toResponse x
10893+- toResponse (TRespR r)= toResponse r
10895+-instance ToResponse Response where
10898+-instance ToResponse ByteString where
10899+- toResponse x= responseLBS status200 [mkparam contentHtml] x
10901+-instance ToResponse String where
10902+- toResponse x= responseLBS status200 [mkparam contentHtml] $ fromString x
10904+-instance ToResponse HttpData where
10905+- toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs <> cookieHeaders cookies)) x
10906+- toResponse (Error str)= responseLBS status404 [("Content-Type", "text/html")] str
10908+--- toResponse $ error "FATAL ERROR: HttpData errors should not reach here: MFlow.Forms.Response.hs "
10912++{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances
10913++ -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
10914++module MFlow.Wai.Response where
10916++import Network.Wai
10917++import MFlow.Cookies
10919++import Data.ByteString.Lazy.UTF8
10921++import Data.Typeable
10922++import Data.Monoid
10923++import System.IO.Unsafe
10924++import Data.Map as M
10925++import Data.CaseInsensitive
10926++import Network.HTTP.Types
10927++import Control.Workflow(WFErrors(..))
10928++--import Data.String
10929++--import Debug.Trace
10931++--(!>)= flip trace
10935++class ToResponse a where
10936++ toResponse :: a -> Response
10940++data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable
10942++instance Monoid TResp where
10944++ mappend (TResp x) (TResp y)=
10946++ Just y' -> TResp $ mappend x y'
10947++ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
10950++mkParams = Prelude.map mkparam
10951++mkparam (x,y)= (mk x, y)
10953++instance ToResponse TResp where
10954++ toResponse (TResp x)= toResponse x
10955++ toResponse (TRespR r)= toResponse r
10957++instance ToResponse Response where
10960++instance ToResponse ByteString where
10961++ toResponse x= responseLBS status200 [mkparam contentHtml] x
10963++instance ToResponse String where
10964++ toResponse x= responseLBS status200 [mkparam contentHtml] $ fromString x
10966++instance ToResponse HttpData where
10967++ toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs <> cookieHeaders cookies)) x
10968++ toResponse (Error str)= responseLBS status404 [("Content-Type", "text/html")] str
10970++-- toResponse $ error "FATAL ERROR: HttpData errors should not reach here: MFlow.Forms.Response.hs "
10974+diff -ru orig/src/MFlow/Wai.hs new/src/MFlow/Wai.hs
10975+--- orig/src/MFlow/Wai.hs 2014-06-10 05:51:26.957015857 +0300
10976++++ new/src/MFlow/Wai.hs 2014-06-10 05:51:25.000000000 +0300
10977+@@ -1,184 +1,209 @@
10978+-{-# LANGUAGE UndecidableInstances
10980+- , TypeSynonymInstances
10981+- , MultiParamTypeClasses
10982+- , DeriveDataTypeable
10983+- , FlexibleInstances
10984+- , OverloadedStrings #-}
10987+- module MFlow.Cookies
10992+-import Data.Typeable
10993+-import Network.Wai
10995+-import Control.Concurrent.MVar(modifyMVar_, readMVar)
10996+-import Control.Monad(when)
10999+-import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail)
11000+-import Data.ByteString.Lazy(fromChunks)
11001++{-# LANGUAGE UndecidableInstances
11003++ , TypeSynonymInstances
11004++ , MultiParamTypeClasses
11005++ , DeriveDataTypeable
11006++ , FlexibleInstances
11007++ , OverloadedStrings #-}
11010++ module MFlow.Cookies
11015++import Data.Typeable
11016++import Network.Wai
11018++import Control.Concurrent.MVar(modifyMVar_, readMVar)
11019++import Control.Monad(when)
11022++import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail)
11023++import Data.ByteString.Lazy(fromChunks)
11024+ import Data.ByteString.UTF8 hiding (span)
11025+-import qualified Data.ByteString as SB hiding (pack, unpack)
11026+-import Control.Concurrent(ThreadId(..))
11027+-import System.IO.Unsafe
11028+-import Control.Concurrent.MVar
11029+-import Control.Concurrent
11030+-import Control.Monad.Trans
11031+-import Control.Exception
11032+-import qualified Data.Map as M
11034+-import Data.TCache
11035+-import Data.TCache.DefaultPersistence
11036+-import Control.Workflow hiding (Indexable(..))
11039+-import MFlow.Cookies
11040+-import Data.Monoid
11041+-import MFlow.Wai.Response
11042+-import Network.Wai
11043+-import Network.HTTP.Types -- hiding (urlDecode)
11044+-import Data.Conduit
11045+-import Data.Conduit.Lazy
11046+-import qualified Data.Conduit.List as CList
11047+-import Data.CaseInsensitive
11048+-import System.Time
11049+-import qualified Data.Text as T
11052+---import Debug.Trace
11053+---(!>) = flip trace
11057+-instance Processable Request where
11058+- pwfPath env= if Prelude.null sc then [noScript] else Prelude.map T.unpack sc
11060+- sc= let p= pathInfo env
11064+- p' -> if T.null $ head p' then reverse(tail p') else p
11067+- puser env = fromMaybe anonymous $ fmap toString $ lookup ( mk $ fromString cookieuser) $ requestHeaders env
11069+- pind env= fromMaybe (error ": No FlowID") $ fmap toString $ lookup (mk flow) $ requestHeaders env
11070+- getParams= mkParams1 . requestHeaders
11072+- mkParams1 = Prelude.map mkParam1
11073+- mkParam1 ( x,y)= (toString $ original x, toString y)
11075+--- getServer env= serverName env
11076+--- getPath env= pathInfo env
11077+--- getPort env= serverPort env
11080+-splitPath ""= ("","","")
11083+- strr= reverse str
11084+- (ext, rest)= span (/= '.') strr
11085+- (mod, path)= span(/='/') $ tail rest
11086+- in (tail $ reverse path, reverse mod, reverse ext)
11089+-waiMessageFlow :: Application
11090+-waiMessageFlow req1= do
11091+- let httpreq1= requestHeaders req1
11093+- let cookies = getCookies httpreq1
11095+- (flowval , retcookies) <- case lookup flow cookies of
11096+- Just fl -> return (fl, [])
11098+- fl <- liftIO $ newFlow
11099+- return (fl, [UnEncryptedCookie (flow, fl, "/",Nothing):: Cookie])
11101+-{- for state persistence in cookies
11102+- putStateCookie req1 cookies
11103+- let retcookies= case getStateCookie req1 of
11104+- Nothing -> retcookies1
11105+- Just ck -> ck:retcookies1
11108+- input <- case parseMethod $ requestMethod req1 of
11111+- inp <- liftIO $ requestBody req1 $$ CList.consume
11113+- return . parseSimpleQuery $ SB.concat inp
11118+- return . Prelude.map (\(x,y) -> (x,fromMaybe "" y)) $ queryString req1
11121+- let req = case retcookies of
11122+- [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ"
11123+- _ -> req1{requestHeaders= mkParams ((flow, flowval): input ++ cookies) ++ requestHeaders req1} -- !> "REQ"
11126+- (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req)
11128+- let resp= case (resp',retcookies) of
11130+- (error@(Error _),_) -> error
11131+- (HttpData hs co str,_) -> HttpData hs (co++ retcookies) str
11133+- return $ toResponse resp
11136+-------persistent state in cookies (not tested)
11138+-tvresources :: MVar (Maybe ( M.Map string string))
11139+-tvresources= unsafePerformIO $ newMVar Nothing
11140+-statCookieName= "stat"
11142+-putStateCookie req cookies=
11143+- case lookup statCookieName cookies of
11144+- Nothing -> return ()
11145+- Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $
11146+- \mmap -> case mmap of
11147+- Just map -> return $ Just $ M.insert (keyResource req) str map
11148+- Nothing -> return $ Just $ M.fromList [((keyResource req), str) ]
11150+-getStateCookie req= do
11151+- mr<- readMVar tvresources
11153+- Nothing -> return Nothing
11154+- Just map -> case M.lookup (keyResource req) map of
11155+- Nothing -> return Nothing
11157+- swapMVar tvresources Nothing
11158+- return $ Just (statCookieName, str , "/")
11164+-persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
11166+- writeResource stat= modifyMVar_ tvresources $ \mmap ->
11168+- Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map
11169+- Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ]
11170+- readResource stat= do
11171+- mstr <- withMVar tvresources $ \mmap ->
11173+- Just map -> return $ M.lookup (keyResource stat) map
11174+- Nothing -> return Nothing
11176+- Nothing -> return Nothing
11177+- Just str -> return $ deserialize str
11179+- deleteResource stat= modifyMVar_ tvresources $ \mmap->
11181+- Just map -> return $ Just $ M.delete (keyResource stat) map
11182+- Nothing -> return $ Nothing
11185++import qualified Data.ByteString.Char8 as SB -- hiding (pack, unpack)
11186++import Control.Concurrent(ThreadId(..))
11187++import System.IO.Unsafe
11188++import Control.Concurrent.MVar
11189++import Control.Concurrent
11190++import Control.Monad.Trans
11191++import Control.Exception
11192++import qualified Data.Map as M
11194++import Data.TCache
11195++import Data.TCache.DefaultPersistence
11196++import Control.Workflow hiding (Indexable(..))
11199++import MFlow.Cookies
11200++import Data.Monoid
11201++import MFlow.Wai.Response
11202++import Network.Wai
11203++import Network.Wai.Parse
11204++import qualified Data.Conduit.Binary as CB
11205++import Control.Monad.Trans.Resource
11206++import Network.HTTP.Types
11207++import Data.Conduit
11208++import Data.Conduit.Lazy
11209++import qualified Data.Conduit.List as CList
11210++import Data.CaseInsensitive
11211++import System.Time
11212++import System.Directory
11214++import qualified Data.Text as T
11217++import Debug.Trace
11222++instance Processable Request where
11223++ pwfPath env= if Prelude.null sc then [noScript] else Prelude.map T.unpack sc
11225++ sc= let p= pathInfo env
11229++ p' -> if T.null $ head p' then reverse(tail p') else p
11232++ puser env = fromMaybe anonymous $ fmap toString $ lookup ( mk $ fromString cookieuser) $ requestHeaders env
11234++ pind env= fromMaybe (error ": No FlowID") $ fmap toString $ lookup (mk flow) $ requestHeaders env
11235++ getParams= mkParams1 . requestHeaders
11237++ mkParams1 = Prelude.map mkParam1
11238++ mkParam1 ( x,y)= (toString $ original x, toString y)
11240++toApp :: (Request -> IO Response) -> Application
11241++#if MIN_VERSION_wai(3, 0, 0)
11242++toApp f req sendResponse = f req >>= sendResponse
11247++waiMessageFlow :: Application
11248++waiMessageFlow = toApp $ \req1 -> do
11249++ let httpreq1= requestHeaders req1
11251++ let cookies = getCookies httpreq1
11253++ (flowval , retcookies) <- case lookup flow cookies of
11254++ Just fl -> return (fl, [])
11256++ fl <- liftIO $ newFlow
11257++ return (fl, [UnEncryptedCookie (flow, fl, "/",Nothing):: Cookie])
11259++{- for state persistence in cookies
11260++ putStateCookie req1 cookies
11261++ let retcookies= case getStateCookie req1 of
11262++ Nothing -> retcookies1
11263++ Just ck -> ck:retcookies1
11266++ (params,files) <- case parseMethod $ requestMethod req1 of
11268++ return (Prelude.map (\(x,y) -> (x,fromMaybe "" y)) $ queryString req1,[])
11272++ case getRequestBodyType req1 of
11273++ Nothing -> error $ "getRequestBodyType: "
11275++ runResourceT $ withInternalState $ \state -> liftIO $ do
11276++ let backend file info= do
11277++ (key, (fp, h)) <- flip runInternalState state $ allocate (do
11278++ tempDir <- getTemporaryDirectory
11279++ openBinaryTempFile tempDir "upload.tmp") (\(_, h) -> hClose h)
11281++ lift $ release key
11283++#if MIN_VERSION_wai(3, 0, 0)
11284++ let backend' file info getBS = do
11286++ bs <- liftIO getBS
11287++ when (not $ SB.null bs) $ do
11288++ Data.Conduit.yield bs
11290++ src $$ backend file info
11291++ sinkRequestBody backend' rbt (requestBody req1)
11293++ requestBody req1 $$ sinkRequestBody backend rbt
11296++-- let fileparams= Prelude.map (\(param,FileInfo filename contentype content)
11297++-- -> (param, SB.pack content )) files
11298++-- let fileparams= Prelude.map (\(param,fileinfo)
11299++-- -> (param, fileinfo )) files
11300++-- return $ fileparams++ params
11301++ let filesp= Prelude.map (\(param,FileInfo filename contentype tempfile)
11302++ -> (mk param, fromString $ show(filename,contentype,tempfile) )) files
11303++-- let filesp= Prelude.map (\(a,b) -> ( mk a, fromString $ show b)) files
11306++ let req = case retcookies of
11307++ [] -> req1{requestHeaders= filesp ++ mkParams (params ++ cookies) ++ requestHeaders req1}
11308++ _ -> req1{requestHeaders= filesp ++ mkParams ((flow, flowval): params ++ cookies) ++ requestHeaders req1}
11311++ (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req)
11313++ let resp= case (resp',retcookies) of
11315++ (error@(Error _),_) -> error
11316++ (HttpData hs co str,_) -> HttpData hs (co++ retcookies) str
11318++ return $ toResponse resp
11321++------persistent state in cookies (not tested)
11323++tvresources :: MVar (Maybe ( M.Map string string))
11324++tvresources= unsafePerformIO $ newMVar Nothing
11325++statCookieName= "stat"
11327++putStateCookie req cookies=
11328++ case lookup statCookieName cookies of
11329++ Nothing -> return ()
11330++ Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $
11331++ \mmap -> case mmap of
11332++ Just map -> return $ Just $ M.insert (keyResource req) str map
11333++ Nothing -> return $ Just $ M.fromList [((keyResource req), str) ]
11335++getStateCookie req= do
11336++ mr<- readMVar tvresources
11338++ Nothing -> return Nothing
11339++ Just map -> case M.lookup (keyResource req) map of
11340++ Nothing -> return Nothing
11342++ swapMVar tvresources Nothing
11343++ return $ Just (statCookieName, str , "/")
11349++persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
11351++ writeResource stat= modifyMVar_ tvresources $ \mmap ->
11353++ Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map
11354++ Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ]
11355++ readResource stat= do
11356++ mstr <- withMVar tvresources $ \mmap ->
11358++ Just map -> return $ M.lookup (keyResource stat) map
11359++ Nothing -> return Nothing
11361++ Nothing -> return Nothing
11362++ Just str -> return $ deserialize str
11364++ deleteResource stat= modifyMVar_ tvresources $ \mmap->
11366++ Just map -> return $ Just $ M.delete (keyResource stat) map
11367++ Nothing -> return $ Nothing
11370+diff -ru orig/src/MFlow.hs new/src/MFlow.hs
11371+--- orig/src/MFlow.hs 2014-06-10 05:51:26.957015857 +0300
11372++++ new/src/MFlow.hs 2014-06-10 05:51:25.000000000 +0300
11373+@@ -1,545 +1,550 @@
11374+-{- | Non monadic low level primitives that implement the MFlow application server.
11375+-See "MFlow.Form" for the higher level interface that you may use.
11377+-it implements an scheduler of 'Processable' messages that are served according with
11378+-the source identification and the verb invoked.
11379+-The scheduler executed the appropriate workflow (using the workflow package).
11380+-The workflow will send additional messages to the source and wait for the responses.
11381+-The diaglog is identified by a 'Token', which is associated to the flow.
11382+-. The computation state is optionally logged. On timeout, the process is killed. When invoked again,
11383+-the execution state is recovered as if no interruption took place.
11385+-There is no asumption about message codification, so instantiations
11386+-of this scheduler for different infrastructures is possible,
11387+-including non-Web based ones as long as they support or emulate cookies.
11389+-"MFlow.Hack" is an instantiation for the Hack interface in a Web context.
11391+-"MFlow.Wai" is a instantiation for the WAI interface.
11393+-"MFlow.Forms" implements a monadic type safe interface with composabe widgets and and applicative
11394+-combinator as well as an higher comunication interface.
11396+-"MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format
11398+-"MFlow.Forms.Blaze.Html" is an instantaiation for blaze-html
11400+-"MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format
11402+-There are some @*.All@ packages that contain a mix of these instantiations.
11403+-For exmaple, "MFlow.Wai.Blaze.Html.All" includes most of all necessary for using MFlow with
11404+-Wai <http://hackage.haskell.org/package/wai> and
11405+-Blaze-html <http://hackage.haskell.org/package/blaze-html>
11408+-In order to manage resources, there are primitives that kill the process and its state after a timeout.
11410+-All these details are hidden in the monad of "MFlow.Forms" that provides an higher level interface.
11412+-Fragment based streaming: 'sendFragment' are provided only at this level.
11414+-'stateless' and 'transient' server processeses are also possible. the first are request-response
11415+- . `transient` processes do not persist after timeout, so they restart anew after a timeout or a crash.
11420+-{-# LANGUAGE DeriveDataTypeable, UndecidableInstances
11421+- ,ExistentialQuantification
11422+- ,MultiParamTypeClasses
11423+- ,FunctionalDependencies
11424+- ,TypeSynonymInstances
11425+- ,FlexibleInstances
11426+- ,FlexibleContexts
11428+- ,OverloadedStrings
11429+- ,ScopedTypeVariables
11433+-Flow, Params, HttpData(..),Processable(..)
11434+-, Token(..), ProcList
11435+--- * low level comunication primitives. Use `ask` instead
11436+-,flushRec, flushResponse, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment
11437+-, sendEndFragment, sendToMF
11438+--- * Flow configuration
11439+-,setNoScript,addMessageFlows,getMessageFlows,delMessageFlow, transient, stateless,anonymous
11440+-,noScript,hlog, setNotFoundResponse,getNotFoundResponse,
11441+--- * ByteString tags
11442+--- | very basic but efficient bytestring tag formatting
11443+-btag, bhtml, bbody,Attribs, addAttrs
11445+-, userRegister, setAdminUser, getAdminName, Auth(..),getAuthMethod, setAuthMethod
11446++{- | Non monadic low level primitives that implement the MFlow application server.
11447++See "MFlow.Form" for the higher level interface that you may use.
11449++it implements an scheduler of 'Processable' messages that are served according with
11450++the source identification and the verb invoked.
11451++The scheduler executed the appropriate workflow (using the workflow package).
11452++The workflow will send additional messages to the source and wait for the responses.
11453++The diaglog is identified by a 'Token', which is associated to the flow.
11454++. The computation state is optionally logged. On timeout, the process is killed. When invoked again,
11455++the execution state is recovered as if no interruption took place.
11457++There is no asumption about message codification, so instantiations
11458++of this scheduler for different infrastructures is possible,
11459++including non-Web based ones as long as they support or emulate cookies.
11461++"MFlow.Hack" is an instantiation for the Hack interface in a Web context.
11463++"MFlow.Wai" is a instantiation for the WAI interface.
11465++"MFlow.Forms" implements a monadic type safe interface with composabe widgets and and applicative
11466++combinator as well as an higher comunication interface.
11468++"MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format
11470++"MFlow.Forms.Blaze.Html" is an instantaiation for blaze-html
11472++"MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format
11474++There are some @*.All@ packages that contain a mix of these instantiations.
11475++For exmaple, "MFlow.Wai.Blaze.Html.All" includes most of all necessary for using MFlow with
11476++Wai <http://hackage.haskell.org/package/wai> and
11477++Blaze-html <http://hackage.haskell.org/package/blaze-html>
11480++In order to manage resources, there are primitives that kill the process and its state after a timeout.
11482++All these details are hidden in the monad of "MFlow.Forms" that provides an higher level interface.
11484++Fragment based streaming: 'sendFragment' are provided only at this level.
11486++'stateless' and 'transient' server processeses are also possible. the first are request-response
11487++ . `transient` processes do not persist after timeout, so they restart anew after a timeout or a crash.
11492++{-# LANGUAGE DeriveDataTypeable, UndecidableInstances
11493++ ,ExistentialQuantification
11494++ ,MultiParamTypeClasses
11495++ ,FunctionalDependencies
11496++ ,TypeSynonymInstances
11497++ ,FlexibleInstances
11498++ ,FlexibleContexts
11500++ ,OverloadedStrings
11501++ ,ScopedTypeVariables
11505++Flow, Params, HttpData(..),Processable(..)
11506++, Token(..), ProcList
11507++-- * low level comunication primitives. Use `ask` instead
11508++,flushRec, flushResponse, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment
11509++, sendEndFragment, sendToMF
11510++-- * Flow configuration
11511++,setNoScript,addMessageFlows,getMessageFlows,delMessageFlow, transient, stateless,anonymous
11512++,noScript,hlog, setNotFoundResponse,getNotFoundResponse,
11513++-- * ByteString tags
11514++-- | very basic but efficient bytestring tag formatting
11515++btag, bhtml, bbody,Attribs, addAttrs
11517++, userRegister, setAdminUser, getAdminName, Auth(..),getAuthMethod, setAuthMethod
11520+-,config, getConfig
11523+-,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow
11524+-,UserStr,PasswdStr, User(..),eUser
11528+-import Control.Concurrent.MVar
11530+-import GHC.Conc(unsafeIOToSTM)
11531+-import Data.Typeable
11532+-import Data.Maybe(isJust, isNothing, fromMaybe, fromJust)
11533+-import Data.Char(isSeparator)
11534+-import Data.List(isPrefixOf,isSuffixOf,isInfixOf, elem , span, (\\),intersperse)
11535+-import Control.Monad(when)
11537+-import Data.Monoid
11538+-import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId)
11539+-import Data.Char(toLower)
11541+-import Unsafe.Coerce
11542+-import System.IO.Unsafe
11543+-import Data.TCache
11544+-import Data.TCache.DefaultPersistence hiding(Indexable(..))
11545+-import Data.TCache.Memoization
11546+-import qualified Data.ByteString.Lazy.Char8 as B (head, readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks)
11547+-import Data.ByteString.Lazy.Internal (ByteString(Chunk))
11548+-import qualified Data.ByteString.Char8 as SB
11549+-import qualified Data.Map as M
11551+-import System.Time
11552+-import Control.Workflow
11553+-import MFlow.Cookies
11554+-import Control.Monad.Trans
11555+-import qualified Control.Exception as CE
11556+-import Data.RefSerialize hiding (empty)
11557+-import qualified Data.Text as T
11558+-import System.Posix.Internals
11559+-import Control.Exception
11560+---import Debug.Trace
11561+---(!>) = flip trace
11564+--- | a Token identifies a flow that handle messages. The scheduler compose a Token with every `Processable`
11565+--- message that arrives and send the mesage to the appropriate flow.
11566+-data Token = Token{twfname,tuser, tind :: String , tpath :: [String], tenv:: Params, tblock:: MVar Bool, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable
11568+-instance Indexable Token where
11569+- key (Token w u i _ _ _ _ _ )= i
11570+--- if u== anonymous then u ++ i -- ++ "@" ++ w
11571+--- else u -- ++ "@" ++ w
11573+-instance Show Token where
11574+- show t = "Token " ++ key t
11576+-instance Read Token where
11577+- readsPrec _ ('T':'o':'k':'e': 'n':' ':str1)
11578+- | anonymous `isPrefixOf` str1= [(Token w anonymous i [] [] (newVar True) (newVar 0) (newVar 0), tail str2)]
11579+- | otherwise = [(Token w ui "0" [] [] (newVar True) (newVar 0) (newVar 0), tail str2)]
11583+- (ui,str')= span(/='@') str1
11584+- i = drop (length anonymous) ui
11585+- (w,str2) = span (not . isSeparator) $ tail str'
11586+- newVar _= unsafePerformIO $ newEmptyMVar
11589+- readsPrec _ str= error $ "parse error in Token read from: "++ str
11591+-instance Serializable Token where
11592+- serialize = B.pack . show
11593+- deserialize= read . B.unpack
11594+- setPersist = \_ -> Just filePersist
11596+-iorefqmap= unsafePerformIO . newMVar $ M.empty
11598+-addTokenToList t@Token{..} =
11599+- modifyMVar_ iorefqmap $ \ map ->
11600+- return $ M.insert ( tind ++ twfname ++ tuser ) t map
11602+-deleteTokenInList t@Token{..} =
11603+- modifyMVar_ iorefqmap $ \ map ->
11604+- return $ M.delete (tind ++ twfname ++ tuser) map
11607+- qmap <- readMVar iorefqmap
11608+- let u= puser msg ; w= pwfname msg ; i=pind msg; ppath=pwfPath msg;penv= getParams msg
11609+- let mqs = M.lookup ( i ++ w ++ u) qmap
11612+- q <- newEmptyMVar -- `debug` (i++w++u)
11616++,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow
11617++,UserStr,PasswdStr, User(..),eUser
11621++import Control.Concurrent.MVar
11623++import GHC.Conc(unsafeIOToSTM)
11624++import Data.Typeable
11625++import Data.Maybe(isJust, isNothing, fromMaybe, fromJust)
11626++import Data.Char(isSeparator)
11627++import Data.List(isPrefixOf,isSuffixOf,isInfixOf, elem , span, (\\),intersperse)
11628++import Control.Monad(when)
11630++import Data.Monoid
11631++import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId)
11632++import Data.Char(toLower)
11634++import Unsafe.Coerce
11635++import System.IO.Unsafe
11636++import Data.TCache
11637++import Data.TCache.DefaultPersistence hiding(Indexable(..))
11638++import Data.TCache.Memoization
11639++import qualified Data.ByteString.Lazy.Char8 as B (head, readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks)
11640++import Data.ByteString.Lazy.Internal (ByteString(Chunk))
11641++import qualified Data.ByteString.Char8 as SB
11642++import qualified Data.Map as M
11644++import System.Time
11645++import Control.Workflow
11646++import MFlow.Cookies
11647++import Control.Monad.Trans
11648++import qualified Control.Exception as CE
11649++import Data.RefSerialize hiding (empty)
11650++import qualified Data.Text as T
11651++import System.Posix.Internals
11652++import Control.Exception
11653++import Crypto.PasswordStore
11656++--import Debug.Trace
11657++--(!>) = flip trace
11660++-- | a Token identifies a flow that handle messages. The scheduler compose a Token with every `Processable`
11661++-- message that arrives and send the mesage to the appropriate flow.
11662++data Token = Token{twfname,tuser, tind :: String , tpath :: [String], tenv:: Params, tblock:: MVar Bool, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable
11664++instance Indexable Token where
11665++ key (Token w u i _ _ _ _ _ )= i
11666++-- if u== anonymous then u ++ i -- ++ "@" ++ w
11667++-- else u -- ++ "@" ++ w
11669++instance Show Token where
11670++ show t = "Token " ++ key t
11672++instance Read Token where
11673++ readsPrec _ ('T':'o':'k':'e': 'n':' ':str1)
11674++ | anonymous `isPrefixOf` str1= [(Token w anonymous i [] [] (newVar True) (newVar 0) (newVar 0), tail str2)]
11675++ | otherwise = [(Token w ui "0" [] [] (newVar True) (newVar 0) (newVar 0), tail str2)]
11679++ (ui,str')= span(/='@') str1
11680++ i = drop (length anonymous) ui
11681++ (w,str2) = span (not . isSeparator) $ tail str'
11682++ newVar _= unsafePerformIO $ newEmptyMVar
11685++ readsPrec _ str= error $ "parse error in Token read from: "++ str
11687++instance Serializable Token where
11688++ serialize = B.pack . show
11689++ deserialize= read . B.unpack
11690++ setPersist = \_ -> Just filePersist
11692++iorefqmap= unsafePerformIO . newMVar $ M.empty
11694++addTokenToList t@Token{..} =
11695++ modifyMVar_ iorefqmap $ \ map ->
11696++ return $ M.insert ( tind ++ twfname ++ tuser ) t map
11698++deleteTokenInList t@Token{..} =
11699++ modifyMVar_ iorefqmap $ \ map ->
11700++ return $ M.delete (tind ++ twfname ++ tuser) map
11703++ qmap <- readMVar iorefqmap
11704++ let u= puser msg ; w= pwfname msg ; i=pind msg; ppath=pwfPath msg;penv= getParams msg
11705++ let mqs = M.lookup ( i ++ w ++ u) qmap
11708++ q <- newEmptyMVar -- `debug` (i++w++u)
11709+ qr <- newEmptyMVar
11710+- pblock <- newMVar True
11711+- let token= Token w u i ppath penv pblock q qr
11712+- addTokenToList token
11715+- Just token -> return token{tpath= ppath, tenv= penv}
11718+-type Flow= (Token -> Workflow IO ())
11720+-data HttpData = HttpData [(SB.ByteString,SB.ByteString)] [Cookie] ByteString | Error ByteString deriving (Typeable, Show)
11723+-instance Monoid HttpData where
11724+- mempty= HttpData [] [] B.empty
11725+- mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s'
11727+--- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname
11728+-type ProcList = WorkflowList IO Token ()
11731+-data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable
11733+-type Params = [(String,String)]
11735+-class Processable a where
11736+- pwfname :: a -> String
11737+- pwfname s= Prelude.head $ pwfPath s
11738+- pwfPath :: a -> [String]
11739+- puser :: a -> String
11740+- pind :: a -> String
11741+- getParams :: a -> Params
11743+-instance Processable Token where
11744+- pwfname = twfname
11750+-instance Processable Req where
11751+- pwfname (Req x)= pwfname x
11752+- pwfPath (Req x)= pwfPath x
11753+- puser (Req x)= puser x
11754+- pind (Req x)= pind x
11755+- getParams (Req x)= getParams x
11756+--- getServer (Req x)= getServer x
11757+--- getPort (Req x)= getPort x
11759+-data Resp = Fragm HttpData
11760+- | EndFragm HttpData
11766+--- | The anonymous user
11767+-anonymous= "anon#"
11769+--- | It is the path of the root flow
11770++ pblock <- newMVar True
11771++ let token= Token w u i ppath penv pblock q qr
11772++ addTokenToList token
11775++ Just token -> return token{tpath= ppath, tenv= penv}
11778++type Flow= (Token -> Workflow IO ())
11780++data HttpData = HttpData [(SB.ByteString,SB.ByteString)] [Cookie] ByteString | Error ByteString deriving (Typeable, Show)
11783++instance Monoid HttpData where
11784++ mempty= HttpData [] [] B.empty
11785++ mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s'
11787++-- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname
11788++type ProcList = WorkflowList IO Token ()
11791++data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable
11793++type Params = [(String,String)]
11795++class Processable a where
11796++ pwfname :: a -> String
11797++ pwfname s= Prelude.head $ pwfPath s
11798++ pwfPath :: a -> [String]
11799++ puser :: a -> String
11800++ pind :: a -> String
11801++ getParams :: a -> Params
11803++instance Processable Token where
11804++ pwfname = twfname
11810++instance Processable Req where
11811++ pwfname (Req x)= pwfname x
11812++ pwfPath (Req x)= pwfPath x
11813++ puser (Req x)= puser x
11814++ pind (Req x)= pind x
11815++ getParams (Req x)= getParams x
11816++-- getServer (Req x)= getServer x
11817++-- getPort (Req x)= getPort x
11819++data Resp = Fragm HttpData
11820++ | EndFragm HttpData
11826++-- | The anonymous user
11827++anonymous= "anon#"
11829++-- | It is the path of the root flow
11830+ noScriptRef= unsafePerformIO $ newIORef "noscript"
11832+-noScript= unsafePerformIO $ readIORef noScriptRef
11834++noScript= unsafePerformIO $ readIORef noScriptRef
11836+ -- | set the flow to be executed when the URL has no path. The home page.
11838+ -- By default it is "noscript".
11839+ -- Although it is changed by `runNavigation` to his own flow name.
11840+-setNoScript scr= writeIORef noScriptRef scr
11843+-instance (Monad m, Show a) => Traceable (Workflow m a) where
11844+- debugf iox str = do
11846+- return $ debug x (str++" => Workflow "++ show x)
11848+--- | send a complete response
11849+---send :: Token -> HttpData -> IO()
11850+-send t@(Token _ _ _ _ _ _ _ qresp) msg= do
11851+- ( putMVar qresp . Resp $ msg ) -- !> ("<<<<< send "++ show t)
11853+-sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush "
11855+--- | send a response fragment. Useful for streaming. the last packet must be sent trough 'send'
11856+-sendFragment :: Token -> HttpData -> IO()
11857+-sendFragment (Token _ _ _ _ _ _ _ qresp) msg= putMVar qresp . Fragm $ msg
11859+-{-# DEPRECATED sendEndFragment "use \"send\" to end a fragmented response instead" #-}
11860+-sendEndFragment :: Token -> HttpData -> IO()
11861+-sendEndFragment (Token _ _ _ _ _ _ _ qresp) msg= putMVar qresp $ EndFragm msg
11863+---emptyReceive (Token queue _ _)= emptyQueue queue
11864+-receive :: Typeable a => Token -> IO a
11865+-receive t= receiveReq t >>= return . fromReq
11867+-flushResponse t@(Token _ _ _ _ _ _ _ qresp)= tryTakeMVar qresp
11870+-flushRec t@(Token _ _ _ _ _ _ queue _)= tryTakeMVar queue -- !> "flushRec"
11872+-receiveReq :: Token -> IO Req
11873++setNoScript scr= writeIORef noScriptRef scr
11876++instance (Monad m, Show a) => Traceable (Workflow m a) where
11877++ debugf iox str = do
11879++ return $ debug x (str++" => Workflow "++ show x)
11881++-- | send a complete response
11882++--send :: Token -> HttpData -> IO()
11883++send t@(Token _ _ _ _ _ _ _ qresp) msg= do
11884++ ( putMVar qresp . Resp $ msg ) -- !> ("<<<<< send "++ show t)
11886++sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush "
11888++-- | send a response fragment. Useful for streaming. the last packet must be sent trough 'send'
11889++sendFragment :: Token -> HttpData -> IO()
11890++sendFragment (Token _ _ _ _ _ _ _ qresp) msg= putMVar qresp . Fragm $ msg
11892++{-# DEPRECATED sendEndFragment "use \"send\" to end a fragmented response instead" #-}
11893++sendEndFragment :: Token -> HttpData -> IO()
11894++sendEndFragment (Token _ _ _ _ _ _ _ qresp) msg= putMVar qresp $ EndFragm msg
11896++--emptyReceive (Token queue _ _)= emptyQueue queue
11897++receive :: Typeable a => Token -> IO a
11898++receive t= receiveReq t >>= return . fromReq
11900++flushResponse t@(Token _ _ _ _ _ _ _ qresp)= tryTakeMVar qresp
11903++flushRec t@(Token _ _ _ _ _ _ queue _)= tryTakeMVar queue -- !> "flushRec"
11905++receiveReq :: Token -> IO Req
11906+ receiveReq t@(Token _ _ _ _ _ _ queue _)= do
11907+ r <- readMVar queue -- !> (">>>>>> receiveReq ")
11908+- return r -- !> "receiveReq >>>>"
11910+-fromReq :: Typeable a => Req -> a
11911+-fromReq (Req x) = x' where
11912+- x'= case cast x of
11913+- Nothing -> error $ "receive: received type: "++ show (typeOf x) ++ " does not match the desired type:" ++ show (typeOf x')
11917+-receiveReqTimeout :: Int
11921+-receiveReqTimeout 0 0 t= receiveReq t
11922+-receiveReqTimeout time time2 t=
11923+- let id= keyWF (twfname t) t in withKillTimeout id time time2 (receiveReq t)
11926+-delMsgHistory t = do
11927+- let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t
11928+- delWFHistory1 statKey -- `debug` "delWFHistory"
11932+--- | executes a simple request-response computation that receive the params and return a response
11934+--- It is used with `addMessageFlows`
11936+--- There is a higuer level version @wstateless@ in "MFLow.Forms"
11937+-stateless :: (Params -> IO HttpData) -> Flow
11938+-stateless f = transient proc
11940+- proc t@(Token _ _ _ _ _ _ queue qresp) = loop t queue qresp
11941+- loop t queue qresp=do
11942+- req <- takeMVar queue -- !> (">>>>>> stateless " ++ thread t)
11943+- resp <- f (getParams req)
11944+- (putMVar qresp $ Resp resp ) -- !> ("<<<<<< stateless " ++thread t)
11945+- loop t queue qresp -- !> ("enviado stateless " ++ thread t)
11949+--- | Executes a monadic computation that send and receive messages, but does
11950+--- not store its state in permanent storage. The process once stopped, will restart anew
11952+----- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow`
11953+-transient :: (Token -> IO ()) -> Flow
11954+-transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) )
11957+-_messageFlows :: MVar (WorkflowList IO Token ()) -- MVar (M.Map String (Token -> Workflow IO ()))
11958+-_messageFlows= unsafePerformIO $ newMVar emptyFList
11960+- emptyFList= M.empty :: WorkflowList IO Token ()
11962+--- | add a list of flows to be scheduled. Each entry in the list is a pair @(path, flow)@
11963+-addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union (M.fromList $ map flt wfs)ms)
11964+- where flt ("",f)= (noScript,f)
11967+--- | return the list of the scheduler
11968+-getMessageFlows = readMVar _messageFlows
11970+-delMessageFlow wfname= modifyMVar_ _messageFlows (\ms -> return $ M.delete wfname ms)
11973+-sendToMF Token{..} msg= putMVar tsendq (Req msg) -- !> "sendToMF"
11975+---recFromMF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c
11976+-recFromMF t@Token{..} = do
11977+- m <- takeMVar trecq -- !> "recFromMF <<<<<< "
11979+- Resp r -> return r -- !> "<<<<<< recFromMF"
11981+- result <- getStream r
11986+- mr <- takeMVar trecq
11989+- rest <- unsafeInterleaveIO $ getStream h
11990+- let result= mappend r rest
11993+- let result= mappend r h
11997+- let result= mappend r h
12003+--- | The scheduler creates a Token with every `Processable`
12004+--- message that arrives and send the mesage to the appropriate flow, then wait for the response
12007+--- It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it
12009+- :: (Typeable a,Processable a)
12010+- => a -> IO (HttpData, ThreadId)
12011+-msgScheduler x = do
12012++ return r -- !> "receiveReq >>>>"
12014++fromReq :: Typeable a => Req -> a
12015++fromReq (Req x) = x' where
12016++ x'= case cast x of
12017++ Nothing -> error $ "receive: received type: "++ show (typeOf x) ++ " does not match the desired type:" ++ show (typeOf x')
12021++receiveReqTimeout :: Int
12025++receiveReqTimeout 0 0 t= receiveReq t
12026++receiveReqTimeout time time2 t=
12027++ let id= keyWF (twfname t) t in withKillTimeout id time time2 (receiveReq t)
12030++delMsgHistory t = do
12031++ let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t
12032++ delWFHistory1 statKey -- `debug` "delWFHistory"
12036++-- | executes a simple request-response computation that receive the params and return a response
12038++-- It is used with `addMessageFlows`
12040++-- There is a higuer level version @wstateless@ in "MFLow.Forms"
12041++stateless :: (Params -> IO HttpData) -> Flow
12042++stateless f = transient proc
12044++ proc t@(Token _ _ _ _ _ _ queue qresp) = loop t queue qresp
12045++ loop t queue qresp=do
12046++ req <- takeMVar queue -- !> (">>>>>> stateless " ++ thread t)
12047++ resp <- f (getParams req)
12048++ (putMVar qresp $ Resp resp ) -- !> ("<<<<<< stateless " ++thread t)
12049++ loop t queue qresp -- !> ("enviado stateless " ++ thread t)
12053++-- | Executes a monadic computation that send and receive messages, but does
12054++-- not store its state in permanent storage. The process once stopped, will restart anew
12056++---- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow`
12057++transient :: (Token -> IO ()) -> Flow
12058++transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) )
12061++_messageFlows :: MVar (WorkflowList IO Token ()) -- MVar (M.Map String (Token -> Workflow IO ()))
12062++_messageFlows= unsafePerformIO $ newMVar emptyFList
12064++ emptyFList= M.empty :: WorkflowList IO Token ()
12066++-- | add a list of flows to be scheduled. Each entry in the list is a pair @(path, flow)@
12067++addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union (M.fromList $ map flt wfs)ms)
12068++ where flt ("",f)= (noScript,f)
12071++-- | return the list of the scheduler
12072++getMessageFlows = readMVar _messageFlows
12074++delMessageFlow wfname= modifyMVar_ _messageFlows (\ms -> return $ M.delete wfname ms)
12077++sendToMF Token{..} msg= putMVar tsendq (Req msg) -- !> "sendToMF"
12079++--recFromMF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c
12080++recFromMF t@Token{..} = do
12081++ m <- takeMVar trecq -- !> "recFromMF <<<<<< "
12083++ Resp r -> return r -- !> "<<<<<< recFromMF"
12085++ result <- getStream r
12090++ mr <- takeMVar trecq
12093++ rest <- unsafeInterleaveIO $ getStream h
12094++ let result= mappend r rest
12097++ let result= mappend r h
12101++ let result= mappend r h
12107++-- | The scheduler creates a Token with every `Processable`
12108++-- message that arrives and send the mesage to the appropriate flow, then wait for the response
12111++-- It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it
12113++ :: (Typeable a,Processable a)
12114++ => a -> IO (HttpData, ThreadId)
12115++msgScheduler x = do
12116+ token <- getToken x
12119+ let wfname = takeWhile (/='/') $ pwfname x
12120+- criticalSection (tblock token) $ do
12121+- sendToMF token x -- !> show th
12122+- th <- startMessageFlow wfname token
12123+- r <- recFromMF token
12124+- return (r,th) -- !> let HttpData _ _ r1=r in B.unpack r1
12125++ criticalSection (tblock token) $ do
12126++ sendToMF token x -- !> show th
12127++ th <- startMessageFlow wfname token
12128++ r <- recFromMF token
12129++ return (r,th) -- !> let HttpData _ _ r1=r in B.unpack r1
12131+- criticalSection mv f= bracket
12134++ criticalSection mv f= bracket
12139+- --start the flow if not started yet
12140+- startMessageFlow wfname token =
12142+- wfs <- getMessageFlows
12143+- r <- startWF wfname token wfs -- !>( "init wf " ++ wfname)
12145+- Left NotFound -> do
12146+- (sendFlush token =<< serveFile (pwfname x))
12148++ --start the flow if not started yet
12149++ startMessageFlow wfname token =
12151++ wfs <- getMessageFlows
12152++ r <- startWF wfname token wfs -- !>( "init wf " ++ wfname)
12154++ Left NotFound -> do
12155++ (sendFlush token =<< serveFile (pwfname x))
12156+ `CE.catch` \(e:: CE.SomeException) -> do
12157+- showError wfname token (show e)
12158+--- sendFlush token (Error NotFound $ "Not found: " <> pack wfname)
12159+- deleteTokenInList token
12161+- Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname)
12163+- Left Timeout -> do
12164+- hFlush stdout -- !> ("TIMEOUT in msgScheduler" ++ (show $ unsafePerformIO myThreadId))
12165+- deleteTokenInList token
12167+- Left (WFException e)-> do
12168+- showError wfname token e
12169+- moveState wfname token token{tind= "error/"++tuser token}
12170+- deleteTokenInList token -- !> "DELETETOKEN"
12173+- Right _ -> delMsgHistory token >> return () -- !> ("finished " ++ wfname)
12177+-showError wfname token@Token{..} e= do
12178+- t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime
12179+- let msg= errorMessage t e tuser (Prelude.concat $ intersperse "/" tpath) tenv
12181+- fresp <- getNotFoundResponse
12182+- let admin= getAdminName
12183+- sendFlush token . Error $ fresp (tuser== admin) $ Prelude.concat[ "<br/>"++ s | s <- lines msg]
12186+-errorMessage t e u path env=
12187+- "\n---------------------ERROR-------------------------\
12188+- \\nTIME=" ++ t ++"\n\n" ++
12190+- "\n\nUSER= " ++ u ++
12191+- "\n\nPATH= " ++ path ++
12192+- "\n\nREQUEST:\n\n" ++
12195+-line= unsafePerformIO $ newMVar ()
12200+- hSeek hlog SeekFromEnd 0
12201+- hPutStrLn hlog err
12205+-logFileName= "errlog"
12209+--- | The handler of the error log
12210+-hlog= unsafePerformIO $ openFile logFileName ReadWriteMode
12212+------- USER MANAGEMENT -------
12215+- uregister :: UserStr -> PasswdStr -> (IO (Maybe String)),
12216+- uvalidate :: UserStr -> PasswdStr -> (IO (Maybe String))}
12218+-_authMethod= unsafePerformIO $ newIORef $ Auth tCacheRegister tCacheValidate
12220+--- | set an authentication method
12221+-setAuthMethod auth= writeIORef _authMethod auth
12223+-getAuthMethod = readIORef _authMethod
12227+- { userName :: String
12228+- , upassword :: String
12229+- } deriving (Read, Show, Typeable)
12232+-eUser= User (error1 "username") (error1 "password")
12234+-error1 s= error $ s ++ " undefined"
12236+-userPrefix= "user/"
12237+-instance Indexable User where
12238+- key User{userName= user}= keyUserName user
12240+--- | Return the key name of an user
12241+-keyUserName n= userPrefix++n
12243+-instance Serializable User where
12244+- serialize= B.pack . show
12245+- deserialize= read . B.unpack
12246+- setPersist = \_ -> Just filePersist
12248+--- | Register an user/password
12249+-tCacheRegister :: String -> String -> IO (Maybe String)
12250+-tCacheRegister user password = atomically $ do
12251+- withSTMResources [newuser] doit
12253+- newuser= User user password
12254+- doit [Just (User _ _)] = resources{toReturn= Just "user already exist"}
12255+- doit [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
12257+-tCacheValidate :: UserStr -> PasswdStr -> IO (Maybe String)
12258+-tCacheValidate u p =
12259+- let user= eUser{userName=u}
12261+- $ withSTMResources [user]
12262+- $ \ mu -> case mu of
12263+- [Nothing] -> resources{toReturn= err }
12264+- [Just (User _ pass )] -> resources{toReturn=
12271+- err= Just "Username or password invalid"
12273+-userRegister u p= liftIO $ do
12274+- Auth reg _ <- getAuthMethod :: IO Auth
12278+-newtype Config= Config1 (M.Map String String) deriving (Read,Show,Typeable)
12280+---defConfig= Config1 $ M.fromList
12281+--- [("cadmin","admin")
12282+--- ,("cjqueryScript","//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js")
12283+--- ,("cjqueryCSS","//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css")
12284+--- ,("cjqueryUI","//code.jquery.com/ui/1.10.3/jquery-ui.js")
12285+--- ,("cnicEditUrl","//js.nicedit.com/nicEdit-latest.js")]
12287++ showError wfname token (show e)
12288++-- sendFlush token (Error NotFound $ "Not found: " <> pack wfname)
12289++ deleteTokenInList token
12291++ Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname)
12293++ Left Timeout -> do
12294++ hFlush stdout -- !> ("TIMEOUT in msgScheduler" ++ (show $ unsafePerformIO myThreadId))
12295++ deleteTokenInList token
12297++ Left (WFException e)-> do
12298++ showError wfname token e
12299++ moveState wfname token token{tind= "error/"++tuser token}
12300++ deleteTokenInList token -- !> "DELETETOKEN"
12303++ Right _ -> delMsgHistory token >> return () -- !> ("finished " ++ wfname)
12307++showError wfname token@Token{..} e= do
12308++ t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime
12309++ let msg= errorMessage t e tuser (Prelude.concat $ intersperse "/" tpath) tenv
12311++ fresp <- getNotFoundResponse
12312++ let admin= getAdminName
12313++ sendFlush token . Error $ fresp (tuser== admin) $ Prelude.concat[ "<br/>"++ s | s <- lines msg]
12316++errorMessage t e u path env=
12317++ "\n---------------------ERROR-------------------------\
12318++ \\nTIME=" ++ t ++"\n\n" ++
12320++ "\n\nUSER= " ++ u ++
12321++ "\n\nPATH= " ++ path ++
12322++ "\n\nREQUEST:\n\n" ++
12325++line= unsafePerformIO $ newMVar ()
12330++ hSeek hlog SeekFromEnd 0
12331++ hPutStrLn hlog err
12335++logFileName= "errlog"
12339++-- | The handler of the error log
12340++hlog= unsafePerformIO $ openFile logFileName ReadWriteMode
12342++------ USER MANAGEMENT -------
12345++ uregister :: UserStr -> PasswdStr -> (IO (Maybe String)),
12346++ uvalidate :: UserStr -> PasswdStr -> (IO (Maybe String))}
12348++_authMethod= unsafePerformIO $ newIORef $ Auth tCacheRegister tCacheValidate
12350++-- | set an authentication method. That includes the registration and validation calls.
12351++-- both return Nothing if sucessful. Otherwise they return a text mesage explaining the failure
12352++setAuthMethod auth= writeIORef _authMethod auth
12354++getAuthMethod = readIORef _authMethod
12358++ { userName :: String
12359++ , upassword :: String
12360++ } deriving (Read, Show, Typeable)
12363++eUser= User (error1 "username") (error1 "password")
12365++error1 s= error $ s ++ " undefined"
12367++userPrefix= "user/"
12368++instance Indexable User where
12369++ key User{userName= user}= keyUserName user
12371++-- | Return the key name of an user
12372++keyUserName n= userPrefix++n
12374++instance Serializable User where
12375++ serialize= B.pack . show
12376++ deserialize= read . B.unpack
12377++ setPersist = \_ -> Just filePersist
12379++-- | Register an user/password
12380++tCacheRegister :: String -> String -> IO (Maybe String)
12381++tCacheRegister user password= tCacheRegister' 14 user password
12383++tCacheRegister' strength user password= do
12384++ salted_password <- makePassword (SB.pack password) strength
12386++ let newuser = User user (SB.unpack salted_password)
12387++ withSTMResources [newuser] $ doit newuser
12389++ doit newuser [Just (User _ _)] = resources{toReturn= Just "user already exist"}
12390++ doit newuser [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
12393++-- withSTMResources [newuser] doit
12395++-- newuser= User user password
12396++-- doit [Just (User _ _)] = resources{toReturn= Just "user already exist"}
12397++-- doit [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
12399++tCacheValidate :: UserStr -> PasswdStr -> IO (Maybe String)
12400++tCacheValidate u p =
12401++ let user= eUser{userName=u}
12403++ $ withSTMResources [user]
12404++ $ \ mu -> case mu of
12405++ [Nothing] -> resources{toReturn= err }
12406++ [Just u@(User _ pass )] -> resources{toReturn =
12407++ case verifyPassword (SB.pack p) (SB.pack pass)
12408++ || pass== p of -- for backward compatibility for unhashed passwords
12413++ err= Just "Username or password invalid"
12415++-- | register an user with the auth Method
12416++userRegister :: MonadIO m => UserStr -> PasswdStr -> m (Maybe String)
12417++userRegister !u !p= liftIO $ do
12418++ Auth reg _ <- getAuthMethod :: IO Auth
12422++newtype Config= Config1 (M.Map String String) deriving (Read,Show,Typeable)
12425+ data Config0 = Config{cadmin :: UserStr -- ^ Administrator name
12426+ ,cjqueryScript :: String -- ^ URL of jquery
12427+ ,cjqueryCSS :: String -- ^ URL of jqueryCSS
12428+ ,cjqueryUI :: String -- ^ URL of jqueryUI
12429+ ,cnicEditUrl :: String -- ^ URL of the nicEdit editor
12431+- deriving (Read, Show, Typeable)
12432++ deriving (Read, Show, Typeable)
12434+---defConfig0= Config "admin" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
12435+--- "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
12436+--- "//code.jquery.com/ui/1.10.3/jquery-ui.js"
12437+--- "//js.nicedit.com/nicEdit-latest.js"
12439+---writeDefConfig0= writeFile "sal" $ show defConfig0
12441+ change :: Config0 -> Config
12442+ change Config{..} = Config1 $ M.fromList
12443+@@ -558,370 +563,366 @@
12445+ readOld :: ByteString -> Config
12446+ readOld s= (change . read . B.unpack $ s)
12448+-keyConfig= "mflow.config"
12450++keyConfig= "mflow.config"
12451+ instance Indexable Config where key _= keyConfig
12453+-rconf :: DBRef Config
12454+-rconf= getDBRef keyConfig
12456+-instance Serializable Config where
12457+- serialize = B.pack . show
12458++rconf :: DBRef Config
12459++rconf= getDBRef keyConfig
12461++instance Serializable Config where
12462++ serialize (Config1 c)= B.pack $ "Config1 (fromList[\n" <> (concat . intersperse ",\n" $ map show (M.toList c)) <> "])"
12463+ deserialize s = unsafePerformIO $ (return $! read $! B.unpack s)
12464+- `CE.catch` \(e :: SomeException) -> return (readOld s)
12465+- setPersist = \_ -> Just filePersist
12466++ `CE.catch` \(e :: SomeException) -> return (readOld s)
12467++ setPersist = \_ -> Just filePersist
12469+ -- | read a config variable from the config file \"mflow.config\". if it is not set, uses the second parameter and
12470+ -- add it to the configuration list, so next time the administrator can change it in the configuration file
12471+-getConfig k v= case M.lookup k config of
12472++getConfig k v= case M.lookup k config of
12473+ Nothing -> unsafePerformIO $ setConfig k v >> return v
12476+ -- | set an user-defined config variable
12477+-setConfig k v= atomically $ do
12478+- Config1 conf <- readConfig
12479+- writeDBRef rconf $ Config1 $ M.insert k v conf
12480++setConfig k v= atomically $ do
12481++ Config1 conf <- readConfig
12482++ writeDBRef rconf $ Config1 $ M.insert k v conf
12487+-type UserStr= String
12488+-type PasswdStr= String
12490++type UserStr= String
12491++type PasswdStr= String
12494+ -- | set the Administrator user and password.
12495+ -- It must be defined in Main , before any configuration parameter is read, before the execution
12497+-setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m ()
12498+-setAdminUser user password= liftIO $ do
12500++setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m ()
12501++setAdminUser user password= liftIO $ do
12502+ userRegister user password
12503+ setConfig "cadmin" user
12504+--- atomically $ do
12505+--- Config1 conf <- readConfig
12506+--- writeDBRef rconf $ Config1 $ M.insert "cadmin" user conf
12510+-getAdminName= getConfig "cadmin" "admin"
12513+---------------- ERROR RESPONSES --------
12515+-defNotFoundResponse isAdmin msg= fresp $
12517+- True -> B.pack msg
12518+- _ -> "The administrator has been notified"
12521+- "<html><h4>Error 404: Page not found or error ocurred</h4> <p style=\"font-family:courier\">" <> msg <>"</p>" <>
12522+- "<br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a></html>"
12525+- paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows
12526+- opts= "options: " <> B.concat (Prelude.map (\s ->
12527+- "<a href=\"/"<> s <>"\">"<> s <>"</a>, ") $ filter (\s -> B.head s /= '_') paths)
12529+-notFoundResponse= unsafePerformIO $ newIORef defNotFoundResponse
12531+--- | set the 404 "not found" response.
12533+--- The parameter is as follows:
12534+--- (Bool Either if the user is Administrator or not
12535+--- -> String The error string
12536+--- -> HttpData) The response. See `defNotFoundResponse` code for an example
12538+-setNotFoundResponse ::
12544+-setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f
12545+-getNotFoundResponse= liftIO $ readIORef notFoundResponse
12547+---------------- BASIC BYTESTRING TAGS -------------------
12550+-type Attribs= [(String,String)]
12551+--- | Writes a XML tag in a ByteString. It is the most basic form of formatting. For
12552+--- more sophisticated formatting , use "MFlow.Forms.XHtml" or "MFlow.Forms.HSP".
12553+-btag :: String -> Attribs -> ByteString -> ByteString
12554+-btag t rs v= "<" <> pt <> attrs rs <> ">" <> v <> "</" <> pt <> ">"
12557+- attrs []= B.empty
12558+- attrs rs= B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs
12561+--- > bhtml ats v= btag "html" ats v
12562+-bhtml :: Attribs -> ByteString -> ByteString
12563+-bhtml ats v= btag "html" ats v
12567+--- > bbody ats v= btag "body" ats v
12568+-bbody :: Attribs -> ByteString -> ByteString
12569+-bbody ats v= btag "body" ats v
12571+-addAttrs :: ByteString -> Attribs -> ByteString
12572+-addAttrs (Chunk "<" (Chunk tag rest)) rs=
12573+- Chunk "<"(Chunk tag (B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest
12575+-addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other
12578+-------------------- FILE SERVER -----------
12580+--- | Set the path of the files in the web server. The links to the files are relative to it.
12581+--- The files are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of
12582+--- the efficient GHC threads by frequent IO calls.So it enhances the performance
12583+--- in the context of heavy concurrence.
12584+--- It uses 'Data.TCache.Memoization'.
12585+--- The caching-uncaching follows the `setPersist` criteria
12586+-setFilesPath :: MonadIO m => String -> m ()
12587+-setFilesPath path= liftIO $ writeIORef rfilesPath path
12589+-rfilesPath= unsafePerformIO $ newIORef "files/"
12591+-serveFile path'= do
12592+- when(let hpath= Prelude.head path' in hpath == '/' || hpath =='\\') $ error noperm
12593+- when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm
12594+- filesPath <- readIORef rfilesPath
12595+- let path= filesPath ++ path'
12596+- mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing)
12598+- Nothing -> error "not found" -- return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible"
12600+- let ext = reverse . takeWhile (/='.') $ reverse path
12601+- mmime= lookup (map toLower ext) mimeTable
12602+- mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream"
12604+- in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r
12606+- noperm= "no permissions"
12607+- ioerr x= \(e :: CE.IOException) -> x
12608+- setMime x= ("Content-Type",x)
12610+---------------------- FLOW ID GENERATOR ------------
12612+-data NFlow= NFlow !Integer deriving (Read, Show, Typeable)
12616+-instance Indexable NFlow where
12619+-instance Serializable NFlow where
12620+- serialize= B.pack . show
12621+- deserialize= read . B.unpack
12622+- setPersist = \_ -> Just filePersist
12624+-rflow= getDBRef . key $ NFlow undefined
12627+- TOD t _ <- getClockTime
12629+- NFlow n <- readDBRef rflow `onNothing` return (NFlow 0)
12630+- writeDBRef rflow . NFlow $ n+1
12631+- return . SB.pack . show $ t + n
12635+- ("html", "text/html"),
12636+- ("htm", "text/html"),
12637+- ("txt", "text/plain"),
12638+- ("hs", "text/plain"),
12639+- ("lhs", "text/plain"),
12640+- ("jpeg", "image/jpeg"),
12641+- ("pdf", "application/pdf"),
12642+- ("js", "application/x-javascript"),
12643+- ("gif", "image/gif"),
12644+- ("bmp", "image/bmp"),
12645+- ("ico", "image/x-icon"),
12646+- ("doc", "application/msword"),
12647+- ("jpg", "image/jpeg"),
12648+- ("eps", "application/postscript"),
12649+- ("zip", "application/zip"),
12650+- ("exe", "application/octet-stream"),
12651+- ("tif", "image/tiff"),
12652+- ("tiff", "image/tiff"),
12653+- ("mov", "video/quicktime"),
12654+- ("movie", "video/x-sgi-movie"),
12655+- ("mp2", "video/mpeg"),
12656+- ("mp3", "audio/mpeg"),
12657+- ("mpa", "video/mpeg"),
12658+- ("mpe", "video/mpeg"),
12659+- ("mpeg", "video/mpeg"),
12660+- ("mpg", "video/mpeg"),
12661+- ("mpp", "application/vnd.ms-project"),
12662+- ("323", "text/h323"),
12663+- ("*", "application/octet-stream"),
12664+- ("acx", "application/internet-property-stream"),
12665+- ("ai", "application/postscript"),
12666+- ("aif", "audio/x-aiff"),
12667+- ("aifc", "audio/x-aiff"),
12668+- ("aiff", "audio/x-aiff"),
12669+- ("asf", "video/x-ms-asf"),
12670+- ("asr", "video/x-ms-asf"),
12671+- ("asx", "video/x-ms-asf"),
12672+- ("au", "audio/basic"),
12673+- ("avi", "video/x-msvideo"),
12674+- ("axs", "application/olescript"),
12675+- ("bas", "text/plain"),
12676+- ("bcpio", "application/x-bcpio"),
12677+- ("bin", "application/octet-stream"),
12678+- ("c", "text/plain"),
12679+- ("cat", "application/vnd.ms-pkiseccat"),
12680+- ("cdf", "application/x-cdf"),
12681+- ("cdf", "application/x-netcdf"),
12682+- ("cer", "application/x-x509-ca-cert"),
12683+- ("class", "application/octet-stream"),
12684+- ("clp", "application/x-msclip"),
12685+- ("cmx", "image/x-cmx"),
12686+- ("cod", "image/cis-cod"),
12687+- ("cpio", "application/x-cpio"),
12688+- ("crd", "application/x-mscardfile"),
12689+- ("crl", "application/pkix-crl"),
12690+- ("crt", "application/x-x509-ca-cert"),
12691+- ("csh", "application/x-csh"),
12692+- ("css", "text/css"),
12693+- ("dcr", "application/x-director"),
12694+- ("der", "application/x-x509-ca-cert"),
12695+- ("dir", "application/x-director"),
12696+- ("dll", "application/x-msdownload"),
12697+- ("dms", "application/octet-stream"),
12698+- ("dot", "application/msword"),
12699+- ("dvi", "application/x-dvi"),
12700+- ("dxr", "application/x-director"),
12701+- ("eps", "application/postscript"),
12702+- ("etx", "text/x-setext"),
12703+- ("evy", "application/envoy"),
12704+- ("fif", "application/fractals"),
12705+- ("flr", "x-world/x-vrml"),
12706+- ("gtar", "application/x-gtar"),
12707+- ("gz", "application/x-gzip"),
12708+- ("h", "text/plain"),
12709+- ("hdf", "application/x-hdf"),
12710+- ("hlp", "application/winhlp"),
12711+- ("hqx", "application/mac-binhex40"),
12712+- ("hta", "application/hta"),
12713+- ("htc", "text/x-component"),
12714+- ("htt", "text/webviewhtml"),
12715+- ("ief", "image/ief"),
12716+- ("iii", "application/x-iphone"),
12717+- ("ins", "application/x-internet-signup"),
12718+- ("isp", "application/x-internet-signup"),
12719+- ("jfif", "image/pipeg"),
12720+- ("jpe", "image/jpeg"),
12721+- ("latex", "application/x-latex"),
12722+- ("lha", "application/octet-stream"),
12723+- ("lsf", "video/x-la-asf"),
12724+- ("lsx", "video/x-la-asf"),
12725+- ("lzh", "application/octet-stream"),
12726+- ("m13", "application/x-msmediaview"),
12727+- ("m14", "application/x-msmediaview"),
12728+- ("m3u", "audio/x-mpegurl"),
12729+- ("man", "application/x-troff-man"),
12730+- ("mdb", "application/x-msaccess"),
12731+- ("me", "application/x-troff-me"),
12732+- ("mht", "message/rfc822"),
12733+- ("mhtml", "message/rfc822"),
12734+- ("mid", "audio/mid"),
12735+- ("mny", "application/x-msmoney"),
12736+- ("mpv2", "video/mpeg"),
12737+- ("ms", "application/x-troff-ms"),
12738+- ("msg", "application/vnd.ms-outlook"),
12739+- ("mvb", "application/x-msmediaview"),
12740+- ("nc", "application/x-netcdf"),
12741+- ("nws", "message/rfc822"),
12742+- ("oda", "application/oda"),
12743+- ("p10", "application/pkcs10"),
12744+- ("p12", "application/x-pkcs12"),
12745+- ("p7b", "application/x-pkcs7-certificates"),
12746+- ("p7c", "application/x-pkcs7-mime"),
12747+- ("p7m", "application/x-pkcs7-mime"),
12748+- ("p7r", "application/x-pkcs7-certreqresp"),
12749+- ("p7s", "application/x-pkcs7-signature"),
12750+- ("png", "image/png"),
12751+- ("pbm", "image/x-portable-bitmap"),
12752+- ("pfx", "application/x-pkcs12"),
12753+- ("pgm", "image/x-portable-graymap"),
12754+- ("pko", "application/ynd.ms-pkipko"),
12755+- ("pma", "application/x-perfmon"),
12756+- ("pmc", "application/x-perfmon"),
12757+- ("pml", "application/x-perfmon"),
12758+- ("pmr", "application/x-perfmon"),
12759+- ("pmw", "application/x-perfmon"),
12760+- ("pnm", "image/x-portable-anymap"),
12761+- ("pot", "application/vnd.ms-powerpoint"),
12762+- ("ppm", "image/x-portable-pixmap"),
12763+- ("pps", "application/vnd.ms-powerpoint"),
12764+- ("ppt", "application/vnd.ms-powerpoint"),
12765+- ("prf", "application/pics-rules"),
12766+- ("ps", "application/postscript"),
12767+- ("pub", "application/x-mspublisher"),
12768+- ("qt", "video/quicktime"),
12769+- ("ra", "audio/x-pn-realaudio"),
12770+- ("ram", "audio/x-pn-realaudio"),
12771+- ("ras", "image/x-cmu-raster"),
12772+- ("rgb", "image/x-rgb"),
12773+- ("rmi", "audio/mid"),
12774+- ("roff", "application/x-troff"),
12775+- ("rtf", "application/rtf"),
12776+- ("rtx", "text/richtext"),
12777+- ("scd", "application/x-msschedule"),
12778+- ("sct", "text/scriptlet"),
12779+- ("setpay", "application/set-payment-initiation"),
12780+- ("setreg", "application/set-registration-initiation"),
12781+- ("sh", "application/x-sh"),
12782+- ("shar", "application/x-shar"),
12783+- ("sit", "application/x-stuffit"),
12784+- ("snd", "audio/basic"),
12785+- ("spc", "application/x-pkcs7-certificates"),
12786+- ("spl", "application/futuresplash"),
12787+- ("src", "application/x-wais-source"),
12788+- ("sst", "application/vnd.ms-pkicertstore"),
12789+- ("stl", "application/vnd.ms-pkistl"),
12790+- ("stm", "text/html"),
12791+- ("sv4cpio", "application/x-sv4cpio"),
12792+- ("sv4crc", "application/x-sv4crc"),
12793+- ("svg", "image/svg+xml"),
12794+- ("swf", "application/x-shockwave-flash"),
12795+- ("t", "application/x-troff"),
12796+- ("tar", "application/x-tar"),
12797+- ("tcl", "application/x-tcl"),
12798+- ("tex", "application/x-tex"),
12799+- ("texi", "application/x-texinfo"),
12800+- ("texinfo", "application/x-texinfo"),
12801+- ("tgz", "application/x-compressed"),
12802+- ("tr", "application/x-troff"),
12803+- ("trm", "application/x-msterminal"),
12804+- ("tsv", "text/tab-separated-values"),
12805+- ("uls", "text/iuls"),
12806+- ("ustar", "application/x-ustar"),
12807+- ("vcf", "text/x-vcard"),
12808+- ("vrml", "x-world/x-vrml"),
12809+- ("wav", "audio/x-wav"),
12810+- ("wcm", "application/vnd.ms-works"),
12811+- ("wdb", "application/vnd.ms-works"),
12812+- ("wks", "application/vnd.ms-works"),
12813+- ("wmf", "application/x-msmetafile"),
12814+- ("wps", "application/vnd.ms-works"),
12815+- ("wri", "application/x-mswrite"),
12816+- ("wrl", "x-world/x-vrml"),
12817+- ("wrz", "x-world/x-vrml"),
12818+- ("xaf", "x-world/x-vrml"),
12819+- ("xbm", "image/x-xbitmap"),
12820+- ("xla", "application/vnd.ms-excel"),
12821+- ("xlc", "application/vnd.ms-excel"),
12822+- ("xlm", "application/vnd.ms-excel"),
12823+- ("xls", "application/vnd.ms-excel"),
12824+- ("xlt", "application/vnd.ms-excel"),
12825+- ("xlw", "application/vnd.ms-excel"),
12826+- ("xof", "x-world/x-vrml"),
12827+- ("xpm", "image/x-xpixmap"),
12828+- ("xwd", "image/x-xwindowdump"),
12829+- ("z", "application/x-compress")
12835++getAdminName= getConfig "cadmin" "admin"
12838++--------------- ERROR RESPONSES --------
12840++defNotFoundResponse isAdmin msg= fresp $
12842++ True -> B.pack msg
12843++ _ -> "The administrator has been notified"
12846++ "<html><h4>Error 404: Page not found or error ocurred</h4> <p style=\"font-family:courier\">" <> msg <>"</p>" <>
12847++ "<br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a></html>"
12850++ paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows
12851++ opts= "options: " <> B.concat (Prelude.map (\s ->
12852++ "<a href=\"/"<> s <>"\">"<> s <>"</a>, ") $ filter (\s -> B.head s /= '_') paths)
12854++notFoundResponse= unsafePerformIO $ newIORef defNotFoundResponse
12856++-- | set the 404 "not found" response.
12858++-- The parameter is as follows:
12859++-- (Bool Either if the user is Administrator or not
12860++-- -> String The error string
12861++-- -> HttpData) The response. See `defNotFoundResponse` code for an example
12863++setNotFoundResponse ::
12869++setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f
12870++getNotFoundResponse= liftIO $ readIORef notFoundResponse
12872++--------------- BASIC BYTESTRING TAGS -------------------
12875++type Attribs= [(String,String)]
12876++-- | Writes a XML tag in a ByteString. It is the most basic form of formatting. For
12877++-- more sophisticated formatting , use "MFlow.Forms.XHtml" or "MFlow.Forms.HSP".
12878++btag :: String -> Attribs -> ByteString -> ByteString
12879++btag t rs v= "<" <> pt <> attrs rs <> ">" <> v <> "</" <> pt <> ">"
12882++ attrs []= B.empty
12883++ attrs rs= B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs
12886++-- > bhtml ats v= btag "html" ats v
12887++bhtml :: Attribs -> ByteString -> ByteString
12888++bhtml ats v= btag "html" ats v
12892++-- > bbody ats v= btag "body" ats v
12893++bbody :: Attribs -> ByteString -> ByteString
12894++bbody ats v= btag "body" ats v
12896++addAttrs :: ByteString -> Attribs -> ByteString
12897++addAttrs (Chunk "<" (Chunk tag rest)) rs=
12898++ Chunk "<"(Chunk tag (B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest
12900++addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other
12903++------------------- FILE SERVER -----------
12905++-- | Set the path of the files in the web server. The links to the files are relative to it.
12906++-- The files are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of
12907++-- the efficient GHC threads by frequent IO calls.So it enhances the performance
12908++-- in the context of heavy concurrence.
12909++-- It uses 'Data.TCache.Memoization'.
12910++-- The caching-uncaching follows the `setPersist` criteria
12911++setFilesPath :: MonadIO m => String -> m ()
12912++setFilesPath !path= liftIO $ writeIORef rfilesPath path
12914++rfilesPath= unsafePerformIO $ newIORef "files/"
12916++serveFile path'= do
12917++ when(let hpath= Prelude.head path' in hpath == '/' || hpath =='\\') $ error noperm
12918++ when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm
12919++ filesPath <- readIORef rfilesPath
12920++ let path= filesPath ++ path'
12921++ mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing)
12923++ Nothing -> error "not found" -- return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible"
12925++ let ext = reverse . takeWhile (/='.') $ reverse path
12926++ mmime= lookup (map toLower ext) mimeTable
12927++ mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream"
12929++ in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r
12931++ noperm= "no permissions"
12932++ ioerr x= \(e :: CE.IOException) -> x
12933++ setMime x= ("Content-Type",x)
12935++--------------------- FLOW ID GENERATOR ------------
12937++data NFlow= NFlow !Integer deriving (Read, Show, Typeable)
12941++instance Indexable NFlow where
12944++instance Serializable NFlow where
12945++ serialize= B.pack . show
12946++ deserialize= read . B.unpack
12947++ setPersist = \_ -> Just filePersist
12949++rflow= getDBRef . key $ NFlow undefined
12952++ TOD t _ <- getClockTime
12954++ NFlow n <- readDBRef rflow `onNothing` return (NFlow 0)
12955++ writeDBRef rflow . NFlow $ n+1
12956++ return . SB.pack . show $ t + n
12960++ ("html", "text/html"),
12961++ ("htm", "text/html"),
12962++ ("txt", "text/plain"),
12963++ ("hs", "text/plain"),
12964++ ("lhs", "text/plain"),
12965++ ("jpeg", "image/jpeg"),
12966++ ("pdf", "application/pdf"),
12967++ ("js", "application/x-javascript"),
12968++ ("gif", "image/gif"),
12969++ ("bmp", "image/bmp"),
12970++ ("ico", "image/x-icon"),
12971++ ("doc", "application/msword"),
12972++ ("jpg", "image/jpeg"),
12973++ ("eps", "application/postscript"),
12974++ ("zip", "application/zip"),
12975++ ("exe", "application/octet-stream"),
12976++ ("tif", "image/tiff"),
12977++ ("tiff", "image/tiff"),
12978++ ("mov", "video/quicktime"),
12979++ ("movie", "video/x-sgi-movie"),
12980++ ("mp2", "video/mpeg"),
12981++ ("mp3", "audio/mpeg"),
12982++ ("mpa", "video/mpeg"),
12983++ ("mpe", "video/mpeg"),
12984++ ("mpeg", "video/mpeg"),
12985++ ("mpg", "video/mpeg"),
12986++ ("mpp", "application/vnd.ms-project"),
12987++ ("323", "text/h323"),
12988++ ("*", "application/octet-stream"),
12989++ ("acx", "application/internet-property-stream"),
12990++ ("ai", "application/postscript"),
12991++ ("aif", "audio/x-aiff"),
12992++ ("aifc", "audio/x-aiff"),
12993++ ("aiff", "audio/x-aiff"),
12994++ ("asf", "video/x-ms-asf"),
12995++ ("asr", "video/x-ms-asf"),
12996++ ("asx", "video/x-ms-asf"),
12997++ ("au", "audio/basic"),
12998++ ("avi", "video/x-msvideo"),
12999++ ("axs", "application/olescript"),
13000++ ("bas", "text/plain"),
13001++ ("bcpio", "application/x-bcpio"),
13002++ ("bin", "application/octet-stream"),
13003++ ("c", "text/plain"),
13004++ ("cat", "application/vnd.ms-pkiseccat"),
13005++ ("cdf", "application/x-cdf"),
13006++ ("cdf", "application/x-netcdf"),
13007++ ("cer", "application/x-x509-ca-cert"),
13008++ ("class", "application/octet-stream"),
13009++ ("clp", "application/x-msclip"),
13010++ ("cmx", "image/x-cmx"),
13011++ ("cod", "image/cis-cod"),
13012++ ("cpio", "application/x-cpio"),
13013++ ("crd", "application/x-mscardfile"),
13014++ ("crl", "application/pkix-crl"),
13015++ ("crt", "application/x-x509-ca-cert"),
13016++ ("csh", "application/x-csh"),
13017++ ("css", "text/css"),
13018++ ("dcr", "application/x-director"),
13019++ ("der", "application/x-x509-ca-cert"),
13020++ ("dir", "application/x-director"),
13021++ ("dll", "application/x-msdownload"),
13022++ ("dms", "application/octet-stream"),
13023++ ("dot", "application/msword"),
13024++ ("dvi", "application/x-dvi"),
13025++ ("dxr", "application/x-director"),
13026++ ("eps", "application/postscript"),
13027++ ("etx", "text/x-setext"),
13028++ ("evy", "application/envoy"),
13029++ ("fif", "application/fractals"),
13030++ ("flr", "x-world/x-vrml"),
13031++ ("gtar", "application/x-gtar"),
13032++ ("gz", "application/x-gzip"),
13033++ ("h", "text/plain"),
13034++ ("hdf", "application/x-hdf"),
13035++ ("hlp", "application/winhlp"),
13036++ ("hqx", "application/mac-binhex40"),
13037++ ("hta", "application/hta"),
13038++ ("htc", "text/x-component"),
13039++ ("htt", "text/webviewhtml"),
13040++ ("ief", "image/ief"),
13041++ ("iii", "application/x-iphone"),
13042++ ("ins", "application/x-internet-signup"),
13043++ ("isp", "application/x-internet-signup"),
13044++ ("jfif", "image/pipeg"),
13045++ ("jpe", "image/jpeg"),
13046++ ("latex", "application/x-latex"),
13047++ ("lha", "application/octet-stream"),
13048++ ("lsf", "video/x-la-asf"),
13049++ ("lsx", "video/x-la-asf"),
13050++ ("lzh", "application/octet-stream"),
13051++ ("m13", "application/x-msmediaview"),
13052++ ("m14", "application/x-msmediaview"),
13053++ ("m3u", "audio/x-mpegurl"),
13054++ ("man", "application/x-troff-man"),
13055++ ("mdb", "application/x-msaccess"),
13056++ ("me", "application/x-troff-me"),
13057++ ("mht", "message/rfc822"),
13058++ ("mhtml", "message/rfc822"),
13059++ ("mid", "audio/mid"),
13060++ ("mny", "application/x-msmoney"),
13061++ ("mpv2", "video/mpeg"),
13062++ ("ms", "application/x-troff-ms"),
13063++ ("msg", "application/vnd.ms-outlook"),
13064++ ("mvb", "application/x-msmediaview"),
13065++ ("nc", "application/x-netcdf"),
13066++ ("nws", "message/rfc822"),
13067++ ("oda", "application/oda"),
13068++ ("p10", "application/pkcs10"),
13069++ ("p12", "application/x-pkcs12"),
13070++ ("p7b", "application/x-pkcs7-certificates"),
13071++ ("p7c", "application/x-pkcs7-mime"),
13072++ ("p7m", "application/x-pkcs7-mime"),
13073++ ("p7r", "application/x-pkcs7-certreqresp"),
13074++ ("p7s", "application/x-pkcs7-signature"),
13075++ ("png", "image/png"),
13076++ ("pbm", "image/x-portable-bitmap"),
13077++ ("pfx", "application/x-pkcs12"),
13078++ ("pgm", "image/x-portable-graymap"),
13079++ ("pko", "application/ynd.ms-pkipko"),
13080++ ("pma", "application/x-perfmon"),
13081++ ("pmc", "application/x-perfmon"),
13082++ ("pml", "application/x-perfmon"),
13083++ ("pmr", "application/x-perfmon"),
13084++ ("pmw", "application/x-perfmon"),
13085++ ("pnm", "image/x-portable-anymap"),
13086++ ("pot", "application/vnd.ms-powerpoint"),
13087++ ("ppm", "image/x-portable-pixmap"),
13088++ ("pps", "application/vnd.ms-powerpoint"),
13089++ ("ppt", "application/vnd.ms-powerpoint"),
13090++ ("prf", "application/pics-rules"),
13091++ ("ps", "application/postscript"),
13092++ ("pub", "application/x-mspublisher"),
13093++ ("qt", "video/quicktime"),
13094++ ("ra", "audio/x-pn-realaudio"),
13095++ ("ram", "audio/x-pn-realaudio"),
13096++ ("ras", "image/x-cmu-raster"),
13097++ ("rgb", "image/x-rgb"),
13098++ ("rmi", "audio/mid"),
13099++ ("roff", "application/x-troff"),
13100++ ("rtf", "application/rtf"),
13101++ ("rtx", "text/richtext"),
13102++ ("scd", "application/x-msschedule"),
13103++ ("sct", "text/scriptlet"),
13104++ ("setpay", "application/set-payment-initiation"),
13105++ ("setreg", "application/set-registration-initiation"),
13106++ ("sh", "application/x-sh"),
13107++ ("shar", "application/x-shar"),
13108++ ("sit", "application/x-stuffit"),
13109++ ("snd", "audio/basic"),
13110++ ("spc", "application/x-pkcs7-certificates"),
13111++ ("spl", "application/futuresplash"),
13112++ ("src", "application/x-wais-source"),
13113++ ("sst", "application/vnd.ms-pkicertstore"),
13114++ ("stl", "application/vnd.ms-pkistl"),
13115++ ("stm", "text/html"),
13116++ ("sv4cpio", "application/x-sv4cpio"),
13117++ ("sv4crc", "application/x-sv4crc"),
13118++ ("svg", "image/svg+xml"),
13119++ ("swf", "application/x-shockwave-flash"),
13120++ ("t", "application/x-troff"),
13121++ ("tar", "application/x-tar"),
13122++ ("tcl", "application/x-tcl"),
13123++ ("tex", "application/x-tex"),
13124++ ("texi", "application/x-texinfo"),
13125++ ("texinfo", "application/x-texinfo"),
13126++ ("tgz", "application/x-compressed"),
13127++ ("tr", "application/x-troff"),
13128++ ("trm", "application/x-msterminal"),
13129++ ("tsv", "text/tab-separated-values"),
13130++ ("uls", "text/iuls"),
13131++ ("ustar", "application/x-ustar"),
13132++ ("vcf", "text/x-vcard"),
13133++ ("vrml", "x-world/x-vrml"),
13134++ ("wav", "audio/x-wav"),
13135++ ("wcm", "application/vnd.ms-works"),
13136++ ("wdb", "application/vnd.ms-works"),
13137++ ("wks", "application/vnd.ms-works"),
13138++ ("wmf", "application/x-msmetafile"),
13139++ ("wps", "application/vnd.ms-works"),
13140++ ("wri", "application/x-mswrite"),
13141++ ("wrl", "x-world/x-vrml"),
13142++ ("wrz", "x-world/x-vrml"),
13143++ ("xaf", "x-world/x-vrml"),
13144++ ("xbm", "image/x-xbitmap"),
13145++ ("xla", "application/vnd.ms-excel"),
13146++ ("xlc", "application/vnd.ms-excel"),
13147++ ("xlm", "application/vnd.ms-excel"),
13148++ ("xls", "application/vnd.ms-excel"),
13149++ ("xlt", "application/vnd.ms-excel"),
13150++ ("xlw", "application/vnd.ms-excel"),
13151++ ("xof", "x-world/x-vrml"),
13152++ ("xpm", "image/x-xpixmap"),
13153++ ("xwd", "image/x-xwindowdump"),
13154++ ("z", "application/x-compress")