@@ -1,13157 +0,0 @@
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")