1diff -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
32diff -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
46diff -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)
154+import Control.Monad.Identity
155+import Data.ByteString.Char8 as B
156+import Web.ClientSession
157+import System.Environment
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)
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,
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
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
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,
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
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
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
425diff -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 ((<|>))
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 ((<|>))
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 "
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 "
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")
772diff -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
784diff -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
805- -XUndecidableInstances
806- -XMultiParamTypeClasses
807- -XGeneralizedNewtypeDeriving
809- -XOverlappingInstances
813-module MFlow.Forms.Internals where
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
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
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
853+ -XUndecidableInstances
854+ -XMultiParamTypeClasses
855+ -XGeneralizedNewtypeDeriving
857+ -XOverlappingInstances
861+module MFlow.Forms.Internals where
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
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
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
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
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))
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
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
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)
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 $
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)
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)
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 $
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)
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 @@
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 @@
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{
1938- needForm :: NeedForm,
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),
1950- notSyncInAction :: Bool,
1953+--needForm1 st= case needForm st of
1955+-- HasElems _ -> True
1960+data NeedForm= HasForm | HasElems | NoElems deriving Show
1962+data MFlowState view= MFlowState{
1969+ needForm :: NeedForm,
1970+ mfFileUpload :: Bool,
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),
1983+ notSyncInAction :: Bool,
1987- mfPagePath :: [String],
1988- mfPrefix :: String,
1990- mfPageFlow :: Bool,
1991+ mfPagePath :: [String],
1992+ mfPrefix :: String,
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
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
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
2178- modify $ \st -> st{mfCookies= (UnEncryptedCookie
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
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
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
2268+ modify $ \st -> st{mfCookies= (UnEncryptedCookie
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
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
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
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
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
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
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
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
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 ()
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 ()
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
2959--- -> FlowM view (Workflow m) (WFRef (FailBack a),a)
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'
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'
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
3051+-- -> FlowM view (Workflow m) (WFRef (FailBack a),a)
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'
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'
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
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
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
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
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() {\
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
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
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
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
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
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)
3686diff -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)
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
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)
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
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
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
3943--- liftIO $ runStateT (runView mf) s
3944--- bool <- liftIO generate
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
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
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)
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
4007--- | a pure version of verifyM
4008-verify :: a -> (Bool, String) -> a
4009-verify f (prop, msg)= do
4017--- marches <- readIORef matches
4018--- return $ head map (m s) matches
4020--- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of
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
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
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)}
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
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
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
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
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
4238+-- liftIO $ runStateT (runView mf) s
4239+-- bool <- liftIO generate
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
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
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)
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
4302+-- | a pure version of verifyM
4303+verify :: a -> (Bool, String) -> a
4304+verify f (prop, msg)= do
4312+-- marches <- readIORef matches
4313+-- return $ head map (m s) matches
4315+-- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of
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
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
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)}
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
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
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
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
4497diff -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,
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,
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
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
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]
4811+ let (_,ws)= unzip r
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))
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))
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.
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.
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
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
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]
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
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
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]
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]
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]
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"
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
5902- FormElm render mx <- runView w
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
5920+ FormElm render mx <- runView w
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 ())
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
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 ++";\
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}
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)
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 ++";\
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}
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)
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"
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);\
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:
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
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++");"
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\" );\
6628- ,JScriptFile jqueryScript []
6629- ,JScriptFile jqueryUI [setit]]
6631- getTextBox mv <! [("id",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:
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
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++");"
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\" );\
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
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')
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);}\
6922diff -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
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
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") []
7058diff -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
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"
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
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"
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
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
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
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
7770--- | Display a password box
7771-getPassword :: (FormInput view,
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}
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}
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}
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}
7858- strs= map snd $ filter ((==) n . fst) env
7859- mn= if null strs then Nothing else Just $ head strs
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
7882- let form= finput n "hidden" "" False Nothing
7883- mr <- getParam1 n env
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
7919- let nvalue x = case x of
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
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
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
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
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
8266+-- | Display a password box
8267+getPassword :: (FormInput view,
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 }
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}
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}
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}
8354+ strs= map snd $ filter ((==) n . fst) env
8355+ mn= if null strs then Nothing else Just $ head strs
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
8378+ let form= finput n "hidden" "" False Nothing
8379+ mr <- getParam1 n env
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
8415+ let nvalue x = case x of
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
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
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
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
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) =>
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 ()
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
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) =>
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 ()
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
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
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
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
9103- mv1= lookup "ajax" env
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
9117+ mv1= lookup "ajax" env
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"
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)
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
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
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 ()
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)
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
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
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)
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)
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)
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)
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)
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@
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 ] []
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))
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
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))
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
10194diff -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
10215 import System.IO.Unsafe
10216 import Data.Map as M
10222-class ToResponse a where
10223- toResponse :: a -> Response
10225+class ToResponse a where
10226+ toResponse :: a -> Response
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")[]
10277diff -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
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
10301diff -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>
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
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
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
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
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
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 ""= ("","","")
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 ""= ("","","")
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
10647diff -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
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)
10693-import Network.Wai.Handler.Warp hiding (getPort) --(run,defaultSettings,Settings ,setPort)
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'
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)
10789+import Network.Wai.Handler.Warp --(run,defaultSettings,Settings ,setPort)
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)]
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)]
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
10846diff -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
10855-import MFlow.Cookies
10857-import Data.ByteString.Lazy.UTF8
10859-import Data.Typeable
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
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
10917+import MFlow.Cookies
10919+import Data.ByteString.Lazy.UTF8
10921+import Data.Typeable
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
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 "
10974diff -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
10978-{-# LANGUAGE UndecidableInstances
10980- , TypeSynonymInstances
10981- , MultiParamTypeClasses
10982- , DeriveDataTypeable
10983- , FlexibleInstances
10984- , OverloadedStrings #-}
10987- module MFlow.Cookies
10992-import Data.Typeable
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
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
11035-import Data.TCache.DefaultPersistence
11036-import Control.Workflow hiding (Indexable(..))
11039-import MFlow.Cookies
11041-import MFlow.Wai.Response
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
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 ""= ("","","")
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
11195+import Data.TCache.DefaultPersistence
11196+import Control.Workflow hiding (Indexable(..))
11199+import MFlow.Cookies
11201+import MFlow.Wai.Response
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
11212+import System.Directory
11214+import qualified Data.Text as T
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
11370diff -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
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
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
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
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)
11538-import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId)
11539-import Data.Char(toLower)
11541-import Unsafe.Coerce
11542-import System.IO.Unsafe
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
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)
11631+import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId)
11632+import Data.Char(toLower)
11634+import Unsafe.Coerce
11635+import System.IO.Unsafe
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
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)
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
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
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
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
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
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 <> ">"
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 <> ">"
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")
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list