@@ -1,13157 +0,0 @@
1−diff -ru orig/MFlow.cabal new/MFlow.cabal
2−--- orig/MFlow.cabal 2014-06-10 05:51:27.009015855 +0300
3−+++ new/MFlow.cabal 2014-06-10 05:51:25.000000000 +0300
4−@@ -105,10 +105,10 @@
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
17−@@ -128,7 +128,7 @@
18− -- hamlet , shakespeare, monadloc , aws , network , hscolour ,
19− -- persistent-template , persistent-sqlite , persistent ,
20− -- conduit , http-conduit , monad-logger , safecopy ,
21−--- time
22−+-- time, acid-state
23− -- main-is: demos-blaze.hs
24− -- buildable: True
25− -- hs-source-dirs: Demos
26−@@ -142,4 +142,4 @@
27− -- InitialConfig GenerateForm GenerateFormUndo GenerateFormUndoMsg WebService
28− -- LazyLoad
29− -- ghc-options: -iDemos -threaded -rtsopts
30−---
31−+
32−diff -ru orig/Setup.lhs new/Setup.lhs
33−--- orig/Setup.lhs 2014-06-10 05:51:26.953015857 +0300
34−+++ new/Setup.lhs 2014-06-10 05:51:25.000000000 +0300
35−@@ -1,5 +1,5 @@
36−-#! /usr/bin/runghc
37−-
38−-> import Distribution.Simple
39−->
40−-> main = defaultMain
41−+#! /usr/bin/runghc
42−+
43−+> import Distribution.Simple
44−+>
45−+> main = defaultMain
46−diff -ru orig/src/MFlow/Cookies.hs new/src/MFlow/Cookies.hs
47−--- orig/src/MFlow/Cookies.hs 2014-06-10 05:51:26.961015857 +0300
48−+++ new/src/MFlow/Cookies.hs 2014-06-10 05:51:25.000000000 +0300
49−@@ -1,188 +1,188 @@
50−-{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-}
51−-
52−-module MFlow.Cookies (
53−- CookieT,
54−- Cookie(..),
55−- contentHtml,
56−- cookieuser,
57−- cookieHeaders,
58−- getCookies,
59−- paranoidEncryptCookie,
60−- paranoidDecryptCookie,
61−- encryptCookie,
62−- decryptCookie
63−- )
64−-where
65−-import Control.Monad(MonadPlus(..), guard, replicateM_, when)
66−-import Data.Char
67−-import Data.Maybe(fromMaybe, fromJust)
68−-import System.IO.Unsafe
69−-import Control.Exception(handle)
70−-import Data.Typeable
71−-import Unsafe.Coerce
72−-import Data.Monoid
73−-import Text.Parsec
74−-import Control.Monad.Identity
75−-import Data.ByteString.Char8 as B
76−-import Web.ClientSession
77−-import System.Environment
78−-
79−---import Debug.Trace
80−---(!>)= flip trace
81−-
82−-contentHtml :: (ByteString, ByteString)
83−-contentHtml= ("Content-Type", "text/html; charset=UTF-8")
84−-
85−-type CookieT = (B.ByteString,B.ByteString,B.ByteString,Maybe B.ByteString)
86−-
87−-data Cookie
88−- = UnEncryptedCookie CookieT
89−- | EncryptedCookie CookieT
90−- | ParanoidCookie CookieT
91−- deriving (Eq, Read, Show)
92−-
93−-cookieuser :: String
94−-cookieuser= "cookieuser"
95−-
96−-getCookies httpreq=
97−- case lookup "Cookie" $ httpreq of
98−- Just str -> splitCookies str :: [(B.ByteString, B.ByteString)]
99−- Nothing -> []
100−-
101−-cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs
102−-
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
107−-
108−-showCookie' (n,v,p,me) = n <> "=" <> v <>
109−- ";path=" <> p <>
110−- showMaxAge me
111−-
112−-showMaxAge Nothing = ""
113−-showMaxAge (Just e) = ";Max-age=" <> e
114−-
115−-splitCookies cookies = f cookies []
116−- where
117−- f s r | B.null s = r
118−- f xs0 r =
119−- let
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)
129−-
130−+{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-}
131−+
132−+module MFlow.Cookies (
133−+ CookieT,
134−+ Cookie(..),
135−+ contentHtml,
136−+ cookieuser,
137−+ cookieHeaders,
138−+ getCookies,
139−+ paranoidEncryptCookie,
140−+ paranoidDecryptCookie,
141−+ encryptCookie,
142−+ decryptCookie
143−+ )
144−+where
145−+import Control.Monad(MonadPlus(..), guard, replicateM_, when)
146−+import Data.Char
147−+import Data.Maybe(fromMaybe, fromJust)
148−+import System.IO.Unsafe
149−+import Control.Exception(handle)
150−+import Data.Typeable
151−+import Unsafe.Coerce
152−+import Data.Monoid
153−+import Text.Parsec
154−+import Control.Monad.Identity
155−+import Data.ByteString.Char8 as B
156−+import Web.ClientSession
157−+import System.Environment
158−+
159−+--import Debug.Trace
160−+--(!>)= flip trace
161−+
162−+contentHtml :: (ByteString, ByteString)
163−+contentHtml= ("Content-Type", "text/html; charset=UTF-8")
164−+
165−+type CookieT = (B.ByteString,B.ByteString,B.ByteString,Maybe B.ByteString)
166−+
167−+data Cookie
168−+ = UnEncryptedCookie CookieT
169−+ | EncryptedCookie CookieT
170−+ | ParanoidCookie CookieT
171−+ deriving (Eq, Read, Show)
172−+
173−+cookieuser :: String
174−+cookieuser= "cookieuser"
175−+
176−+getCookies httpreq=
177−+ case lookup "Cookie" $ httpreq of
178−+ Just str -> splitCookies str :: [(B.ByteString, B.ByteString)]
179−+ Nothing -> []
180−+
181−+cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs
182−+
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
187−+
188−+showCookie' (n,v,p,me) = n <> "=" <> v <>
189−+ ";path=" <> p <>
190−+ showMaxAge me
191−+
192−+showMaxAge Nothing = ""
193−+showMaxAge (Just e) = ";Max-age=" <> e
194−+
195−+splitCookies cookies = f cookies []
196−+ where
197−+ f s r | B.null s = r
198−+ f xs0 r =
199−+ let
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)
209−+
210− ----------------------------
211−-
212−---readEnv :: Parser [(String,String)]
213−-readEnv = (do
214−- n <- urlEncoded
215−- string "="
216−- v <- urlEncoded
217−- return (n,v)) `sepBy` (string "&")
218−-
219−-urlEncoded :: Parsec String () String
220−-urlEncoded
221−- = many ( alphaNum `mplus` extra `mplus` safe
222−- `mplus` do{ char '+' ; return ' '}
223−- `mplus` do{ char '%' ; hexadecimal }
224−- )
225−-
226−-
227−---extra :: Parser Char
228−-extra = satisfy (`Prelude.elem` "!*'(),/\"")
229−---
230−---safe :: Parser Char
231−-safe = satisfy (`Prelude.elem` "$-_.")
232−-----
233−---hexadecimal :: Parser HexString
234−-hexadecimal = do d1 <- hexDigit
235−- d2 <- 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])
240−-
241−-
242−-
243−-decryptCookie :: Cookie -> IO Cookie
244−-decryptCookie c@(UnEncryptedCookie _) = return c
245−-decryptCookie (EncryptedCookie c) = decryptCookie' c
246−-decryptCookie (ParanoidCookie c) = paranoidDecryptCookie c
247−-
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"
255−- iv1 <- randomIV
256−- iv2 <- randomIV
257−- iv3 <- randomIV
258−- iv4 <- randomIV
259−- return $ ParanoidCookie
260−- ( encrypt key1 iv1 a,
261−- encrypt key2 iv2 b,
262−- encrypt key3 iv3 c,
263−- encryptMaybe key4 iv4 d)
264−-
265−-paranoidDecryptCookie :: CookieT -> IO Cookie
266−-paranoidDecryptCookie (a,b,c,d) = do
267−- key1 <- getKey "CookieKey1.key"
268−- key2 <- getKey "CookieKey2.key"
269−- key3 <- getKey "CookieKey3.key"
270−- key4 <- getKey "CookieKey4.key"
271−- return $ UnEncryptedCookie
272−- ( decryptFM key1 a,
273−- decryptFM key2 b,
274−- decryptFM key3 c,
275−- decryptMaybe key4 d)
276−-
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"
281−- iv1 <- randomIV
282−- iv2 <- randomIV
283−- iv3 <- randomIV
284−- iv4 <- randomIV
285−- return $ EncryptedCookie
286−- ( encrypt key iv1 a,
287−- encrypt key iv2 b,
288−- encrypt key iv3 c,
289−- encryptMaybe key iv4 d)
290−-
291−-decryptCookie' :: CookieT -> IO Cookie
292−-decryptCookie' (a,b,c,d) = do
293−- key <- getKey "CookieKey.key"
294−- return $ UnEncryptedCookie
295−- ( decryptFM key a,
296−- decryptFM key b,
297−- decryptFM key c,
298−- decryptMaybe key d)
299−-
300−-encryptMaybe :: Key -> IV -> Maybe ByteString -> Maybe ByteString
301−-encryptMaybe k i (Just s) = Just $ encrypt k i s
302−-encryptMaybe _ _ Nothing = Nothing
303−-
304−-decryptMaybe :: Key -> Maybe ByteString -> Maybe ByteString
305−-decryptMaybe k (Just s) = Just $ fromMaybe "" $ decrypt k s
306−-decryptMaybe _ Nothing = Nothing
307−-
308−-decryptFM :: Key -> ByteString -> ByteString
309−-decryptFM k b = fromMaybe "" $ decrypt k b
310−-
311−-cookieToTuple :: Cookie -> CookieT
312−-cookieToTuple (UnEncryptedCookie c) = c
313−-cookieToTuple (EncryptedCookie c) = c
314−-cookieToTuple (ParanoidCookie c) = c
315−-
316−-decryptAndToTuple :: Cookie -> CookieT
317−-decryptAndToTuple = cookieToTuple . unsafePerformIO . decryptCookie
318−+
319−+--readEnv :: Parser [(String,String)]
320−+readEnv = (do
321−+ n <- urlEncoded
322−+ string "="
323−+ v <- urlEncoded
324−+ return (n,v)) `sepBy` (string "&")
325−+
326−+urlEncoded :: Parsec String () String
327−+urlEncoded
328−+ = many ( alphaNum `mplus` extra `mplus` safe
329−+ `mplus` do{ char '+' ; return ' '}
330−+ `mplus` do{ char '%' ; hexadecimal }
331−+ )
332−+
333−+
334−+--extra :: Parser Char
335−+extra = satisfy (`Prelude.elem` "!*'(),/\"")
336−+--
337−+--safe :: Parser Char
338−+safe = satisfy (`Prelude.elem` "$-_.")
339−+----
340−+--hexadecimal :: Parser HexString
341−+hexadecimal = do d1 <- hexDigit
342−+ d2 <- 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])
347−+
348−+
349−+
350−+decryptCookie :: Cookie -> IO Cookie
351−+decryptCookie c@(UnEncryptedCookie _) = return c
352−+decryptCookie (EncryptedCookie c) = decryptCookie' c
353−+decryptCookie (ParanoidCookie c) = paranoidDecryptCookie c
354−+
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"
362−+ iv1 <- randomIV
363−+ iv2 <- randomIV
364−+ iv3 <- randomIV
365−+ iv4 <- randomIV
366−+ return $ ParanoidCookie
367−+ ( encrypt key1 iv1 a,
368−+ encrypt key2 iv2 b,
369−+ encrypt key3 iv3 c,
370−+ encryptMaybe key4 iv4 d)
371−+
372−+paranoidDecryptCookie :: CookieT -> IO Cookie
373−+paranoidDecryptCookie (a,b,c,d) = do
374−+ key1 <- getKey "CookieKey1.key"
375−+ key2 <- getKey "CookieKey2.key"
376−+ key3 <- getKey "CookieKey3.key"
377−+ key4 <- getKey "CookieKey4.key"
378−+ return $ UnEncryptedCookie
379−+ ( decryptFM key1 a,
380−+ decryptFM key2 b,
381−+ decryptFM key3 c,
382−+ decryptMaybe key4 d)
383−+
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"
388−+ iv1 <- randomIV
389−+ iv2 <- randomIV
390−+ iv3 <- randomIV
391−+ iv4 <- randomIV
392−+ return $ EncryptedCookie
393−+ ( encrypt key iv1 a,
394−+ encrypt key iv2 b,
395−+ encrypt key iv3 c,
396−+ encryptMaybe key iv4 d)
397−+
398−+decryptCookie' :: CookieT -> IO Cookie
399−+decryptCookie' (a,b,c,d) = do
400−+ key <- getKey "CookieKey.key"
401−+ return $ UnEncryptedCookie
402−+ ( decryptFM key a,
403−+ decryptFM key b,
404−+ decryptFM key c,
405−+ decryptMaybe key d)
406−+
407−+encryptMaybe :: Key -> IV -> Maybe ByteString -> Maybe ByteString
408−+encryptMaybe k i (Just s) = Just $ encrypt k i s
409−+encryptMaybe _ _ Nothing = Nothing
410−+
411−+decryptMaybe :: Key -> Maybe ByteString -> Maybe ByteString
412−+decryptMaybe k (Just s) = Just $ fromMaybe "" $ decrypt k s
413−+decryptMaybe _ Nothing = Nothing
414−+
415−+decryptFM :: Key -> ByteString -> ByteString
416−+decryptFM k b = fromMaybe "" $ decrypt k b
417−+
418−+cookieToTuple :: Cookie -> CookieT
419−+cookieToTuple (UnEncryptedCookie c) = c
420−+cookieToTuple (EncryptedCookie c) = c
421−+cookieToTuple (ParanoidCookie c) = c
422−+
423−+decryptAndToTuple :: Cookie -> CookieT
424−+decryptAndToTuple = cookieToTuple . unsafePerformIO . decryptCookie
425−diff -ru orig/src/MFlow/Forms/Admin.hs new/src/MFlow/Forms/Admin.hs
426−--- orig/src/MFlow/Forms/Admin.hs 2014-06-10 05:51:26.985015856 +0300
427−+++ new/src/MFlow/Forms/Admin.hs 2014-06-10 05:51:25.000000000 +0300
428−@@ -1,175 +1,175 @@
429−-{-# OPTIONS
430−- -XScopedTypeVariables
431−-
432−- #-}
433−-module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where
434−+{-# OPTIONS
435−+ -XScopedTypeVariables
436−+
437−+ #-}
438−+module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where
439− import MFlow.Forms
440− import MFlow
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
446−-import Data.TCache
447−-import Data.TCache.IndexQuery
448−-import System.Exit
449−-import System.IO
450−-import System.IO.Unsafe
451−-import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack)
452−-import System.IO
453−-import Data.RefSerialize hiding ((<|>))
454−-import Data.Typeable
455−-import Data.Monoid
456−-import Data.Maybe
457−-import Data.Map as M (keys, toList)
458−-import System.Exit
459−-import Control.Exception as E
460−-import Control.Concurrent
461−-import Control.Concurrent.MVar
462−-import GHC.Conc
463−-
464−-
465−-ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done"
466−-
467−--- | A small console interpreter with some commands:
468−---
469−--- [@sync@] Synchronize the cache with persistent storage (see `syncCache`)
470−---
471−--- [@flush@] Flush the cache
472−---
473−--- [@end@] Synchronize and exit
474−---
475−--- [@abort@] Exit. Do not synchronize
476−---
477−--- on exception, for example Control-c, it sync and exits.
478−--- It must be used as the last statement of the main procedure.
479−-adminLoop :: IO ()
480−-adminLoop= do
481−- msgs <- getMessageFlows
482−- putStrLn ""
483−- putStrLn $ "Served:"
484−- mapM putStrLn [ " http://server:port/"++ i | i <- M.keys msgs]
485−- putStrLn ""
486−- putStrLn "Commands: sync, flush, end, abort"
487−- adminLoop1
488−- `E.catch` (\(e:: E.SomeException) ->do
489−- ssyncCache
490−- error $ "\nException: "++ show e)
491−-
492−-adminLoop1= do
493−- putStr ">"; hFlush stdout
494−- op <- getLine
495−- case op of
496−- "sync" -> ssyncCache
497−- "flush" -> atomically flushAll >> putStrLn "flushed cache"
498−- "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess
499−- "abort" -> exitWith ExitSuccess
500−- _ -> return()
501−- adminLoop1
502−-
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
510−+import Data.TCache
511−+import Data.TCache.IndexQuery
512−+import System.Exit
513−+import System.IO
514−+import System.IO.Unsafe
515−+import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack)
516−+import System.IO
517−+import Data.RefSerialize hiding ((<|>))
518−+import Data.Typeable
519−+import Data.Monoid
520−+import Data.Maybe
521−+import Data.Map as M (keys, toList)
522−+import System.Exit
523−+import Control.Exception as E
524−+import Control.Concurrent
525−+import Control.Concurrent.MVar
526−+import GHC.Conc
527−+
528−+
529−+ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done"
530−+
531−+-- | A small console interpreter with some commands:
532−+--
533−+-- [@sync@] Synchronize the cache with persistent storage (see `syncCache`)
534−+--
535−+-- [@flush@] Flush the cache
536−+--
537−+-- [@end@] Synchronize and exit
538−+--
539−+-- [@abort@] Exit. Do not synchronize
540−+--
541−+-- on exception, for example Control-c, it sync and exits.
542−+-- It must be used as the last statement of the main procedure.
543−+adminLoop :: IO ()
544−+adminLoop= do
545−+ msgs <- getMessageFlows
546−+ putStrLn ""
547−+ putStrLn $ "Served:"
548−+ mapM putStrLn [ " http://server:port/"++ i | i <- M.keys msgs]
549−+ putStrLn ""
550−+ putStrLn "Commands: sync, flush, end, abort"
551−+ adminLoop1
552−+ `E.catch` (\(e:: E.SomeException) ->do
553−+ ssyncCache
554−+ error $ "\nException: "++ show e)
555−+
556−+adminLoop1= do
557−+ putStr ">"; hFlush stdout
558−+ op <- getLine
559−+ case op of
560−+ "sync" -> ssyncCache
561−+ "flush" -> atomically flushAll >> putStrLn "flushed cache"
562−+ "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess
563−+ "abort" -> exitWith ExitSuccess
564−+ _ -> return()
565−+ adminLoop1
566−+
567−+-- | execute the process and wait for its finalization.
568−+-- then it synchronizes the cache
569− wait f= do
570− putChar '\n'
571− putStrLn "Using configuration: "
572− mapM_ putStrLn [k ++"= "++ show v | (k,v) <- M.toList config]
573−- putChar '\n'
574−- mv <- newEmptyMVar
575−- forkIO (f1 >> putMVar mv True)
576−- putStrLn "wait: ready"
577−+ putChar '\n'
578−+ mv <- newEmptyMVar
579−+ forkIO (f1 >> putMVar mv True)
580−+ putStrLn "wait: ready"
581− takeMVar mv
582−- return ()
583−- `E.catch` (\(e:: E.SomeException) ->do
584−- ssyncCache
585−- error $ "Signal: "++ show e)
586−-
587−- where
588−- f1= do
589−- mv <- newEmptyMVar
590−- n <- getNumProcessors
591−- putStr "Running in "
592−- putStr $ show n
593−- putStrLn " core(s)"
594−- hFlush stdout
595−- f
596−-
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`.
600−---
601−--- The administration page is reached with the path \"adminserv\"
602−-addAdminWF= addMessageFlows[("adminserv", runFlow $ transientNav adminMFlow)]
603−-
604−-
605−-adminMFlow :: FlowM Html IO ()
606−-adminMFlow= do
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")
615−-
616−- case op of
617−- "users" -> users
618−- "sync" -> liftIO $ syncCache >> print "syncronized cache"
619−- "flush" -> liftIO $ atomically flushAll >> print "flushed cache"
620−-
621−- "errors" -> errors
622−- "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess)
623−- "abort" -> liftIO $ exitWith(ExitSuccess)
624−- _ -> return()
625−- adminMFlow
626−-
627−-
628−-errors= do
629−- size <- liftIO $ hFileSize hlog
630−- if size == 0
631−- then ask $ wlink () (b << "no error log")
632−- else do
633−- liftIO $ hSeek hlog AbsoluteSeek 0
634−- log <- liftIO $ hGetNonBlocking hlog (fromIntegral size)
635−-
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
639−- breturn()
640−-
641−-
642−-
643−-
644−-
645−-
646−-
647−-users= do
648−- users <- liftIO $ atomically $ return . map fst =<< indexOf userName
649−-
650−- showFormList [[wlink u (b << u) `waction` optionsUser ] | u<- users] 0 10
651−-
652−-showFormList
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
658−-
659−- where
660−- list= table <<< firstOf (span1 n l [tr <<< cols e | e <- ls ])
661−-
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
665−-
666−-optionsUser us = do
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
671−- if null wfss
672−- then ask $ b << " not logs for this user" ++> wlink () (b << "Press here")
673−- else do
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")
676−-
677−+ return ()
678−+ `E.catch` (\(e:: E.SomeException) ->do
679−+ ssyncCache
680−+ error $ "Signal: "++ show e)
681−+
682−+ where
683−+ f1= do
684−+ mv <- newEmptyMVar
685−+ n <- getNumProcessors
686−+ putStr "Running in "
687−+ putStr $ show n
688−+ putStrLn " core(s)"
689−+ hFlush stdout
690−+ f
691−+
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`.
695−+--
696−+-- The administration page is reached with the path \"adminserv\"
697−+addAdminWF= addMessageFlows[("adminserv", runFlow $ transientNav adminMFlow)]
698−+
699−+
700−+adminMFlow :: FlowM Html IO ()
701−+adminMFlow= do
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")
710−+
711−+ case op of
712−+ "users" -> users
713−+ "sync" -> liftIO $ syncCache >> print "syncronized cache"
714−+ "flush" -> liftIO $ atomically flushAll >> print "flushed cache"
715−+
716−+ "errors" -> errors
717−+ "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess)
718−+ "abort" -> liftIO $ exitWith(ExitSuccess)
719−+ _ -> return()
720−+ adminMFlow
721−+
722−+
723−+errors= do
724−+ size <- liftIO $ hFileSize hlog
725−+ if size == 0
726−+ then ask $ wlink () (b << "no error log")
727−+ else do
728−+ liftIO $ hSeek hlog AbsoluteSeek 0
729−+ log <- liftIO $ hGetNonBlocking hlog (fromIntegral size)
730−+
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
734−+ breturn()
735−+
736−+
737−+
738−+
739−+
740−+
741−+
742−+users= do
743−+ users <- liftIO $ atomically $ return . map fst =<< indexOf userName
744−+
745−+ showFormList [[wlink u (b << u) `waction` optionsUser ] | u<- users] 0 10
746−+
747−+showFormList
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
753−+
754−+ where
755−+ list= table <<< firstOf (span1 n l [tr <<< cols e | e <- ls ])
756−+
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
760−+
761−+optionsUser us = do
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
766−+ if null wfss
767−+ then ask $ b << " not logs for this user" ++> wlink () (b << "Press here")
768−+ else do
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")
771−+
772−diff -ru orig/src/MFlow/Forms/Blaze/Html.hs new/src/MFlow/Forms/Blaze/Html.hs
773−--- orig/src/MFlow/Forms/Blaze/Html.hs 2014-06-10 05:51:26.989015856 +0300
774−+++ new/src/MFlow/Forms/Blaze/Html.hs 2014-06-10 05:51:25.000000000 +0300
775−@@ -58,7 +58,7 @@
776− in if msel then tag ! selected (toValue ("" ::String)) else tag
777−
778−
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
781−
782− fromStr= toMarkup
783− fromStrNoEncode = preEscapedToMarkup
784−diff -ru orig/src/MFlow/Forms/Internals.hs new/src/MFlow/Forms/Internals.hs
785−--- orig/src/MFlow/Forms/Internals.hs 2014-06-10 05:51:26.981015856 +0300
786−+++ new/src/MFlow/Forms/Internals.hs 2014-06-10 05:51:25.000000000 +0300
787−@@ -1,313 +1,345 @@
788−------------------------------------------------------------------------------
789−---
790−--- Module : MFlow.Forms.Internals
791−--- Copyright :
792−--- License : BSD3
793−---
794−--- Maintainer : agocorona@gmail.com
795−--- Stability : experimental
796−--- Portability :
797−---
798−--- |
799−---
800−------------------------------------------------------------------------------
801−-{-# OPTIONS -XDeriveDataTypeable
802−- -XExistentialQuantification
803−- -XScopedTypeVariables
804−- -XFlexibleInstances
805−- -XUndecidableInstances
806−- -XMultiParamTypeClasses
807−- -XGeneralizedNewtypeDeriving
808−- -XFlexibleContexts
809−- -XOverlappingInstances
810−- -XRecordWildCards
811−-#-}
812−-
813−-module MFlow.Forms.Internals where
814−-import MFlow
815−-import MFlow.Cookies
816−-import Control.Applicative
817−-import Data.Monoid
818−-import Control.Monad.Trans
819−-import Control.Monad.State
820−-import Data.ByteString.Lazy.UTF8 as B hiding (length, foldr, take)
821−-import qualified Data.ByteString.UTF8 as SB
822−-import Data.Typeable
823−-import Data.RefSerialize hiding((<|>))
824−-import Data.TCache
825−-import Data.TCache.Memoization
826−-import Data.TCache.DefaultPersistence
827−-import Data.TCache.Memoization
828−-import Data.Dynamic
829−-import qualified Data.Map as M
830−-import Unsafe.Coerce
831−-import Control.Workflow as WF
832−-import Control.Monad.Identity
833−-import Data.List
834−-import System.IO.Unsafe
835−-import Control.Concurrent.MVar
836−+-----------------------------------------------------------------------------
837−+--
838−+-- Module : MFlow.Forms.Internals
839−+-- Copyright :
840−+-- License : BSD3
841−+--
842−+-- Maintainer : agocorona@gmail.com
843−+-- Stability : experimental
844−+-- Portability :
845−+--
846−+-- |
847−+--
848−+-----------------------------------------------------------------------------
849−+{-# OPTIONS -XDeriveDataTypeable
850−+ -XExistentialQuantification
851−+ -XScopedTypeVariables
852−+ -XFlexibleInstances
853−+ -XUndecidableInstances
854−+ -XMultiParamTypeClasses
855−+ -XGeneralizedNewtypeDeriving
856−+ -XFlexibleContexts
857−+ -XOverlappingInstances
858−+ -XRecordWildCards
859−+#-}
860−+
861−+module MFlow.Forms.Internals where
862−+import MFlow
863−+import MFlow.Cookies
864−+import Control.Applicative
865−+import Data.Monoid
866−+import Control.Monad.Trans
867−+import Control.Monad.State
868−+import Data.ByteString.Lazy.UTF8 as B hiding (length, foldr, take)
869−+import qualified Data.ByteString.UTF8 as SB
870−+import Data.Typeable
871−+import Data.RefSerialize hiding((<|>))
872−+import Data.TCache
873−+import Data.TCache.Memoization
874−+import Data.TCache.DefaultPersistence
875−+import Data.TCache.Memoization
876−+import Data.Dynamic
877−+import qualified Data.Map as M
878−+import Unsafe.Coerce
879−+import Control.Workflow as WF
880−+import Control.Monad.Identity
881−+import Data.List
882−+import System.IO.Unsafe
883−+import Control.Concurrent.MVar
884− import qualified Data.Text as T
885− import Data.Char
886− import Data.List(stripPrefix)
887− import Data.Maybe(isJust)
888− import Control.Concurrent.STM
889− import Data.TCache.Memoization
890−-
891−---
892−----- for traces
893−---
894−-
895−-import Control.Exception as CE
896−-import Control.Concurrent
897−-import Control.Monad.Loc
898−-
899−--- debug
900−---import Debug.Trace
901−---(!>) = flip trace
902−-
903−-
904−-data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable)
905−-
906−-
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)
911−-
912−- readp = choice [icanFailBackp,repeatPleasep,noFailBackp]
913−- where
914−- noFailBackp = symbol noFailBack >> readp >>= return . NoBack
915−- icanFailBackp = symbol iCanFailBack >> readp >>= return . BackPoint
916−- repeatPleasep = symbol repeatPlease >> return GoBack
917−-
918−-iCanFailBack= "B"
919−-repeatPlease= "G"
920−-noFailBack= "N"
921−-
922−-newtype Sup m a = Sup { runSup :: m (FailBack a ) }
923−-
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
927−-
928−- supervise :: m (FailBack a) -> m (FailBack a)
929−- supervise= id
930−-
931−-
932−-
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
937−- where
938−- loop = do
939−- s <- get
940−- v <- supervise $ runSup x -- !> "loop"
941−- case v of
942−- NoBack y -> supervise $ runSup (f y) -- !> "runback"
943−- BackPoint y -> do
944−- z <- supervise $ runSup (f y) -- !> "BACK"
945−- case z of
946−- GoBack -> supBack s >> loop -- !> "BACKTRACKING"
947−- other -> return other
948−- GoBack -> return $ GoBack
949−-
950−-
951−-fromFailBack (NoBack x) = x
952−-fromFailBack (BackPoint x)= x
953−-toFailBack x= NoBack x
954−-
955−-
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.
959−---
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))
962−-flowM= FlowM
963−---runFlowM= runView
964−-
965−-{-# NOINLINE breturn #-}
966−-
967−--- | Use this instead of return to return from a computation with ask statements
968−---
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"
973−-
974−-
975−-instance (Supervise s m,MonadIO m) => MonadIO (Sup m) where
976−- liftIO f= Sup $ liftIO f >>= \ x -> return $ NoBack x
977−-
978−-instance (Monad m,Functor m) => Functor (Sup m) where
979−- fmap f g= Sup $ do
980−- mr <- runSup g
981−- case mr of
982−- BackPoint x -> return . BackPoint $ f x
983−- NoBack x -> return . NoBack $ f x
984−- GoBack -> return $ GoBack
985−-
986−-
987−-liftSup f = Sup $ f >>= \x -> return $ NoBack x
988−-instance MonadTrans Sup where
989−- lift f = Sup $ f >>= \x -> return $ NoBack x
990−-
991−-
992−-instance (Supervise s m,MonadState s m) => MonadState s (Sup m) where
993−- get= lift get -- !> "get"
994−- put= lift . put
995−-
996−-type WState view m = StateT (MFlowState view) m
997−-type FlowMM view m= Sup (WState view m)
998−-
999−-data FormElm view a = FormElm view (Maybe a) deriving Typeable
1000−-
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
1004−-
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`
1006−---
1007−--- It has 'Applicative', 'Alternative' and 'Monad' instances.
1008−---
1009−--- Things to know about these instances:
1010−---
1011−--- If the View expression does not validate, ask will present the page again.
1012−---
1013−--- /Alternative instance/: Both alternatives are executed. The rest is as usual
1014−---
1015−--- /Monad Instance/:
1016−---
1017−--- The rendering of each statement is added to the previous. If you want to avoid this, use 'wcallback'
1018−---
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).
1021−---
1022−--- The monadic code is executed from the beginning each time the page is presented or refreshed
1023−---
1024−--- use 'pageFlow' if your page has more than one monadic computation with dynamic behaviour
1025−---
1026−--- use 'pageFlow' to identify each subflow branch of a conditional
1027−---
1028−--- For example:
1029−---
1030−--- > pageFlow "myid" $ do
1031−--- > r <- formlet1
1032−--- > liftIO $ ioaction1 r
1033−--- > s <- formlet2
1034−--- > liftIO $ ioaction2 s
1035−--- > case s of
1036−--- > True -> pageFlow "idtrue" $ do ....
1037−--- > False -> paeFlow "idfalse" $ do ...
1038−--- > ...
1039−---
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)}
1044−-
1045−-
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
1050−- , mfPath=mfPath
1051−- , mfData=mfData
1052−- , mfTrace= mfTrace
1053−+
1054−+--
1055−+---- for traces
1056−+--
1057−+
1058−+import Control.Exception as CE
1059−+import Control.Concurrent
1060−+import Control.Monad.Loc
1061−+
1062−+-- debug
1063−+import Debug.Trace
1064−+(!>) = flip trace
1065−+
1066−+
1067−+data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable)
1068−+
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
1073−+
1074−+instance Applicative FailBack where
1075−+ pure x = NoBack x
1076−+ _ <*> GoBack = GoBack
1077−+ GoBack <*> _ = GoBack
1078−+ k <*> x = NoBack $ (fromFailBack k) (fromFailBack x)
1079−+
1080−+instance Alternative FailBack where
1081−+ empty= GoBack
1082−+ GoBack <|> f = f
1083−+ f <|> _ = f
1084−+
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)
1089−+
1090−+ readp = choice [icanFailBackp,repeatPleasep,noFailBackp]
1091−+ where
1092−+ noFailBackp = symbol noFailBack >> readp >>= return . NoBack
1093−+ icanFailBackp = symbol iCanFailBack >> readp >>= return . BackPoint
1094−+ repeatPleasep = symbol repeatPlease >> return GoBack
1095−+
1096−+iCanFailBack= "B"
1097−+repeatPlease= "G"
1098−+noFailBack= "N"
1099−+
1100−+newtype Sup m a = Sup { runSup :: m (FailBack a ) }
1101−+
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
1105−+
1106−+ supervise :: m (FailBack a) -> m (FailBack a)
1107−+ supervise= id
1108−+
1109−+
1110−+
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
1115−+ where
1116−+ loop = do
1117−+ s <- get
1118−+ v <- supervise $ runSup x -- !> "loop"
1119−+ case v of
1120−+ NoBack y -> supervise $ runSup (f y) -- !> "runback"
1121−+ BackPoint y -> do
1122−+ z <- supervise $ runSup (f y) -- !> "BACK"
1123−+ case z of
1124−+ GoBack -> supBack s >> loop -- !> "BACKTRACKING"
1125−+ other -> return other
1126−+ GoBack -> return $ GoBack
1127−+
1128−+
1129−+fromFailBack (NoBack x) = x
1130−+fromFailBack (BackPoint x)= x
1131−+toFailBack x= NoBack x
1132−+
1133−+instance (Monad m,Applicative m) => Applicative (Sup m) where
1134−+ pure x = Sup . return $ NoBack x
1135−+ f <*> g= Sup $ do
1136−+ k <- runSup f
1137−+ x <- runSup g
1138−+ return $ k <*> x
1139−+
1140−+instance(Monad m, Applicative m) => Alternative (Sup m) where
1141−+ empty = Sup . return $ GoBack
1142−+ f <|> g= Sup $ do
1143−+ x <- runSup f
1144−+ case x of
1145−+ GoBack -> runSup g !> "GOBACK"
1146−+ _ -> return x
1147−+
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.
1151−+--
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))
1156−+
1157−+--runFlowM= runView
1158−+
1159−+{-# NOINLINE breturn #-}
1160−+
1161−+-- | Use this instead of return to return from a computation with ask statements
1162−+--
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"
1167−+
1168−+
1169−+instance (Supervise s m,MonadIO m) => MonadIO (Sup m) where
1170−+ liftIO f= Sup $ liftIO f >>= \ x -> return $ NoBack x
1171−+
1172−+instance (Monad m,Functor m) => Functor (Sup m) where
1173−+ fmap f g= Sup $ do
1174−+ mr <- runSup g
1175−+ case mr of
1176−+ BackPoint x -> return . BackPoint $ f x
1177−+ NoBack x -> return . NoBack $ f x
1178−+ GoBack -> return $ GoBack
1179−+
1180−+
1181−+liftSup f = Sup $ f >>= \x -> return $ NoBack x
1182−+instance MonadTrans Sup where
1183−+ lift f = Sup $ f >>= \x -> return $ NoBack x
1184−+
1185−+
1186−+instance (Supervise s m,MonadState s m) => MonadState s (Sup m) where
1187−+ get= lift get -- !> "get"
1188−+ put= lift . put
1189−+
1190−+type WState view m = StateT (MFlowState view) m
1191−+type FlowMM view m= Sup (WState view m)
1192−+
1193−+data FormElm view a = FormElm view (Maybe a) deriving Typeable
1194−+
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
1198−+
1199−+
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`
1201−+--
1202−+-- It has 'Applicative', 'Alternative' and 'Monad' instances.
1203−+--
1204−+-- Things to know about these instances:
1205−+--
1206−+-- If the View expression does not validate, ask will present the page again.
1207−+--
1208−+-- /Alternative instance/: Both alternatives are executed. The rest is as usual
1209−+--
1210−+-- /Monad Instance/:
1211−+--
1212−+-- The rendering of each statement is added to the previous. If you want to avoid this, use 'wcallback'
1213−+--
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).
1216−+--
1217−+-- The monadic code is executed from the beginning each time the page is presented or refreshed
1218−+--
1219−+-- use 'pageFlow' if your page has more than one monadic computation with dynamic behaviour
1220−+--
1221−+-- use 'pageFlow' to identify each subflow branch of a conditional
1222−+--
1223−+-- For example:
1224−+--
1225−+-- > pageFlow "myid" $ do
1226−+-- > r <- formlet1
1227−+-- > liftIO $ ioaction1 r
1228−+-- > s <- formlet2
1229−+-- > liftIO $ ioaction2 s
1230−+-- > case s of
1231−+-- > True -> pageFlow "idtrue" $ do ....
1232−+-- > False -> paeFlow "idfalse" $ do ...
1233−+-- > ...
1234−+--
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)}
1239−+
1240−+
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
1245−+ , mfPath=mfPath
1246−+ , mfData=mfData
1247−+ , mfTrace= mfTrace
1248− , inSync=False
1249−- , newAsk=False}
1250−-
1251−-
1252−-
1253−-
1254−-instance MonadLoc (FlowM v IO) where
1255−- withLoc loc f = FlowM . Sup $ do
1256−- withLoc loc $ do
1257−- s <- get
1258−- (r,s') <- lift $ do
1259−- rs@(r,s') <- runStateT (runSup (runFlowM f) ) s
1260−- `CE.catch` (handler1 loc s)
1261−- case mfTrace s' of
1262−- [] -> return rs
1263−- trace -> return(r, s'{mfTrace= loc:trace})
1264−- put s'
1265−- return r
1266−-
1267−- where
1268−- handler1 loc s (e :: SomeException)= do
1269−- case CE.fromException e :: Maybe WFErrors of
1270−- Just e -> CE.throw e -- !> ("TROWNF=" ++ show e)
1271−- Nothing ->
1272−- case CE.fromException e :: Maybe AsyncException of
1273−- Just e -> CE.throw e -- !> ("TROWN ASYNCF=" ++ show e)
1274−- Nothing ->
1275−- return (GoBack, s{mfTrace= [show e]})
1276−-
1277−-
1278−---instance (Serialize a,Typeable a, FormInput v) => MonadLoc (FlowM v (Workflow IO)) a where
1279−--- withLoc loc f = FlowM . Sup $
1280−--- withLoc loc $ do
1281−--- s <- get
1282−--- (r,s') <- lift . WF.step $ exec1d "jkkjk" ( runStateT (runSup $ runFlowM f) s) `CMT.catch` (handler1 loc s)
1283−--- put s'
1284−--- return r
1285−---
1286−--- where
1287−--- handler1 loc s (e :: SomeException)=
1288−--- return (GoBack, s{mfTrace= Just ["exception: " ++show e]})
1289−-
1290−-instance FormInput v => MonadLoc (View v IO) where
1291−- withLoc loc f = View $ do
1292−- withLoc loc $ do
1293−- s <- get
1294−- (r,s') <- lift $ do
1295−- rs@(r,s') <- runStateT (runView f) s
1296−- `CE.catch` (handler1 loc s)
1297−- case mfTrace s' of
1298−- [] -> return rs
1299−- trace -> return(r, s'{mfTrace= loc:trace})
1300−- put s'
1301−- return r
1302−-
1303−- where
1304−- handler1 loc s (e :: SomeException)= do
1305−- case CE.fromException e :: Maybe WFErrors of
1306−- Just e -> CE.throw e -- !> ("TROWN=" ++ show e)
1307−- Nothing ->
1308−- case CE.fromException e :: Maybe AsyncException of
1309−- Just e -> CE.throw e -- !> ("TROWN ASYNC=" ++ show e)
1310−- Nothing ->
1311−- return (FormElm mempty Nothing, s{mfTrace= [show e]}) -- !> loc
1312−-
1313−-
1314−-
1315−-
1316−-
1317−-
1318−-
1319−-instance Functor (FormElm view ) where
1320−- fmap f (FormElm form x)= FormElm form (fmap f x)
1321−-
1322−-instance (Monad m,Functor m) => Functor (View view m) where
1323−- fmap f x= View $ fmap (fmap f) $ runView x
1324−-
1325−-
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)
1332−-
1333−-instance (FormInput view,Functor m, Monad m) => Alternative (View view m) where
1334−- empty= View $ return $ FormElm mempty Nothing
1335−+ , newAsk=False}
1336−+
1337−+
1338−+
1339−+
1340−+instance MonadLoc (FlowM v IO) where
1341−+ withLoc loc f = FlowM . Sup $ do
1342−+ withLoc loc $ do
1343−+ s <- get
1344−+ (r,s') <- lift $ do
1345−+ rs@(r,s') <- runStateT (runSup (runFlowM f) ) s
1346−+ `CE.catch` (handler1 loc s)
1347−+ case mfTrace s' of
1348−+ [] -> return rs
1349−+ trace -> return(r, s'{mfTrace= loc:trace})
1350−+ put s'
1351−+ return r
1352−+
1353−+ where
1354−+ handler1 loc s (e :: SomeException)= do
1355−+ case CE.fromException e :: Maybe WFErrors of
1356−+ Just e -> CE.throw e -- !> ("TROWNF=" ++ show e)
1357−+ Nothing ->
1358−+ case CE.fromException e :: Maybe AsyncException of
1359−+ Just e -> CE.throw e -- !> ("TROWN ASYNCF=" ++ show e)
1360−+ Nothing ->
1361−+ return (GoBack, s{mfTrace= [show e]})
1362−+
1363−+
1364−+--instance (Serialize a,Typeable a, FormInput v) => MonadLoc (FlowM v (Workflow IO)) a where
1365−+-- withLoc loc f = FlowM . Sup $
1366−+-- withLoc loc $ do
1367−+-- s <- get
1368−+-- (r,s') <- lift . WF.step $ exec1d "jkkjk" ( runStateT (runSup $ runFlowM f) s) `CMT.catch` (handler1 loc s)
1369−+-- put s'
1370−+-- return r
1371−+--
1372−+-- where
1373−+-- handler1 loc s (e :: SomeException)=
1374−+-- return (GoBack, s{mfTrace= Just ["exception: " ++show e]})
1375−+
1376−+instance FormInput v => MonadLoc (View v IO) where
1377−+ withLoc loc f = View $ do
1378−+ withLoc loc $ do
1379−+ s <- get
1380−+ (r,s') <- lift $ do
1381−+ rs@(r,s') <- runStateT (runView f) s
1382−+ `CE.catch` (handler1 loc s)
1383−+ case mfTrace s' of
1384−+ [] -> return rs
1385−+ trace -> return(r, s'{mfTrace= loc:trace})
1386−+ put s'
1387−+ return r
1388−+
1389−+ where
1390−+ handler1 loc s (e :: SomeException)= do
1391−+ case CE.fromException e :: Maybe WFErrors of
1392−+ Just e -> CE.throw e -- !> ("TROWN=" ++ show e)
1393−+ Nothing ->
1394−+ case CE.fromException e :: Maybe AsyncException of
1395−+ Just e -> CE.throw e -- !> ("TROWN ASYNC=" ++ show e)
1396−+ Nothing ->
1397−+ return (FormElm mempty Nothing, s{mfTrace= [show e]}) -- !> loc
1398−+
1399−+
1400−+
1401−+
1402−+
1403−+
1404−+
1405−+instance Functor (FormElm view ) where
1406−+ fmap f (FormElm form x)= FormElm form (fmap f x)
1407−+
1408−+instance (Monad m,Functor m) => Functor (View view m) where
1409−+ fmap f x= View $ fmap (fmap f) $ runView x
1410−+
1411−+
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)
1418−+
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
1425− s1 <- get
1426− let path1 = mfPagePath s1
1427−- put s1{mfPagePath=path}
1428−+ put s1{mfPagePath=path}
1429− FormElm form2 x <- g
1430− s2 <- get
1431− (mix,hasform) <- controlForms s1 s2 form1 form2
1432−@@ -317,259 +349,259 @@
1433− (_,Just _) -> path2
1434− _ -> path
1435− if hasform then put s2{needForm= HasForm,mfPagePath= path3}
1436−- else put s2{mfPagePath=path3}
1437−- return $ FormElm mix (k <|> x)
1438−-
1439−-
1440−-instance (FormInput view, Monad m) => Monad (View view m) where
1441−- View x >>= f = View $ do
1442−- FormElm form1 mk <- x
1443−- case mk of
1444−- Just k -> do
1445−+ else put s2{mfPagePath=path3}
1446−+ return $ FormElm mix (k <|> x)
1447−+
1448−+
1449−+instance (FormInput view, Monad m) => Monad (View view m) where
1450−+ View x >>= f = View $ do
1451−+ FormElm form1 mk <- x
1452−+ case mk of
1453−+ Just k -> do
1454− st'' <- get
1455− let st = st''{ linkMatched = False }
1456−- put st
1457−+ put st
1458− FormElm form2 mk <- runView $ f k
1459− st' <- get
1460− (mix, hasform) <- controlForms st st' form1 form2
1461− when hasform $ put st'{needForm= HasForm}
1462−-
1463−- return $ FormElm mix mk
1464−- Nothing ->
1465−- return $ FormElm form1 Nothing
1466−-
1467−-
1468−-
1469−- return = View . return . FormElm mempty . Just
1470−--- fail msg= View . return $ FormElm [inRed msg] Nothing
1471−-
1472−-
1473−-
1474−-
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
1478−-
1479−-
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>)
1485−---
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.
1489−-wcallback
1490−- :: Monad m =>
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
1494−- case mk of
1495−- Just k -> do
1496−- modify $ \st -> st{linkMatched= False, needForm=NoElems}
1497−+
1498−+ return $ FormElm mix mk
1499−+ Nothing ->
1500−+ return $ FormElm form1 Nothing
1501−+
1502−+
1503−+
1504−+ return = View . return . FormElm mempty . Just
1505−+-- fail msg= View . return $ FormElm [inRed msg] Nothing
1506−+
1507−+
1508−+
1509−+
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
1513−+
1514−+
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>)
1520−+--
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.
1524−+wcallback
1525−+ :: Monad m =>
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
1529−+ case mk of
1530−+ Just k -> do
1531−+ modify $ \st -> st{linkMatched= False, needForm=NoElems}
1532− runView (f k)
1533−-
1534−- Nothing -> return $ FormElm form1 Nothing
1535−-
1536−-
1537−-
1538−-
1539−-
1540−-
1541−-instance Monoid view => MonadTrans (View view) where
1542−- lift f = View $ (lift f) >>= \x -> return $ FormElm mempty $ Just x
1543−-
1544−-instance MonadTrans (FlowM view) where
1545−- lift f = FlowM $ lift (lift f) -- >>= \x -> return x
1546−-
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
1550−-
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
1554−-
1555−-
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
1558−-
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')
1565−+
1566−+ Nothing -> return $ FormElm form1 Nothing
1567−+
1568−+
1569−+
1570−+
1571−+
1572−+
1573−+instance Monoid view => MonadTrans (View view) where
1574−+ lift f = View $ (lift f) >>= \x -> return $ FormElm mempty $ Just x
1575−+
1576−+instance MonadTrans (FlowM view) where
1577−+ lift f = FlowM $ lift (lift f) -- >>= \x -> return x
1578−+
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
1582−+
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
1586−+
1587−+
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
1590−+
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')
1597−
1598−
1599−
1600− ----- some combinators ----
1601−-
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).
1605−---
1606−--- it has a low infix priority: @infixr 2@
1607−---
1608−--- > r <- ask widget1 <+> widget2
1609−--- > case r of (Just x, Nothing) -> ..
1610−-(<+>) , mix :: (Monad m, FormInput view)
1611−- => View view m a
1612−- -> View view m b
1613−- -> View view m (Maybe a, Maybe b)
1614−-mix digest1 digest2= View $ do
1615−+
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).
1619−+--
1620−+-- it has a low infix priority: @infixr 2@
1621−+--
1622−+-- > r <- ask widget1 <+> widget2
1623−+-- > case r of (Just x, Nothing) -> ..
1624−+(<+>) , mix :: (Monad m, FormInput view)
1625−+ => View view m a
1626−+ -> View view m b
1627−+ -> View view m (Maybe a, Maybe b)
1628−+mix digest1 digest2= View $ do
1629− FormElm f1 mx' <- runView digest1
1630−- s1 <- get
1631−+ s1 <- get
1632− FormElm f2 my' <- runView digest2
1633− s2 <- get
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
1640−-
1641−-infixr 2 <+>
1642−-
1643−-(<+>) = mix
1644−-
1645−-
1646−-
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.
1650−---
1651−--- The first element is displayed however, as happens in the case of '*>' .
1652−---
1653−--- Here @w\'s@ are widgets and @r\'s@ are returned values
1654−---
1655−--- @(w1 <* w2)@ will return @Just r1@ only if w1 and w2 are validated
1656−---
1657−--- @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated
1658−---
1659−--- it has a low infix priority: @infixr 1@
1660−-
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
1668−+
1669−+infixr 2 <+>
1670−+
1671−+(<+>) = mix
1672−+
1673−+
1674−+
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.
1678−+--
1679−+-- The first element is displayed however, as happens in the case of '*>' .
1680−+--
1681−+-- Here @w\'s@ are widgets and @r\'s@ are returned values
1682−+--
1683−+-- @(w1 <* w2)@ will return @Just r1@ only if w1 and w2 are validated
1684−+--
1685−+-- @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated
1686−+--
1687−+-- it has a low infix priority: @infixr 1@
1688−+
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
1694−- s1 <- get
1695−+ s1 <- get
1696− FormElm form2 x <- runView g
1697− s2 <- get
1698− (mix,hasform) <- controlForms s1 s2 form1 form2
1699−- when hasform $ put s2{needForm= HasForm}
1700−- return $ FormElm mix (k *> x)
1701−-
1702−-
1703−-
1704−-valid form= View $ do
1705−- FormElm form mx <- runView form
1706−- return $ FormElm form $ Just undefined
1707−-
1708−-infixr 1 **> , <**
1709−-
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
1715−---
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)
1722−+
1723−+
1724−+
1725−+valid form= View $ do
1726−+ FormElm form mx <- runView form
1727−+ return $ FormElm form $ Just undefined
1728−+
1729−+infixr 1 **> , <**
1730−+
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
1736−+--
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
1743−- s1 <- get
1744−+ s1 <- get
1745− FormElm form2 x <- runView $ valid g
1746− s2 <- get
1747− (mix,hasform) <- controlForms s1 s2 form1 form2
1748−- when hasform $ put s2{needForm= HasForm}
1749−- return $ FormElm mix (k <* x)
1750−-
1751−+ when hasform $ put s2{needForm= HasForm}
1752−+ return $ FormElm mix (k <* x)
1753−+
1754−
1755−
1756− -------- Flow control
1757−-
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
1760−---
1761−--- @menu= do
1762−--- mop <- getGoStraighTo
1763−--- case mop of
1764−--- Just goop -> goop
1765−--- Nothing -> do
1766−--- r \<- `ask` option1 \<|> option2
1767−--- case r of
1768−--- op1 -> setGoStraighTo (Just goop1) >> goop1
1769−--- op2 -> setGoStraighTo (Just goop2) >> goop2@
1770−---
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
1774−---
1775−--- @menu= do
1776−--- mop <- getGoStraighTo
1777−--- back <- `goingBack`
1778−--- case (mop,back) of
1779−--- (Just goop,False) -> goop
1780−--- _ -> do
1781−--- r \<- `ask` option1 \<|> option2
1782−--- case r of
1783−--- op1 -> setGoStraighTo (Just goop1) >> goop1
1784−--- op2 -> setGoStraighTo (Just goop2) >> goop2@
1785−---
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
1790−-goingBack = do
1791−- st <- get
1792−- return $ not (inSync st) && not (newAsk st)
1793−-
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
1797−---
1798−--- It is useful when an undoable transaction has been commited. For example, after a payment.
1799−---
1800−--- This example show a message when the user go back and press again to pay
1801−---
1802−--- > ask $ wlink () << b << "press here to pay 100000 $ "
1803−--- > payIt
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"
1807−--- > where
1808−--- > payIt= liftIO $ print "paying"
1809−-
1810−-preventGoingBack
1811−- :: ( Functor m, MonadIO m, FormInput v) => FlowM v m () -> FlowM v m ()
1812−-preventGoingBack msg= do
1813−- back <- goingBack
1814−- if not back then breturn() else do
1815−- breturn() -- will not go back beyond this
1816−- clearEnv
1817−- modify $ \s -> s{newAsk= True}
1818−- msg
1819−-
1820−-
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
1825−- back <- goingBack
1826−- case back of
1827−- False -> (lift doit) >>= breturn
1828−- True -> onback
1829−-
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 "")
1835−+
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
1838−+--
1839−+-- @menu= do
1840−+-- mop <- getGoStraighTo
1841−+-- case mop of
1842−+-- Just goop -> goop
1843−+-- Nothing -> do
1844−+-- r \<- `ask` option1 \<|> option2
1845−+-- case r of
1846−+-- op1 -> setGoStraighTo (Just goop1) >> goop1
1847−+-- op2 -> setGoStraighTo (Just goop2) >> goop2@
1848−+--
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
1852−+--
1853−+-- @menu= do
1854−+-- mop <- getGoStraighTo
1855−+-- back <- `goingBack`
1856−+-- case (mop,back) of
1857−+-- (Just goop,False) -> goop
1858−+-- _ -> do
1859−+-- r \<- `ask` option1 \<|> option2
1860−+-- case r of
1861−+-- op1 -> setGoStraighTo (Just goop1) >> goop1
1862−+-- op2 -> setGoStraighTo (Just goop2) >> goop2@
1863−+--
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
1868−+goingBack = do
1869−+ st <- get
1870−+ return $ not (inSync st) && not (newAsk st)
1871−+
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
1875−+--
1876−+-- It is useful when an undoable transaction has been commited. For example, after a payment.
1877−+--
1878−+-- This example show a message when the user go back and press again to pay
1879−+--
1880−+-- > ask $ wlink () << b << "press here to pay 100000 $ "
1881−+-- > payIt
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"
1885−+-- > where
1886−+-- > payIt= liftIO $ print "paying"
1887−+
1888−+preventGoingBack
1889−+ :: ( Functor m, MonadIO m, FormInput v) => FlowM v m () -> FlowM v m ()
1890−+preventGoingBack msg= do
1891−+ back <- goingBack
1892−+ if not back then breturn() else do
1893−+ breturn() -- will not go back beyond this
1894−+ clearEnv
1895−+ modify $ \s -> s{newAsk= True}
1896−+ msg
1897−+
1898−+
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
1903−+ back <- goingBack
1904−+ case back of
1905−+ False -> (lift doit) >>= breturn
1906−+ True -> onback
1907−+
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 "")
1913−
1914−
1915− --orElse :: FormInput v => FlowM v IO a -> FlowM v IO a -> FlowM v IO a
1916−@@ -595,91 +627,96 @@
1917− -- case mr of
1918− -- Nothing -> retry
1919− -- Just v -> return v
1920−-
1921−+
1922− type Lang= String
1923−
1924−-needForm1 st= case needForm st of
1925−- HasForm -> False
1926−- HasElems -> True
1927−- NoElems -> False
1928−-
1929−-data NeedForm= HasForm | HasElems | NoElems deriving Show
1930−-
1931−-data MFlowState view= MFlowState{
1932−- mfSequence :: Int,
1933−- mfCached :: Bool,
1934−- newAsk :: Bool,
1935−- inSync :: Bool,
1936−- mfLang :: Lang,
1937−- mfEnv :: Params,
1938−- needForm :: NeedForm,
1939−- mfToken :: Token,
1940−- mfkillTime :: Int,
1941−- mfSessionTime :: Integer,
1942−- mfCookies :: [Cookie],
1943−- mfHttpHeaders :: [(SB.ByteString,SB.ByteString)],
1944−- mfHeader :: view -> view,
1945−- mfDebug :: Bool,
1946−- mfRequirements :: [Requirement],
1947−- mfData :: M.Map TypeRep Void,
1948−- mfAjax :: Maybe (M.Map String Void),
1949−- mfSeqCache :: Int,
1950−- notSyncInAction :: Bool,
1951−-
1952−- -- Link management
1953−+--needForm1 st= case needForm st of
1954−+-- HasForm -> False
1955−+-- HasElems _ -> True
1956−+-- NoElems -> False
1957−+
1958−+
1959−+
1960−+data NeedForm= HasForm | HasElems | NoElems deriving Show
1961−+
1962−+data MFlowState view= MFlowState{
1963−+ mfSequence :: Int,
1964−+ mfCached :: Bool,
1965−+ newAsk :: Bool,
1966−+ inSync :: Bool,
1967−+ mfLang :: Lang,
1968−+ mfEnv :: Params,
1969−+ needForm :: NeedForm,
1970−+ mfFileUpload :: Bool,
1971−+ mfToken :: Token,
1972−+ mfkillTime :: Int,
1973−+ mfSessionTime :: Integer,
1974−+ mfCookies :: [Cookie],
1975−+ mfHttpHeaders :: [(SB.ByteString,SB.ByteString)],
1976−+ mfHeader :: view -> view,
1977−+ mfDebug :: Bool,
1978−+ mfRequirements :: [Requirement],
1979−+ mfInstalledScripts :: [WebRequirement],
1980−+ mfData :: M.Map TypeRep Void,
1981−+ mfAjax :: Maybe (M.Map String Void),
1982−+ mfSeqCache :: Int,
1983−+ notSyncInAction :: Bool,
1984−+
1985−+ -- Link management
1986− mfPath :: [String],
1987−- mfPagePath :: [String],
1988−- mfPrefix :: String,
1989−--- mfPIndex :: Int,
1990−- mfPageFlow :: Bool,
1991−+ mfPagePath :: [String],
1992−+ mfPrefix :: String,
1993−+-- mfPIndex :: Int,
1994−+ mfPageFlow :: Bool,
1995− linkMatched :: Bool,
1996−--- mfPendingPath :: [String],
1997−-
1998−-
1999−- mfAutorefresh :: Bool,
2000−- mfTrace :: [String],
2001−- mfClear :: Bool
2002−- }
2003−- deriving Typeable
2004−-
2005−-type Void = Char
2006−-
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
2011−-
2012−-
2013−--- | Set user-defined data in the context of the session.
2014−---
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.
2017−---
2018−--- This example define @addHistory@ and @getHistory@ to maintain a Html log in the session of a Flow:
2019−---
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
2026−-
2027−-setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a -> m ()
2028−-setSessionData x=
2029−- modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)}
2030−-
2031−-delSessionData x=
2032−- modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
2033−-
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],
2044−+
2045−+
2046−+ mfAutorefresh :: Bool,
2047−+ mfTrace :: [String],
2048−+ mfClear :: Bool
2049−+ }
2050−+ deriving Typeable
2051−+
2052−+type Void = Char
2053−+
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
2059−+
2060−+
2061−+-- | Set user-defined data in the context of the session.
2062−+--
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.
2065−+--
2066−+-- This example define @addHistory@ and @getHistory@ to maintain a Html log in the session of a Flow:
2067−+--
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
2074−+
2075−+setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a -> m ()
2076−+setSessionData x=
2077−+ modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)}
2078−+
2079−+delSessionData x=
2080−+ modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
2081−+
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
2091−
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
2098−-
2099−--- | Return the user language. Now it is fixed to "en"
2100−-getLang :: MonadState (MFlowState view) m => m String
2101−-getLang= gets mfLang
2102−-
2103−-getToken :: MonadState (MFlowState view) m => m Token
2104−-getToken= gets mfToken
2105−-
2106−-
2107−--- get a parameter form the las received response
2108−-getEnv :: MonadState (MFlowState view) m => m Params
2109−-getEnv = gets mfEnv
2110−-
2111−-stdHeader v = v
2112−-
2113−-
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
2116−---
2117−--- This header uses XML trough Haskell Server Pages (<http://hackage.haskell.org/package/hsp>)
2118−---
2119−--- @
2120−--- setHeader $ \c ->
2121−--- \<html\>
2122−--- \<head\>
2123−--- \<title\> my title \</title\>
2124−--- \<meta name= \"Keywords\" content= \"sci-fi\" /\>)
2125−--- \</head\>
2126−--- \<body style= \"margin-left:5%;margin-right:5%\"\>
2127−--- \<% c %\>
2128−--- \</body\>
2129−--- \</html\>
2130−--- @
2131−---
2132−--- This header uses "Text.XHtml"
2133−---
2134−--- @
2135−--- setHeader $ \c ->
2136−--- `thehtml`
2137−--- << (`header`
2138−--- << (`thetitle` << title +++
2139−--- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++
2140−--- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c
2141−--- @
2142−---
2143−--- This header uses both. It uses byteString tags
2144−---
2145−--- @
2146−--- setHeader $ \c ->
2147−--- `bhtml` [] $
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
2152−--- @
2153−---
2154−-setHeader :: MonadState (MFlowState view) m => (view -> view) -> m ()
2155−-setHeader header= do
2156−- fs <- get
2157−- put fs{mfHeader= header}
2158−-
2159−-
2160−-
2161−--- | Return the current header
2162−-getHeader :: ( Monad m) => FlowM view m (view -> view)
2163−-getHeader= gets mfHeader
2164−-
2165−--- | Add another header embedded in the previous one
2166−-addHeader new= do
2167−- fhtml <- getHeader
2168−- setHeader $ fhtml . new
2169−-
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
2176−- -> m ()
2177−-setCookie n v p me=
2178−- modify $ \st -> st{mfCookies= (UnEncryptedCookie
2179−- ( SB.fromString n,
2180−- SB.fromString v,
2181−- SB.fromString p,
2182−- fmap (SB.fromString . show) me)):mfCookies st }
2183−-
2184−-setParanoidCookie :: MonadState (MFlowState view) m
2185−- => String -- ^ name
2186−- -> String -- ^ value
2187−- -> String -- ^ path
2188−+
2189−+-- | Return the user language. Now it is fixed to "en"
2190−+getLang :: MonadState (MFlowState view) m => m String
2191−+getLang= gets mfLang
2192−+
2193−+getToken :: MonadState (MFlowState view) m => m Token
2194−+getToken= gets mfToken
2195−+
2196−+
2197−+-- get a parameter form the las received response
2198−+getEnv :: MonadState (MFlowState view) m => m Params
2199−+getEnv = gets mfEnv
2200−+
2201−+stdHeader v = v
2202−+
2203−+
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
2206−+--
2207−+-- This header uses XML trough Haskell Server Pages (<http://hackage.haskell.org/package/hsp>)
2208−+--
2209−+-- @
2210−+-- setHeader $ \c ->
2211−+-- \<html\>
2212−+-- \<head\>
2213−+-- \<title\> my title \</title\>
2214−+-- \<meta name= \"Keywords\" content= \"sci-fi\" /\>)
2215−+-- \</head\>
2216−+-- \<body style= \"margin-left:5%;margin-right:5%\"\>
2217−+-- \<% c %\>
2218−+-- \</body\>
2219−+-- \</html\>
2220−+-- @
2221−+--
2222−+-- This header uses "Text.XHtml"
2223−+--
2224−+-- @
2225−+-- setHeader $ \c ->
2226−+-- `thehtml`
2227−+-- << (`header`
2228−+-- << (`thetitle` << title +++
2229−+-- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++
2230−+-- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c
2231−+-- @
2232−+--
2233−+-- This header uses both. It uses byteString tags
2234−+--
2235−+-- @
2236−+-- setHeader $ \c ->
2237−+-- `bhtml` [] $
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
2242−+-- @
2243−+--
2244−+setHeader :: MonadState (MFlowState view) m => (view -> view) -> m ()
2245−+setHeader header= do
2246−+ fs <- get
2247−+ put fs{mfHeader= header}
2248−+
2249−+
2250−+
2251−+-- | Return the current header
2252−+getHeader :: ( Monad m) => FlowM view m (view -> view)
2253−+getHeader= gets mfHeader
2254−+
2255−+-- | Add another header embedded in the previous one
2256−+addHeader new= do
2257−+ fhtml <- getHeader
2258−+ setHeader $ fhtml . new
2259−+
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
2266−+ -> m ()
2267−+setCookie n v p me=
2268−+ modify $ \st -> st{mfCookies= (UnEncryptedCookie
2269−+ ( SB.fromString n,
2270−+ SB.fromString v,
2271−+ SB.fromString p,
2272−+ fmap (SB.fromString . show) me)):mfCookies st }
2273−+
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
2279−- -> m ()
2280−-setParanoidCookie n v p me = setEncryptedCookie' n v p me paranoidEncryptCookie
2281−+ -> m ()
2282−+setParanoidCookie n v p me = setEncryptedCookie' n v p me paranoidEncryptCookie
2283−
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
2293−- -> m ()
2294−-setEncryptedCookie n v p me = setEncryptedCookie' n v p me encryptCookie
2295−-
2296−-setEncryptedCookie' n v p me encFunc=
2297−- modify $ \st -> st{mfCookies =
2298−- (unsafePerformIO $ encFunc
2299−- ( SB.fromString n,
2300−- SB.fromString v,
2301−- SB.fromString p,
2302−- fmap (SB.fromString . show) me)):mfCookies st }
2303−-
2304−--- | Set an HTTP Response header
2305−-setHttpHeader :: MonadState (MFlowState view) m
2306−- => SB.ByteString -- ^ name
2307−- -> SB.ByteString -- ^ value
2308−- -> m ()
2309−-setHttpHeader n v =
2310−- modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (n,v):mfHttpHeaders st}
2311−-
2312−-
2313−--- | Set
2314−--- 1) the timeout of the flow execution since the last user interaction.
2315−--- Once passed, the flow executes from the begining.
2316−---
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.
2320−---
2321−--- As the other state primitives, it can be run in the Flow and in the View monad
2322−---
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
2328−- fs <- get
2329−- put fs{ mfkillTime= kt, mfSessionTime= st}
2330−-
2331−-
2332−-getWFName :: MonadState (MFlowState view) m => m String
2333−-getWFName = do
2334−- fs <- get
2335−- return . twfname $ mfToken fs
2336−-
2337−-getCurrentUser :: MonadState (MFlowState view) m => m String
2338−-getCurrentUser = do
2339−- st<- gets mfToken
2340−- return $ tuser st
2341−-
2342−-type Name= String
2343−-type Type= String
2344−-type Value= String
2345−-type Checked= Bool
2346−-type OnClick= Maybe String
2347−-
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')
2352−-
2353−-
2354−-
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
2378−-
2379−-
2380−-
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
2383−-
2384−---instance Executable (View v m) where
2385−--- execute f = execute $ evalStateT f mFlowState0
2386−-
2387−-
2388−---instance (Monad m, Executable m, Monoid view, FormInput view)
2389−--- => Executable (StateT (MFlowState view) m) where
2390−--- execute f= execute $ evalStateT f mFlowState0
2391−-
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.
2396−---
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.
2399−---
2400−--- @
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\"
2407−--- time
2408−--- @
2409−---
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.
2412−---
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
2425−+ -> m ()
2426−+setEncryptedCookie n v p me = setEncryptedCookie' n v p me encryptCookie
2427−+
2428−+setEncryptedCookie' n v p me encFunc=
2429−+ modify $ \st -> st{mfCookies =
2430−+ (unsafePerformIO $ encFunc
2431−+ ( SB.fromString n,
2432−+ SB.fromString v,
2433−+ SB.fromString p,
2434−+ fmap (SB.fromString . show) me)):mfCookies st }
2435−+
2436−+-- | Set an HTTP Response header
2437−+setHttpHeader :: MonadState (MFlowState view) m
2438−+ => SB.ByteString -- ^ name
2439−+ -> SB.ByteString -- ^ value
2440−+ -> m ()
2441−+setHttpHeader n v =
2442−+ modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (n,v):mfHttpHeaders st}
2443−+
2444−+
2445−+-- | Set
2446−+-- 1) the timeout of the flow execution since the last user interaction.
2447−+-- Once passed, the flow executes from the begining.
2448−+--
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.
2452−+--
2453−+-- As the other state primitives, it can be run in the Flow and in the View monad
2454−+--
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
2460−+ fs <- get
2461−+ put fs{ mfkillTime= kt, mfSessionTime= st}
2462−+
2463−+
2464−+getWFName :: MonadState (MFlowState view) m => m String
2465−+getWFName = do
2466−+ fs <- get
2467−+ return . twfname $ mfToken fs
2468−+
2469−+getCurrentUser :: MonadState (MFlowState view) m => m String
2470−+getCurrentUser = do
2471−+ st<- gets mfToken
2472−+ return $ tuser st
2473−+
2474−+type Name= String
2475−+type Type= String
2476−+type Value= String
2477−+type Checked= Bool
2478−+type OnClick= Maybe String
2479−+
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')
2484−+
2485−+
2486−+
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
2510−+
2511−+
2512−+
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
2515−+
2516−+--instance Executable (View v m) where
2517−+-- execute f = execute $ evalStateT f mFlowState0
2518−+
2519−+
2520−+--instance (Monad m, Executable m, Monoid view, FormInput view)
2521−+-- => Executable (StateT (MFlowState view) m) where
2522−+-- execute f= execute $ evalStateT f mFlowState0
2523−+
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.
2528−+--
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.
2531−+--
2532−+-- @
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\"
2539−+-- time
2540−+-- @
2541−+--
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.
2544−+--
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
2557− ,mfPath= mfPath 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'')
2566−-
2567−- -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2))
2568−- where
2569−- proc mf s= runStateT (runView mf) s >>= \(r,_) -> mfSeqCache s `seq` return (r,mfSeqCache s )
2570−-
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
2579−-
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.
2585−---
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})
2596−- where
2597−- proc mf s= do
2598−- (r,s) <- runStateT (runView mf) s
2599−- return (r,mfRequirements s, mfSeqCache s, mfAjax s)
2600−-
2601−-
2602−-
2603−-{- | Execute the Flow, in the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`
2604−-`waiMessageFlow` or `addMessageFlows`
2605−-
2606−-The flow is executed in a loop. When the flow is finished, it is started again
2607−-
2608−-@main= do
2609−- addMessageFlows [(\"noscript\",transient $ runFlow mainf)]
2610−- forkIO . run 80 $ waiMessageFlow
2611−- adminLoop
2612−-@
2613−--}
2614−-runFlow :: (FormInput view, MonadIO m)
2615−- => FlowM view (Workflow m) () -> Token -> Workflow m ()
2616−-runFlow f t=
2617−- loop (startState t) f t
2618−- where
2619−- loop s f t = do
2620−- (mt,s) <- runFlowOnce2 s f
2621−- let t'= fromFailBack mt
2622−- let t''= t'{tpath=[twfname t']}
2623−- liftIO $ do
2624−- flushRec t''
2625−+
2626−+ -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2))
2627−+ where
2628−+ proc mf s= runStateT (runView mf) s >>= \(r,_) -> mfSeqCache s `seq` return (r,mfSeqCache s )
2629−+
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
2638−+
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.
2644−+--
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})
2655−+ where
2656−+ proc mf s= do
2657−+ (r,s) <- runStateT (runView mf) s
2658−+ return (r,mfRequirements s, mfSeqCache s, mfAjax s)
2659−+
2660−+
2661−+
2662−+{- | Execute the Flow, in the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`
2663−+`waiMessageFlow` or `addMessageFlows`
2664−+
2665−+The flow is executed in a loop. When the flow is finished, it is started again
2666−+
2667−+@main= do
2668−+ addMessageFlows [(\"noscript\",transient $ runFlow mainf)]
2669−+ forkIO . run 80 $ waiMessageFlow
2670−+ adminLoop
2671−+@
2672−+-}
2673−+runFlow :: (FormInput view, MonadIO m)
2674−+ => FlowM view (Workflow m) () -> Token -> Workflow m ()
2675−+runFlow f t=
2676−+ loop (startState t) f t
2677−+ where
2678−+ loop s f t = do
2679−+ (mt,s) <- runFlowOnce2 s f
2680−+ let t'= fromFailBack mt
2681−+ let t''= t'{tpath=[twfname t']}
2682−+ liftIO $ do
2683−+ flushRec t''
2684− sendToMF t'' 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"
2689−-
2690−-inRecovery= -1
2691−-
2692−-runFlowOnce :: (FormInput view, MonadIO m)
2693−- => FlowM view (Workflow m) () -> Token -> Workflow m ()
2694−-runFlowOnce f t= runFlowOnce1 f t >> return ()
2695−-
2696−-runFlowOnce1 f t = runFlowOnce2 (startState t) f
2697−-
2698−+ _ -> s{mfPath=[twfname t],mfPagePath=[],mfEnv=[]}
2699−+ loop s' f t''{tpath=[]} -- !> "LOOPAGAIN"
2700−+
2701−+inRecovery= -1
2702−+
2703−+runFlowOnce :: (FormInput view, MonadIO m)
2704−+ => FlowM view (Workflow m) () -> Token -> Workflow m ()
2705−+runFlowOnce f t= runFlowOnce1 f t >> return ()
2706−+
2707−+runFlowOnce1 f t = runFlowOnce2 (startState t) f
2708−+
2709− startState t= mFlowState0{mfToken=t
2710−- ,mfSequence= inRecovery
2711−- ,mfPath= tpath t
2712−+ ,mfSequence= inRecovery
2713−+ ,mfPath= tpath t
2714− ,mfEnv= tenv t
2715−- ,mfPagePath=[]}
2716−+ ,mfPagePath=[]}
2717−
2718−-runFlowOnce2 s f =
2719−- runStateT (runSup . runFlowM $ do
2720−- backInit
2721−- f
2722−- getToken) s
2723−-
2724−-
2725−- where
2726−- backInit= do
2727−- s <- get -- !> "BackInit"
2728−- case mfTrace s of
2729−+runFlowOnce2 s f =
2730−+ runStateT (runSup . runFlowM $ do
2731−+ backInit
2732−+ f
2733−+ getToken) s
2734−+
2735−+
2736−+ where
2737−+ backInit= do
2738−+ s <- get -- !> "BackInit"
2739−+ case mfTrace s of
2740− [] -> do
2741− let t = mfToken s
2742− back <- goingBack
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]}
2746− breturn ()
2747−-
2748−- tr -> error $ disp tr
2749−- where
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
2752−+
2753−+ tr -> error $ disp tr
2754−+ where
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
2757−
2758− runFlowOnceReturn
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)
2762−-
2763−-
2764−-
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)
2771−+
2772−+
2773−+
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.
2781−-runFlowIn
2782−- :: (MonadIO m,
2783−- FormInput view)
2784−- => String
2785−- -> FlowM view (Workflow IO) b
2786−- -> FlowM view m b
2787−-runFlowIn wf f= FlowM . Sup $ do
2788−- st <- get
2789−- let t = mfToken st
2790−- (r,st') <- liftIO $ exec1nc wf $ runFlow1 st f t
2791−- put st{mfPath= mfPath st'}
2792−- case r of
2793−- GoBack -> delWF wf ()
2794−- return r
2795−-
2796−- where
2797−- runFlow1 st f t= runStateT (runSup . runFlowM $ f) st
2798−-
2799−-
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
2803−-runFlowConf f = do
2804−- q <- liftIO newEmptyMVar -- `debug` (i++w++u)
2805−+-- defined configurations by means of persistent flows with web formularies.
2806−+runFlowIn
2807−+ :: (MonadIO m,
2808−+ FormInput view)
2809−+ => String
2810−+ -> FlowM view (Workflow IO) b
2811−+ -> FlowM view m b
2812−+runFlowIn wf f= FlowM . Sup $ do
2813−+ st <- get
2814−+ let t = mfToken st
2815−+ (r,st') <- liftIO $ exec1nc wf $ runFlow1 st f t
2816−+ put st{mfPath= mfPath st'}
2817−+ case r of
2818−+ GoBack -> delWF wf ()
2819−+ return r
2820−+
2821−+ where
2822−+ runFlow1 st f t= runStateT (runSup . runFlowM $ f) st
2823−+
2824−+
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
2828−+runFlowConf f = do
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 ()
2834−-
2835−+ block <- liftIO $ newMVar True
2836−+ let t= Token "" "" "" [] [] block q qr
2837−+ evalStateT (runSup . runFlowM $ f ) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return ()
2838−+
2839−
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
2843−-
2844−-
2845−--- | Clears the environment
2846−-clearEnv :: MonadState (MFlowState view) m => m ()
2847−-clearEnv= do
2848−- st <- get
2849−- put st{ mfEnv= []}
2850−-
2851−-
2852−-
2853−-instance (FormInput v,Serialize a)
2854−- => Serialize (a,MFlowState v) where
2855−- showp (x,s)= case mfDebug s of
2856−- False -> showp x
2857−- True -> showp(x, mfEnv s)
2858−- readp= choice[nodebug, debug]
2859−- where
2860−- nodebug= readp >>= \x -> return (x, mFlowState0{mfSequence= inRecovery})
2861−- debug= do
2862−- (x,env) <- readp
2863−- return (x,mFlowState0{mfEnv= env,mfSequence= inRecovery})
2864−-
2865−-
2866−-
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.
2870−-step
2871−- :: (Serialize a,
2872−- Typeable view,
2873−- FormInput view,
2874−- MonadIO m,
2875−- Typeable a) =>
2876−- FlowM view m a
2877−- -> FlowM view (Workflow m) a
2878−-step f= do
2879−- s <- get
2880−- flowM $ Sup $ do
2881−- (r,s') <- lift . WF.step $ runStateT (runSup $ runFlowM f) s
2882−-
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}
2885−- return r
2886−-
2887−--- | to execute transient flows as if they were persistent
2888−+
2889−+
2890−+-- | Clears the environment
2891−+clearEnv :: MonadState (MFlowState view) m => m ()
2892−+clearEnv= do
2893−+ st <- get
2894−+ put st{ mfEnv= []}
2895−+
2896−+
2897−+
2898−+instance (FormInput v,Serialize a)
2899−+ => Serialize (a,MFlowState v) where
2900−+ showp (x,s)= case mfDebug s of
2901−+ False -> showp x
2902−+ True -> showp(x, mfEnv s)
2903−+ readp= choice[nodebug, debug]
2904−+ where
2905−+ nodebug= readp >>= \x -> return (x, mFlowState0{mfSequence= inRecovery})
2906−+ debug= do
2907−+ (x,env) <- readp
2908−+ return (x,mFlowState0{mfEnv= env,mfSequence= inRecovery})
2909−+
2910−+
2911−+
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.
2915−+step
2916−+ :: (Serialize a,
2917−+ Typeable view,
2918−+ FormInput view,
2919−+ MonadIO m,
2920−+ Typeable a) =>
2921−+ FlowM view m a
2922−+ -> FlowM view (Workflow m) a
2923−+step f= do
2924−+ s <- get
2925−+ FlowM $ Sup $ do
2926−+ (r,s') <- lift . WF.step $ runStateT (runSup $ runFlowM f) s
2927−+
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}
2930−+ return r
2931−+
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.
2936−---
2937−--- > transient $ runFlow f === runFlow $ transientNav f
2938−-transientNav
2939−- :: (Serialize a,
2940−- Typeable view,
2941−- FormInput view,
2942−- Typeable a) =>
2943−- FlowM view IO a
2944−- -> FlowM view (Workflow IO) a
2945−-transientNav f= do
2946−- s <- get
2947−- flowM $ Sup $ do
2948−- (r,s') <- lift . unsafeIOtoWF $ runStateT (runSup $ runFlowM f) s
2949−- put s'
2950−- return r
2951−-
2952−---stepWFRef
2953−--- :: (Serialize a,
2954−--- Typeable view,
2955−--- FormInput view,
2956−--- MonadIO m,
2957−--- Typeable a) =>
2958−--- FlowM view m a
2959−--- -> FlowM view (Workflow m) (WFRef (FailBack a),a)
2960−---stepWFRef f= do
2961−--- s <- get
2962−--- flowM $ Sup $ do
2963−--- (r,s') <- lift . WF.stepWFRef $ runStateT (runSup $ runFlowM f) s
2964−--- -- when recovery of a workflow, the MFlow state is not considered
2965−--- when( mfSequence s' >0) $ put s'
2966−--- return r
2967−-
2968−---step f= do
2969−--- s <- get
2970−--- flowM $ Sup $ do
2971−--- (r,s') <- do
2972−--- (br,s') <- runStateT (runSup $ runFlowM f) s
2973−--- case br of
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'
2979−--- return r
2980−-
2981−-
2982−-
2983−---stepDebug
2984−--- :: (Serialize a,
2985−--- Typeable view,
2986−--- FormInput view,
2987−--- Monoid view,
2988−--- MonadIO m,
2989−--- Typeable a) =>
2990−--- FlowM view m a
2991−--- -> FlowM view (Workflow m) a
2992−---stepDebug f= Sup $ do
2993−--- s <- get
2994−--- (r, s') <- lift $ do
2995−--- (r',stat)<- do
2996−--- rec <- isInRecover
2997−--- case rec of
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''' )
3003−--- put s'
3004−--- return r
3005−-
3006−-
3007−-
3008−-data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)
3009−-
3010−-valToMaybe (Validated x)= Just x
3011−-valToMaybe _= Nothing
3012−-
3013−-isValidated (Validated x)= True
3014−-isValidated _= False
3015−-
3016−-fromValidated (Validated x)= x
3017−-fromValidated NoParam= error $ "fromValidated : NoParam"
3018−-fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s
3019−-
3020−-
3021−-
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.
3028−+--
3029−+-- > transient $ runFlow f === runFlow $ transientNav f
3030−+transientNav
3031−+ :: (Serialize a,
3032−+ Typeable view,
3033−+ FormInput view,
3034−+ Typeable a) =>
3035−+ FlowM view IO a
3036−+ -> FlowM view (Workflow IO) a
3037−+transientNav f= do
3038−+ s <- get
3039−+ FlowM $ Sup $ do
3040−+ (r,s') <- lift . unsafeIOtoWF $ runStateT (runSup $ runFlowM f) s
3041−+ put s'
3042−+ return r
3043−+
3044−+--stepWFRef
3045−+-- :: (Serialize a,
3046−+-- Typeable view,
3047−+-- FormInput view,
3048−+-- MonadIO m,
3049−+-- Typeable a) =>
3050−+-- FlowM view m a
3051−+-- -> FlowM view (Workflow m) (WFRef (FailBack a),a)
3052−+--stepWFRef f= do
3053−+-- s <- get
3054−+-- flowM $ Sup $ do
3055−+-- (r,s') <- lift . WF.stepWFRef $ runStateT (runSup $ runFlowM f) s
3056−+-- -- when recovery of a workflow, the MFlow state is not considered
3057−+-- when( mfSequence s' >0) $ put s'
3058−+-- return r
3059−+
3060−+--step f= do
3061−+-- s <- get
3062−+-- flowM $ Sup $ do
3063−+-- (r,s') <- do
3064−+-- (br,s') <- runStateT (runSup $ runFlowM f) s
3065−+-- case br of
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'
3071−+-- return r
3072−+
3073−+
3074−+
3075−+--stepDebug
3076−+-- :: (Serialize a,
3077−+-- Typeable view,
3078−+-- FormInput view,
3079−+-- Monoid view,
3080−+-- MonadIO m,
3081−+-- Typeable a) =>
3082−+-- FlowM view m a
3083−+-- -> FlowM view (Workflow m) a
3084−+--stepDebug f= Sup $ do
3085−+-- s <- get
3086−+-- (r, s') <- lift $ do
3087−+-- (r',stat)<- do
3088−+-- rec <- isInRecover
3089−+-- case rec of
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''' )
3095−+-- put s'
3096−+-- return r
3097−+
3098−+
3099−+
3100−+data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)
3101−+
3102−+valToMaybe (Validated x)= Just x
3103−+valToMaybe _= Nothing
3104−+
3105−+isValidated (Validated x)= True
3106−+isValidated _= False
3107−+
3108−+fromValidated (Validated x)= x
3109−+fromValidated NoParam= error $ "fromValidated : NoParam"
3110−+fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s
3111−+
3112−+
3113−+
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
3119−
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)
3124−- => m (Maybe a)
3125−-getRestParam= do
3126−- st <- get
3127−- let lpath = mfPath st
3128−+ => m (Maybe a)
3129−+getRestParam= do
3130−+ st <- get
3131−+ let lpath = mfPath st
3132− if linkMatched 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
3138−- Just xs ->
3139−- case stripPrefix (mfPrefix st) (head xs) of
3140−- Nothing -> return Nothing
3141−- Just name -> do
3142−- r <- fmap valToMaybe $ readParam name
3143−- when (isJust r) $ modify $ \s -> s{inSync= True
3144−- ,linkMatched= True
3145−- ,mfPagePath= mfPagePath s++[name]}
3146−- return r
3147−-
3148−+ Just [] -> return Nothing
3149−+ Just xs -> do
3150−+-- case stripPrefix (mfPrefix st) (head xs) of
3151−+-- Nothing -> return Nothing
3152−+-- Just name ->
3153−+ let name= head xs
3154−+ r <- fmap valToMaybe $ readParam name
3155−+ when (isJust r) $ modify $ \s -> s{inSync= True
3156−+ ,linkMatched= True
3157−+ ,mfPagePath= mfPagePath s++[name]}
3158−+ return r
3159−+
3160−
3161−
3162− -- | return the value of a post or get param in the form ?param=value¶m2=value2...
3163−@@ -1246,31 +1284,31 @@
3164− st <- get
3165− r <- getParam1 par $ mfEnv st
3166− return $ valToMaybe r
3167−-
3168−-readParam :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
3169−- => String -> m (ParamResult v a)
3170−-readParam x1 = r
3171−- where
3172−- r= do
3173−- modify $ \s -> s{inSync= True}
3174−- maybeRead x1
3175−-
3176−- getType :: m (ParamResult v a) -> a
3177−- getType= undefined
3178−- x= getType r
3179−- maybeRead str= do
3180−- let typeofx = typeOf x
3181−+
3182−+readParam :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
3183−+ => String -> m (ParamResult v a)
3184−+readParam x1 = r
3185−+ where
3186−+ r= do
3187−+ modify $ \s -> s{inSync= True}
3188−+ maybeRead x1
3189−+
3190−+ getType :: m (ParamResult v a) -> a
3191−+ getType= undefined
3192−+ x= getType r
3193−+ maybeRead str= do
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
3201−- _ -> do
3202−- let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
3203−- return $ NotValidated str err
3204−-
3205−-
3206−+ return . Validated . unsafeCoerce $ T.pack str
3207−+ else case readsPrec 0 $ str of
3208−+ [(x,"")] -> return $ Validated x
3209−+ _ -> do
3210−+ let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
3211−+ return $ NotValidated str err
3212−+
3213−+
3214− ---- Requirements
3215−
3216−
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.
3221−+
3222−+
3223− requires rs =do
3224− st <- get
3225− let l = mfRequirements st
3226−--- let rs'= map Requirement rs \\ l
3227− put st {mfRequirements= l ++ map Requirement rs}
3228−
3229−-
3230−+unfold (JScriptFile f ss)= JScript loadScript:map (\s-> JScriptFile f [s]) ss
3231−+unfold x= [x]
3232−
3233− data Requirement= forall a.(Show a,Typeable a,Requirements a) => Requirement a deriving Typeable
3234−
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
3238−
3239− instance Show Requirement where
3240− show (Requirement a)= show a ++ "\n"
3241−
3242−-installAllRequirements :: ( Monad m, FormInput view) => WState view m view
3243−+installAllRequirements :: ( MonadIO m, FormInput view) => WState view m view
3244− installAllRequirements= do
3245− st <- get
3246− let rs = mfRequirements st
3247−- auto = mfAutorefresh st
3248−- installAllRequirements1 auto mempty rs
3249−+ installAllRequirements1 mempty rs
3250−+
3251− where
3252−
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''
3262− where
3263− installRequirements2 []= return $ fromStrNoEncode ""
3264−- installRequirements2 (Requirement r:rs)= installRequirements auto $ r:unmap rs
3265−+ installRequirements2 (Requirement r:rs)= installRequirements $ r:unmap rs
3266− unmap []=[]
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)
3271− else (ts, x:fs)
3272−
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"
3282−+
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);};"
3291−- ++ onload
3292−- where
3293−- onload= case lcallbacks of
3294−- [] -> ""
3295−- cs -> "fileref.onload = function() {"++ (concat $ nub cs)++"};"
3296−-
3297−-
3298−-loadjs content= content
3299−-
3300−-
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);"
3307−-
3308−-
3309−-loadcss content=
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);"
3315−-
3316−-
3317−-data WebRequirement= JScriptFile
3318−- String
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)
3325−-
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;\
3336−+ \} else {\
3337−+ \elem.onload = function() {\
3338−+ \if (oldonload) {\
3339−+ \oldonload();\
3340−+ \}\
3341−+ \func();\
3342−+ \}\
3343−+ \}\
3344−+ \}"
3345−+
3346−+loadCallback depend script=
3347−+ let varname= addrStr depend in
3348−+ "\naddLoadEvent("++varname++",function(){"++ script++"});"
3349−+
3350−+
3351−+
3352−+
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);"
3359−+
3360−+
3361−+loadcss content=
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);"
3367−+
3368−+
3369−+data WebRequirement= JScriptFile
3370−+ String
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)
3377−+
3378−+instance Eq (String, Flow) where
3379− (x,_) == (y,_)= x == y
3380−-
3381−-instance Ord (String, Flow) where
3382−- compare(x,_) (y,_)= compare x y
3383−-instance Show (String, Flow) where
3384−- show (x,_)= show x
3385−-
3386−-instance Requirements WebRequirement where
3387−- installRequirements= installWebRequirements
3388−-
3389−-
3390−-
3391−-installWebRequirements :: (Monad m,FormInput view) => Bool -> [WebRequirement] -> m view
3392−-installWebRequirements auto rs= do
3393−- let s = jsRequirements auto $ sort rs
3394−-
3395−- return $ ftag "script" (fromStrNoEncode s)
3396−-
3397−-
3398−-jsRequirements _ []= ""
3399−-
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)
3403−-
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)
3407−-
3408−-
3409−-
3410−-
3411−-jsRequirements auto (r:r':rs)
3412−- | r== r' = jsRequirements auto $ r:rs
3413−- | otherwise= strRequirement r ++ jsRequirements auto (r':rs)
3414−-
3415−-jsRequirements auto (r:rs)= strRequirement r++jsRequirements auto rs
3416−-
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` ""
3422−-
3423−-
3424−-
3425−-
3426−-
3427−---- AJAX ----
3428−-ajaxScript=
3429−- "function loadXMLObj()" ++
3430−- "{" ++
3431−- "var xmlhttp;" ++
3432−- "if (window.XMLHttpRequest)" ++
3433−- "{"++
3434−- " xmlhttp=new XMLHttpRequest();" ++
3435−- " }" ++
3436−- "else" ++
3437−- "{"++
3438−- " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++
3439−- " }" ++
3440−- "return xmlhttp" ++
3441−- "};" ++
3442−-
3443−- " xmlhttp= loadXMLObj();" ++
3444−- " noparam= '';"++
3445−- ""++
3446−- "function doServer (servproc,param,param2){" ++
3447−- " xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++
3448−- " xmlhttp.send();};" ++
3449−- ""++
3450−- "xmlhttp.onreadystatechange=function()" ++
3451−- " {" ++
3452−- " if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++
3453−- " {" ++
3454−- " eval(xmlhttp.responseText);" ++
3455−- " }" ++
3456−- " };" ++
3457−- ""
3458−-
3459−-formPrefix st form anchored= do
3460−+
3461−+instance Ord (String, Flow) where
3462−+ compare(x,_) (y,_)= compare x y
3463−+instance Show (String, Flow) where
3464−+ show (x,_)= show x
3465−+
3466−+instance Requirements WebRequirement where
3467−+ installRequirements= installWebRequirements
3468−+
3469−+
3470−+
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
3476−+
3477−+ strs <- mapM strRequirement rs' -- !>( "OLD="++show installed) !> ("new="++show rs')
3478−+ case null strs of
3479−+ True -> return mempty
3480−+ False -> return . ftag "script" . fromStrNoEncode $ concat strs
3481−+
3482−+
3483−+strRequirement r=do
3484−+ r1 <- strRequirement' r
3485−+ modify $ \st -> st{mfInstalledScripts= mfInstalledScripts st ++ [r]}
3486−+ return r1
3487−+
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
3498−+ ([],_) ->
3499−+ -- no script file has been loaded previously
3500−+ return $ loadScript <> loadjsfile file <> concatMap(loadCallback file) scripts
3501−+ (_,Just _) -> do
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
3507−+ -- already loaded
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
3511−+
3512−+
3513−+strRequirement' (JScript scr) = return scr
3514−+strRequirement' (ServerProc f)= do
3515−+ liftIO $ addMessageFlows [f]
3516−+ return ""
3517−+
3518−+
3519−+
3520−+
3521−+
3522−+--- AJAX ----
3523−+ajaxScript=
3524−+ "function loadXMLObj()" ++
3525−+ "{" ++
3526−+ "var xmlhttp;" ++
3527−+ "if (window.XMLHttpRequest)" ++
3528−+ "{"++
3529−+ " xmlhttp=new XMLHttpRequest();" ++
3530−+ " }" ++
3531−+ "else" ++
3532−+ "{"++
3533−+ " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++
3534−+ " }" ++
3535−+ "return xmlhttp" ++
3536−+ "};" ++
3537−+
3538−+ " xmlhttp= loadXMLObj();" ++
3539−+ " noparam= '';"++
3540−+ ""++
3541−+ "function doServer (servproc,param,param2){" ++
3542−+ " xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++
3543−+ " xmlhttp.send();};" ++
3544−+ ""++
3545−+ "xmlhttp.onreadystatechange=function()" ++
3546−+ " {" ++
3547−+ " if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++
3548−+ " {" ++
3549−+ " eval(xmlhttp.responseText);" ++
3550−+ " }" ++
3551−+ " };" ++
3552−+ ""
3553−+
3554−+formPrefix st form anchored= do
3555− let verb = twfname $ mfToken st
3556−- path = currentPath st
3557−- (anchor,anchorf)
3558−- <- case anchored of
3559−- True -> do
3560−- anchor <- genNewId
3561−- return ('#':anchor, (ftag "a") mempty `attrs` [("name",anchor)])
3562−- False -> return (mempty,mempty)
3563−- return $ formAction (path ++ anchor ) $ anchorf <> form -- !> anchor
3564−-
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
3568−- st <- get
3569−- cont <- case needForm1 st of
3570−- True -> do
3571−- frm <- formPrefix st forms False
3572−- put st{needForm= HasForm}
3573−- return frm
3574−- _ -> return forms
3575−-
3576−- return $ FormElm cont mx
3577−+ path = currentPath st
3578−+ hasfile= mfFileUpload st
3579−+ attr= case hasfile of
3580−+ True -> [("enctype","multipart/form-data")]
3581−+ False -> []
3582−+ (anchor,anchorf)
3583−+ <- case anchored of
3584−+ True -> do
3585−+ anchor <- genNewId
3586−+ return ('#':anchor, (ftag "a") mempty `attrs` [("name",anchor)])
3587−+ False -> return (mempty,mempty)
3588−+ return $ formAction (path ++ anchor ) "POST" ( anchorf <> form ) `attrs` attr
3589−+
3590−+
3591−+
3592−+
3593−+
3594−+
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
3598−+ st <- get
3599−+ cont <- case needForm st of
3600−+ HasElems -> do
3601−+ frm <- formPrefix st forms False
3602−+ put st{needForm= HasForm}
3603−+ return frm
3604−+ _ -> return forms
3605−+
3606−+ return $ FormElm cont mx
3607−
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)
3613−
3614−- _ -> return (v1 <> v2, False)
3615−-
3616−-currentPath st= concat ['/':v| v <- mfPagePath st ]
3617−-
3618−--- | Generate a new string. Useful for creating tag identifiers and other attributes.
3619−---
3620−--- if the page is refreshed, the identifiers generated are the same.
3621−-genNewId :: MonadState (MFlowState view) m => m String
3622−-genNewId= do
3623−- st <- get
3624−- case mfCached st of
3625−- False -> do
3626−- let n= mfSequence st
3627−- prefseq= mfPrefix st
3628−- put $ st{mfSequence= n+1}
3629−-
3630−- return $ 'p':show n++prefseq
3631−- True -> do
3632−- let n = mfSeqCache st
3633−- put $ st{mfSeqCache=n+1}
3634−- return $ 'c' : (show n)
3635−-
3636−--- | get the next ideitifier that will be created by genNewId
3637−-getNextId :: MonadState (MFlowState view) m => m String
3638−-getNextId= do
3639−- st <- get
3640−- case mfCached st of
3641−- False -> do
3642−- let n= mfSequence st
3643−- prefseq= mfPrefix st
3644−- return $ 'p':show n++prefseq
3645−- True -> do
3646−- let n = mfSeqCache st
3647−- return $ 'c' : (show n)
3648−+ _ -> return (v1 <> v2, False)
3649−+
3650−+currentPath st= concat ['/':v| v <- mfPagePath st ]
3651−+
3652−+-- | Generate a new string. Useful for creating tag identifiers and other attributes.
3653−+--
3654−+-- if the page is refreshed, the identifiers generated are the same.
3655−+genNewId :: MonadState (MFlowState view) m => m String
3656−+genNewId= do
3657−+ st <- get
3658−+ case mfCached st of
3659−+ False -> do
3660−+ let n= mfSequence st
3661−+ prefseq= mfPrefix st
3662−+ put $ st{mfSequence= n+1}
3663−+
3664−+ return $ 'p':show n++prefseq
3665−+ True -> do
3666−+ let n = mfSeqCache st
3667−+ put $ st{mfSeqCache=n+1}
3668−+ return $ 'c' : (show n)
3669−+
3670−+-- | get the next ideitifier that will be created by genNewId
3671−+getNextId :: MonadState (MFlowState view) m => m String
3672−+getNextId= do
3673−+ st <- get
3674−+ case mfCached st of
3675−+ False -> do
3676−+ let n= mfSequence st
3677−+ prefseq= mfPrefix st
3678−+ return $ 'p':show n++prefseq
3679−+ True -> do
3680−+ let n = mfSeqCache st
3681−+ return $ 'c' : (show n)
3682−+
3683−
3684−
3685−-
3686−diff -ru orig/src/MFlow/Forms/Test.hs new/src/MFlow/Forms/Test.hs
3687−--- orig/src/MFlow/Forms/Test.hs 2014-06-10 05:51:26.977015856 +0300
3688−+++ new/src/MFlow/Forms/Test.hs 2014-06-10 05:51:25.000000000 +0300
3689−@@ -1,404 +1,404 @@
3690−------------------------------------------------------------------------------
3691−---
3692−--- Module : MFlow.Forms.Test
3693−--- Copyright :
3694−--- License : BSD3
3695−---
3696−--- Maintainer : agocorona@gmail.com
3697−--- Stability : experimental
3698−--- Portability :
3699−---
3700−--- |
3701−---
3702−------------------------------------------------------------------------------
3703−-{-# OPTIONS
3704−- -XOverlappingInstances
3705−- -XFlexibleInstances
3706−- -XUndecidableInstances
3707−- -XPatternGuards
3708−- -XRecordWildCards
3709−- #-}
3710−-
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
3720−-import MFlow
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)
3726−-import Data.List
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
3732−-import Data.Monoid
3733−-import Data.Maybe
3734−-import Data.IORef
3735−-import MFlow.Cookies(cookieuser)
3736−-
3737−-import Data.Dynamic
3738−-import Data.TCache.Memoization
3739−-
3740−-
3741−-
3742−-class Generate a where
3743−- generate :: IO a
3744−-
3745−-instance Generate a => Generate (Maybe a) where
3746−- generate= do
3747−- b <- randomRIO(0,1 :: Int)
3748−- case b of 0 -> generate >>= return . Just ; _ -> return Nothing
3749−-
3750−-instance Generate String where
3751−- generate= replicateM 5 $ randomRIO ('a','z')
3752−-
3753−-instance Generate Int where
3754−- generate= randomRIO(1,1000)
3755−-
3756−-instance Generate Integer where
3757−- generate= randomRIO(1,1000)
3758−-
3759−-
3760−-instance (Generate a, Generate b) => Generate (a,b) where
3761−- generate= fmap (,) generate `ap` generate
3762−-
3763−-
3764−-instance (Generate a, Generate b) => Generate (Maybe a,Maybe b) where
3765−- generate= do
3766−- r <- generate
3767−- case r of
3768−- (Nothing,Nothing) -> generate
3769−- other -> return other
3770−-
3771−-
3772−-instance (Bounded a, Enum a) => Generate a where
3773−- generate= mx
3774−- where
3775−- mx= do
3776−- let x= typeOfIO mx
3777−- n <- randomRIO ( fromEnum $ minBound `asTypeOf` x
3778−- , fromEnum $ maxBound `asTypeOf` x)
3779−- return $ toEnum n
3780−- where
3781−- typeOfIO :: IO a -> a
3782−- typeOfIO = undefined
3783−-
3784−--- | run a list of flows with a number of simultaneous threads
3785−-runTest :: [(Int, Flow)] -> IO ()
3786−-runTest ps= do
3787−- mapM_ (forkIO . run1) ps
3788−- putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads"
3789−-
3790−- where
3791−- run1 (nusers, proc) = replicateM_ nusers $ runTest1 proc
3792−-
3793−-runTest1 f = do
3794−- atomicModifyIORef testNumber (\n -> (n+1,n+1))
3795−- name <- generate
3796−- x <- generate
3797−- y <- generate
3798−+-----------------------------------------------------------------------------
3799−+--
3800−+-- Module : MFlow.Forms.Test
3801−+-- Copyright :
3802−+-- License : BSD3
3803−+--
3804−+-- Maintainer : agocorona@gmail.com
3805−+-- Stability : experimental
3806−+-- Portability :
3807−+--
3808−+-- |
3809−+--
3810−+-----------------------------------------------------------------------------
3811−+{-# OPTIONS
3812−+ -XOverlappingInstances
3813−+ -XFlexibleInstances
3814−+ -XUndecidableInstances
3815−+ -XPatternGuards
3816−+ -XRecordWildCards
3817−+ #-}
3818−+
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
3828−+import MFlow
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)
3834−+import Data.List
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
3840−+import Data.Monoid
3841−+import Data.Maybe
3842−+import Data.IORef
3843−+import MFlow.Cookies(cookieuser)
3844−+
3845−+import Data.Dynamic
3846−+import Data.TCache.Memoization
3847−+
3848−+
3849−+
3850−+class Generate a where
3851−+ generate :: IO a
3852−+
3853−+instance Generate a => Generate (Maybe a) where
3854−+ generate= do
3855−+ b <- randomRIO(0,1 :: Int)
3856−+ case b of 0 -> generate >>= return . Just ; _ -> return Nothing
3857−+
3858−+instance Generate String where
3859−+ generate= replicateM 5 $ randomRIO ('a','z')
3860−+
3861−+instance Generate Int where
3862−+ generate= randomRIO(1,1000)
3863−+
3864−+instance Generate Integer where
3865−+ generate= randomRIO(1,1000)
3866−+
3867−+
3868−+instance (Generate a, Generate b) => Generate (a,b) where
3869−+ generate= fmap (,) generate `ap` generate
3870−+
3871−+
3872−+instance (Generate a, Generate b) => Generate (Maybe a,Maybe b) where
3873−+ generate= do
3874−+ r <- generate
3875−+ case r of
3876−+ (Nothing,Nothing) -> generate
3877−+ other -> return other
3878−+
3879−+
3880−+instance (Bounded a, Enum a) => Generate a where
3881−+ generate= mx
3882−+ where
3883−+ mx= do
3884−+ let x= typeOfIO mx
3885−+ n <- randomRIO ( fromEnum $ minBound `asTypeOf` x
3886−+ , fromEnum $ maxBound `asTypeOf` x)
3887−+ return $ toEnum n
3888−+ where
3889−+ typeOfIO :: IO a -> a
3890−+ typeOfIO = undefined
3891−+
3892−+-- | run a list of flows with a number of simultaneous threads
3893−+runTest :: [(Int, Flow)] -> IO ()
3894−+runTest ps= do
3895−+ mapM_ (forkIO . run1) ps
3896−+ putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads"
3897−+
3898−+ where
3899−+ run1 (nusers, proc) = replicateM_ nusers $ runTest1 proc
3900−+
3901−+runTest1 f = do
3902−+ atomicModifyIORef testNumber (\n -> (n+1,n+1))
3903−+ name <- generate
3904−+ x <- generate
3905−+ y <- generate
3906− z <- generate
3907−-
3908−- let t = Token x y z [] [] undefined undefined undefined
3909−- WF.start name f t
3910−-
3911−-testNumber= unsafePerformIO $ newIORef 0
3912−-
3913−-getTestNumber :: MonadIO m => m Int
3914−-getTestNumber= liftIO $ readIORef testNumber
3915−-
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:
3918−---
3919−--- > ask something `inject` const someother
3920−---
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
3924−-inject exp v= do
3925−- n <- getTestNumber
3926−- if n== 0 then exp else exp `seq` return $ v n
3927−-
3928−--- | a simulated ask that generate simulated user input of the type expected.
3929−---
3930−--- It forces the web page rendering, since it is monadic and can contain
3931−--- side effects and load effects to be tested.
3932−---
3933−--- it is a substitute of 'ask' from "MFlow.Forms" for testing purposes.
3934−-
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
3937−-ask w = do
3938−- FormElm forms mx <- FlowM . lift $ runView w
3939−- r <- liftIO generate
3940−- let n= B.length $ toByteString forms
3941−- breturn $ n `seq` mx `seq` r
3942−--- let u= undefined
3943−--- liftIO $ runStateT (runView mf) s
3944−--- bool <- liftIO generate
3945−--- case bool of
3946−--- False -> fail ""
3947−--- True -> do
3948−--- b <- liftIO generate
3949−--- r <- liftIO generate
3950−--- case (b,r) of
3951−--- (True,x) -> breturn x
3952−--- _ -> ask w
3953−-
3954−-
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.
3957−---
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
3961−-askt v w = do
3962−- FormElm forms mx <- FlowM . lift $ runView w
3963−- n <- getTestNumber
3964−- let l= B.length $ toByteString forms
3965−- breturn $ l `seq` mx `seq` v n
3966−-
3967−---mvtestopts :: MVar (M.Map String (Int,Dynamic))
3968−---mvtestopts = unsafePerformIO $ newMVar M.empty
3969−-
3970−---asktn :: (Typeable a,MonadIO m) => [a] -> View v m a -> FlowM v m a
3971−---asktn xs w= do
3972−--- v <- liftIO $ do
3973−--- let k = addrStr xs
3974−--- opts <- takeMVar mvtestopts
3975−--- let r = M.lookup k opts
3976−--- case r of
3977−--- Nothing -> do
3978−--- putMVar mvtestopts $ M.singleton k (0,toDyn xs)
3979−--- return $ head xs
3980−--- Just (i,d) -> do
3981−--- putMVar mvtestopts $ M.insert k (i+1,d) opts
3982−--- return $ (fromMaybe (error err1) $ fromDynamic d) !! i
3983−---
3984−--- askt v w
3985−---
3986−--- where
3987−--- err1= "MFlow.Forms.Test: asktn: fromDynamic error"
3988−-
3989−-
3990−--- | verify a property. if not true, throw the error message.
3991−---
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:
3996−---
3997−--- > liftIO $ print (x :: Int) `verify` (return $ x > 10, "x < = 10")
3998−---
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
4002−- prop <- mprop
4003−- case prop of
4004−- True -> f
4005−- False -> error msg
4006−-
4007−--- | a pure version of verifyM
4008−-verify :: a -> (Bool, String) -> a
4009−-verify f (prop, msg)= do
4010−- case prop of
4011−- True -> f
4012−- False -> error msg
4013−-
4014−-
4015−---
4016−---match form=do
4017−--- marches <- readIORef matches
4018−--- return $ head map (m s) matches
4019−--- where
4020−--- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of
4021−--- True -> Just ps
4022−--- False -> Nothing
4023−---
4024−---composeParams (Gen ps) form= zip (getParams form) ps
4025−--- where
4026−--- getParams form=
4027−--- let search name form
4028−--- | null form = mempty
4029−--- | isPrefix name form = drop (length name) form
4030−--- | otherwise= search name $ tail form
4031−---
4032−--- par s= takeWhile(/='\"') . dropWhile (/='\"') . tail . dropWhile (/='=') $ s
4033−--- getPar= par $ search "name"
4034−--- in getPar form
4035−---
4036−-
4037−-waction :: (Functor m, MonadIO m,Generate a, FormInput view)
4038−- => View view m a
4039−- -> (a -> FlowM view m b)
4040−- -> View view m b
4041−-waction w f= do
4042−- x <- liftIO generate
4043−- MFlow.Forms.waction (return x) f
4044−-
4045−-userWidget :: ( MonadIO m, Functor m
4046−- , FormInput view)
4047−- => Maybe String
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
4057−-
4058−- where
4059−- login uname= do
4060−- st <- get
4061−- let t = mfToken st
4062−- t'= t{tuser= uname}
4063−- put st{mfToken= t'}
4064−- return ()
4065−-
4066−-getUserSimple :: ( MonadIO m, FormInput view, Typeable view
4067−- , Functor m)
4068−- => FlowM view m String
4069−-getUserSimple= getUser Nothing userFormLine
4070−-
4071−-
4072−-getUser :: ( FormInput view, Typeable view
4073−- , Functor m,MonadIO m)
4074−- => Maybe String
4075−- -> View view m (Maybe (String,String), Maybe String)
4076−- -> FlowM view m String
4077−-getUser mu form= ask $ userWidget mu form
4078−-
4079−---wmodify
4080−--- :: (Functor m, MonadIO m, FormInput v, Generate (Maybe a)) =>
4081−--- View v m a1
4082−--- -> ([v] -> Maybe a -> WState v m ([v], Maybe b))
4083−--- -> View v m b
4084−---wmodify formt act = do
4085−--- x <- liftIO generate
4086−--- formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act
4087−-
4088−-{-
4089−-type Var= String
4090−-data Test= Test{tflink:: [(Var,String)]
4091−- ,selectOptions :: [(Var,[String])]
4092−- ,tfinput :: [(Var, String)]
4093−- ,tftextarea :: [(Var, String)]
4094−- }
4095−- deriving(Read,Show)
4096−-
4097−-type TestM = Test -> Test
4098−-
4099−-instance Monoid TestM where
4100−- mempty= id
4101−- mappend= (.)
4102−-
4103−-instance FormInput TestM where
4104−- ftag = const id
4105−- inred = const id
4106−- fromStr = const id
4107−- flink var _= let(n,v)=break (=='=') var in \t ->t{tflink= (n,tail v):tflink t}
4108−- finput n _ v _ _ = \t -> t{tfinput = (n,v):tfinput t}
4109−- ftextarea n v= \t -> t{tftextarea = (n,v):tftextarea t}
4110−- fselect n _= \t -> t{selectOptions=(n,[]):selectOptions t}
4111−- foption o _ _= \t ->
4112−- let (n,opts)= head $ selectOptions t
4113−- in t{selectOptions=(n,o:opts):tail (selectOptions t)}
4114−- formAction _ _= id
4115−- addAttributes _ _= id
4116−-
4117−-generateGenerate Test{..}= do
4118−- b <- generate
4119−- case b of
4120−- True -> genLink
4121−- False -> genForm
4122−-
4123−- where
4124−- genForm= do
4125−- -- one on every generate is incomplete
4126−- n <- randomRIO(0,10) :: IO Int
4127−- case n of
4128−- 0 -> do
4129−- genInput
4130−-
4131−- _ -> do
4132−- r1 <- genInput
4133−- r2 <- genSelect
4134−- r3 <- genTextArea
4135−- return $ r1++r2++r3
4136−- genLink= do
4137−- let n = length tflink
4138−- if n == 0 then genForm
4139−- else do
4140−- r <- randomRIO(0,n )
4141−- return [tflink !! r]
4142−-
4143−- genSelect=do
4144−- let n = length selectOptions
4145−- if n== 0
4146−- then return []
4147−- else mapM gen selectOptions
4148−- where
4149−- gen(s,os)= do
4150−- let m = length os
4151−- j <- randomRIO(0,m)
4152−- return (s, os !! j)
4153−-
4154−- genInput= do
4155−- let n = length tftextarea
4156−- if n==0
4157−- then return []
4158−- else mapM gen tfinput
4159−- where gen(n,_)= do
4160−- str <- generate
4161−- return $ (n,str)
4162−-
4163−- genTextArea= do
4164−- let n = length tfinput
4165−- if n==0
4166−- then return []
4167−- else mapM gen tftextarea
4168−- where
4169−- gen(n,_)= do
4170−- str <- generate
4171−- return $ (n,str)
4172−-
4173−-pwf= "pwf"
4174−-ind= "ind"
4175−-instance Processable Params where
4176−- pwfname = fromMaybe noScript . lookup pwf
4177−- puser= fromMaybe anonymous . lookup cookieuser
4178−- pind = fromMaybe "0" . lookup ind
4179−- getParams = id
4180−-
4181−-
4182−-
4183−-runTest nusers = do
4184−- wfs <- getMessageFlows
4185−- replicateM nusers $ gen wfs
4186−- where
4187−- gen wfs = do
4188−- u <- generate
4189−- mapM (genTraffic u) $ M.toList wfs
4190−-
4191−- genTraffic u (n,_)= forkIO $ iterategenerates [(pwf,n),(cookieuser,u)] []
4192−-
4193−- iterategenerates ident msg= iterate [] msg
4194−- where
4195−- iterate cs msg= do
4196−- (HttpData ps cooks test,_) <- msgScheduler $ ident ++ cs++ msg
4197−- let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks
4198−- resp <- generateGenerate . read $ B.unpack test
4199−- iterate cs' resp
4200−-
4201−- -}
4202−+
4203−+ let t = Token x y z [] [] undefined undefined undefined
4204−+ WF.start name f t
4205−+
4206−+testNumber= unsafePerformIO $ newIORef 0
4207−+
4208−+getTestNumber :: MonadIO m => m Int
4209−+getTestNumber= liftIO $ readIORef testNumber
4210−+
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:
4213−+--
4214−+-- > ask something `inject` const someother
4215−+--
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
4219−+inject exp v= do
4220−+ n <- getTestNumber
4221−+ if n== 0 then exp else exp `seq` return $ v n
4222−+
4223−+-- | a simulated ask that generate simulated user input of the type expected.
4224−+--
4225−+-- It forces the web page rendering, since it is monadic and can contain
4226−+-- side effects and load effects to be tested.
4227−+--
4228−+-- it is a substitute of 'ask' from "MFlow.Forms" for testing purposes.
4229−+
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
4232−+ask w = do
4233−+ FormElm forms mx <- FlowM . lift $ runView w
4234−+ r <- liftIO generate
4235−+ let n= B.length $ toByteString forms
4236−+ breturn $ n `seq` mx `seq` r
4237−+-- let u= undefined
4238−+-- liftIO $ runStateT (runView mf) s
4239−+-- bool <- liftIO generate
4240−+-- case bool of
4241−+-- False -> fail ""
4242−+-- True -> do
4243−+-- b <- liftIO generate
4244−+-- r <- liftIO generate
4245−+-- case (b,r) of
4246−+-- (True,x) -> breturn x
4247−+-- _ -> ask w
4248−+
4249−+
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.
4252−+--
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
4256−+askt v w = do
4257−+ FormElm forms mx <- FlowM . lift $ runView w
4258−+ n <- getTestNumber
4259−+ let l= B.length $ toByteString forms
4260−+ breturn $ l `seq` mx `seq` v n
4261−+
4262−+--mvtestopts :: MVar (M.Map String (Int,Dynamic))
4263−+--mvtestopts = unsafePerformIO $ newMVar M.empty
4264−+
4265−+--asktn :: (Typeable a,MonadIO m) => [a] -> View v m a -> FlowM v m a
4266−+--asktn xs w= do
4267−+-- v <- liftIO $ do
4268−+-- let k = addrStr xs
4269−+-- opts <- takeMVar mvtestopts
4270−+-- let r = M.lookup k opts
4271−+-- case r of
4272−+-- Nothing -> do
4273−+-- putMVar mvtestopts $ M.singleton k (0,toDyn xs)
4274−+-- return $ head xs
4275−+-- Just (i,d) -> do
4276−+-- putMVar mvtestopts $ M.insert k (i+1,d) opts
4277−+-- return $ (fromMaybe (error err1) $ fromDynamic d) !! i
4278−+--
4279−+-- askt v w
4280−+--
4281−+-- where
4282−+-- err1= "MFlow.Forms.Test: asktn: fromDynamic error"
4283−+
4284−+
4285−+-- | verify a property. if not true, throw the error message.
4286−+--
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:
4291−+--
4292−+-- > liftIO $ print (x :: Int) `verify` (return $ x > 10, "x < = 10")
4293−+--
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
4297−+ prop <- mprop
4298−+ case prop of
4299−+ True -> f
4300−+ False -> error msg
4301−+
4302−+-- | a pure version of verifyM
4303−+verify :: a -> (Bool, String) -> a
4304−+verify f (prop, msg)= do
4305−+ case prop of
4306−+ True -> f
4307−+ False -> error msg
4308−+
4309−+
4310−+--
4311−+--match form=do
4312−+-- marches <- readIORef matches
4313−+-- return $ head map (m s) matches
4314−+-- where
4315−+-- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of
4316−+-- True -> Just ps
4317−+-- False -> Nothing
4318−+--
4319−+--composeParams (Gen ps) form= zip (getParams form) ps
4320−+-- where
4321−+-- getParams form=
4322−+-- let search name form
4323−+-- | null form = mempty
4324−+-- | isPrefix name form = drop (length name) form
4325−+-- | otherwise= search name $ tail form
4326−+--
4327−+-- par s= takeWhile(/='\"') . dropWhile (/='\"') . tail . dropWhile (/='=') $ s
4328−+-- getPar= par $ search "name"
4329−+-- in getPar form
4330−+--
4331−+
4332−+waction :: (Functor m, MonadIO m,Generate a, FormInput view)
4333−+ => View view m a
4334−+ -> (a -> FlowM view m b)
4335−+ -> View view m b
4336−+waction w f= do
4337−+ x <- liftIO generate
4338−+ MFlow.Forms.waction (return x) f
4339−+
4340−+userWidget :: ( MonadIO m, Functor m
4341−+ , FormInput view)
4342−+ => Maybe String
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
4352−+
4353−+ where
4354−+ login uname= do
4355−+ st <- get
4356−+ let t = mfToken st
4357−+ t'= t{tuser= uname}
4358−+ put st{mfToken= t'}
4359−+ return ()
4360−+
4361−+getUserSimple :: ( MonadIO m, FormInput view, Typeable view
4362−+ , Functor m)
4363−+ => FlowM view m String
4364−+getUserSimple= getUser Nothing userFormLine
4365−+
4366−+
4367−+getUser :: ( FormInput view, Typeable view
4368−+ , Functor m,MonadIO m)
4369−+ => Maybe String
4370−+ -> View view m (Maybe (String,String), Maybe String)
4371−+ -> FlowM view m String
4372−+getUser mu form= ask $ userWidget mu form
4373−+
4374−+--wmodify
4375−+-- :: (Functor m, MonadIO m, FormInput v, Generate (Maybe a)) =>
4376−+-- View v m a1
4377−+-- -> ([v] -> Maybe a -> WState v m ([v], Maybe b))
4378−+-- -> View v m b
4379−+--wmodify formt act = do
4380−+-- x <- liftIO generate
4381−+-- formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act
4382−+
4383−+{-
4384−+type Var= String
4385−+data Test= Test{tflink:: [(Var,String)]
4386−+ ,selectOptions :: [(Var,[String])]
4387−+ ,tfinput :: [(Var, String)]
4388−+ ,tftextarea :: [(Var, String)]
4389−+ }
4390−+ deriving(Read,Show)
4391−+
4392−+type TestM = Test -> Test
4393−+
4394−+instance Monoid TestM where
4395−+ mempty= id
4396−+ mappend= (.)
4397−+
4398−+instance FormInput TestM where
4399−+ ftag = const id
4400−+ inred = const id
4401−+ fromStr = const id
4402−+ flink var _= let(n,v)=break (=='=') var in \t ->t{tflink= (n,tail v):tflink t}
4403−+ finput n _ v _ _ = \t -> t{tfinput = (n,v):tfinput t}
4404−+ ftextarea n v= \t -> t{tftextarea = (n,v):tftextarea t}
4405−+ fselect n _= \t -> t{selectOptions=(n,[]):selectOptions t}
4406−+ foption o _ _= \t ->
4407−+ let (n,opts)= head $ selectOptions t
4408−+ in t{selectOptions=(n,o:opts):tail (selectOptions t)}
4409−+ formAction _ _= id
4410−+ addAttributes _ _= id
4411−+
4412−+generateGenerate Test{..}= do
4413−+ b <- generate
4414−+ case b of
4415−+ True -> genLink
4416−+ False -> genForm
4417−+
4418−+ where
4419−+ genForm= do
4420−+ -- one on every generate is incomplete
4421−+ n <- randomRIO(0,10) :: IO Int
4422−+ case n of
4423−+ 0 -> do
4424−+ genInput
4425−+
4426−+ _ -> do
4427−+ r1 <- genInput
4428−+ r2 <- genSelect
4429−+ r3 <- genTextArea
4430−+ return $ r1++r2++r3
4431−+ genLink= do
4432−+ let n = length tflink
4433−+ if n == 0 then genForm
4434−+ else do
4435−+ r <- randomRIO(0,n )
4436−+ return [tflink !! r]
4437−+
4438−+ genSelect=do
4439−+ let n = length selectOptions
4440−+ if n== 0
4441−+ then return []
4442−+ else mapM gen selectOptions
4443−+ where
4444−+ gen(s,os)= do
4445−+ let m = length os
4446−+ j <- randomRIO(0,m)
4447−+ return (s, os !! j)
4448−+
4449−+ genInput= do
4450−+ let n = length tftextarea
4451−+ if n==0
4452−+ then return []
4453−+ else mapM gen tfinput
4454−+ where gen(n,_)= do
4455−+ str <- generate
4456−+ return $ (n,str)
4457−+
4458−+ genTextArea= do
4459−+ let n = length tfinput
4460−+ if n==0
4461−+ then return []
4462−+ else mapM gen tftextarea
4463−+ where
4464−+ gen(n,_)= do
4465−+ str <- generate
4466−+ return $ (n,str)
4467−+
4468−+pwf= "pwf"
4469−+ind= "ind"
4470−+instance Processable Params where
4471−+ pwfname = fromMaybe noScript . lookup pwf
4472−+ puser= fromMaybe anonymous . lookup cookieuser
4473−+ pind = fromMaybe "0" . lookup ind
4474−+ getParams = id
4475−+
4476−+
4477−+
4478−+runTest nusers = do
4479−+ wfs <- getMessageFlows
4480−+ replicateM nusers $ gen wfs
4481−+ where
4482−+ gen wfs = do
4483−+ u <- generate
4484−+ mapM (genTraffic u) $ M.toList wfs
4485−+
4486−+ genTraffic u (n,_)= forkIO $ iterategenerates [(pwf,n),(cookieuser,u)] []
4487−+
4488−+ iterategenerates ident msg= iterate [] msg
4489−+ where
4490−+ iterate cs msg= do
4491−+ (HttpData ps cooks test,_) <- msgScheduler $ ident ++ cs++ msg
4492−+ let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks
4493−+ resp <- generateGenerate . read $ B.unpack test
4494−+ iterate cs' resp
4495−+
4496−+ -}
4497−diff -ru orig/src/MFlow/Forms/Widgets.hs new/src/MFlow/Forms/Widgets.hs
4498−--- orig/src/MFlow/Forms/Widgets.hs 2014-06-10 05:51:26.977015856 +0300
4499−+++ new/src/MFlow/Forms/Widgets.hs 2014-06-10 05:51:25.000000000 +0300
4500−@@ -1,114 +1,114 @@
4501−-
4502−-{- |
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.
4506−--}
4507−+
4508−+{- |
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.
4512−+-}
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 #-}
4522−-
4523−-
4524−-
4525−-
4526−-module MFlow.Forms.Widgets (
4527−--- * Ajax refreshing of widgets
4528−-autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..), lazy
4529−-
4530−--- * JQueryUi widgets
4531−-,datePicker, getSpinner, wautocomplete, wdialog,
4532−-
4533−--- * User Management
4534−-userFormOrName,maybeLogout, wlogin,
4535−-
4536−--- * Active widgets
4537−-wEditList,wautocompleteList
4538−-, wautocompleteEdit,
4539−-
4540−--- * Editing widgets
4541−-delEdited, getEdited, setEdited, prependWidget,appendWidget,setWidget
4542−-
4543−--- * Content Management
4544−-,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey
4545−-
4546−--- * Multilanguage
4547−-,mFieldEd, mField
4548−-
4549−--- * utility
4550−-,insertForm, readtField, writetField
4551−-
4552−-
4553−-) where
4554−-import MFlow
4555−-import MFlow.Forms
4556−-import MFlow.Forms.Internals
4557−-import Data.Monoid
4558−+ , StandaloneDeriving #-}
4559−+
4560−+
4561−+
4562−+
4563−+module MFlow.Forms.Widgets (
4564−+-- * Ajax refreshing of widgets
4565−+autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..), lazy
4566−+
4567−+-- * JQueryUi widgets
4568−+,datePicker, getSpinner, wautocomplete, wdialog,
4569−+
4570−+-- * User Management
4571−+userFormOrName,maybeLogout, wlogin,
4572−+
4573−+-- * Active widgets
4574−+wEditList,wautocompleteList
4575−+, wautocompleteEdit,
4576−+
4577−+-- * Editing widgets
4578−+delEdited, getEdited, setEdited, prependWidget,appendWidget,setWidget
4579−+
4580−+-- * Content Management
4581−+,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey
4582−+
4583−+-- * Multilanguage
4584−+,mFieldEd, mField
4585−+
4586−+-- * utility
4587−+,insertForm, readtField, writetField
4588−+
4589−+
4590−+) where
4591−+import MFlow
4592−+import MFlow.Forms
4593−+import MFlow.Forms.Internals
4594−+import Data.Monoid
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
4599−-import Data.List
4600−-import System.IO.Unsafe
4601−-
4602−-import Control.Monad.State
4603−-import Data.TCache
4604−-import Data.TCache.Defs
4605−-import Data.TCache.Memoization
4606−-import Data.RefSerialize hiding ((<|>))
4607−-import qualified Data.Map as M
4608−-import Data.IORef
4609−-import MFlow.Cookies
4610−-import Data.Maybe
4611−-import Data.Char
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
4619−+import Data.List
4620−+import System.IO.Unsafe
4621−+
4622−+import Control.Monad.State
4623−+import Data.TCache
4624−+import Data.TCache.Defs
4625−+import Data.TCache.Memoization
4626−+import Data.RefSerialize hiding ((<|>))
4627−+import qualified Data.Map as M
4628−+import Data.IORef
4629−+import MFlow.Cookies
4630−+import Data.Maybe
4631−+import Data.Char
4632−+import Control.Monad.Identity
4633−+import Control.Workflow(killWF)
4634−+import Unsafe.Coerce
4635−+import Control.Exception
4636− import MFlow.Forms.Cache
4637−-
4638−-
4639−-
4640−---jqueryScript= "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
4641−---jqueryScript1="//code.jquery.com/jquery-1.9.1.js"
4642−---
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"
4645−---
4646−---jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js"
4647−---jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js"
4648−-
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 ------
4654−-
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
4659−- where
4660−- f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input"
4661−- f felem Nothing = do
4662−- us <- getCurrentUser -- getEnv cookieuser
4663−- if us == anonymous
4664−- then return (felem, Nothing)
4665−- else return([fromStr us], Just us)
4666−-
4667−--- | Display a logout link if the user is logged. Nothing otherwise
4668−-maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m ()
4669−-maybeLogout= do
4670−- us <- getCurrentUser
4671−- if us/= anonymous
4672−- then do
4673−- cmd <- ajax $ const $ return "window.location=='/'" --refresh
4674−- fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout
4675−+
4676−+
4677−+
4678−+--jqueryScript= "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
4679−+--jqueryScript1="//code.jquery.com/jquery-1.9.1.js"
4680−+--
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"
4683−+--
4684−+--jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js"
4685−+--jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js"
4686−+
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 ------
4692−+
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
4697−+ where
4698−+ f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input"
4699−+ f felem Nothing = do
4700−+ us <- getCurrentUser -- getEnv cookieuser
4701−+ if us == anonymous
4702−+ then return (felem, Nothing)
4703−+ else return([fromStr us], Just us)
4704−+
4705−+-- | Display a logout link if the user is logged. Nothing otherwise
4706−+maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m ()
4707−+maybeLogout= do
4708−+ us <- getCurrentUser
4709−+ if us/= anonymous
4710−+ then do
4711−+ cmd <- ajax $ const $ return "window.location=='/'" --refresh
4712−+ fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout
4713− else noWidget
4714−
4715−-
4716−+
4717− data Medit view m a = Medit (M.Map B.ByteString [(String,View view m a)])
4718−
4719− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4720−@@ -129,46 +129,46 @@
4721− ta :: Medit v m a -> a
4722− ta= undefined
4723−
4724−-#endif
4725−-
4726−--- | If not logged, it present a page flow which askm for the user name, then the password if not logged
4727−---
4728−--- If logged, it present the user name and a link to logout
4729−---
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 ()
4732−-wlogin= do
4733−- username <- getCurrentUser
4734−- if username /= anonymous
4735−+#endif
4736−+
4737−+-- | If not logged, it present a page flow which askm for the user name, then the password if not logged
4738−+--
4739−+-- If logged, it present the user name and a link to logout
4740−+--
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 ()
4743−+wlogin= wform $ do
4744−+ username <- getCurrentUser
4745−+ if username /= anonymous
4746− then do
4747− private; noCache;noStore
4748−- return username
4749−- else do
4750−+ return username
4751−+ else do
4752− name <- getString Nothing <! hint "login name"
4753− <! size (9 :: Int)
4754−- <++ ftag "br" mempty
4755−+ <++ ftag "br" mempty
4756− pass <- getPassword <! hint "password"
4757−- <! size 9
4758−- <++ ftag "br" mempty
4759−- <** submitButton "login"
4760−- val <- userValidate (name,pass)
4761−- case val of
4762−- Just msg -> notValid msg
4763−- Nothing -> login name >> (return name)
4764−-
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)
4768−-
4769−-focus = [("onload","this.focus()")]
4770−-hint s= [("placeholder",s)]
4771−-size n= [("size",show n)]
4772−-
4773−-getEdited1 id= do
4774−- Medit stored <- getSessionData `onNothing` return (Medit M.empty)
4775−- return $ fromMaybe [] $ M.lookup id stored
4776−-
4777−--- | Return the list of edited widgets (added by the active widgets) for a given identifier
4778−+ <! size 9
4779−+ <++ ftag "br" mempty
4780−+ <** submitButton "login"
4781−+ val <- userValidate (name,pass)
4782−+ case val of
4783−+ Just msg -> notValid msg
4784−+ Nothing -> login name >> (return name)
4785−+
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)
4789−+
4790−+focus = [("onload","this.focus()")]
4791−+hint s= [("placeholder",s)]
4792−+size n= [("size",show n)]
4793−+
4794−+getEdited1 id= do
4795−+ Medit stored <- getSessionData `onNothing` return (Medit M.empty)
4796−+ return $ fromMaybe [] $ M.lookup id stored
4797−+
4798−+-- | Return the list of edited widgets (added by the active widgets) for a given identifier
4799− getEdited
4800−
4801− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4802−@@ -181,15 +181,15 @@
4803−
4804− #endif
4805−
4806−- B.ByteString -> m [View v m1 a]
4807−+ B.ByteString -> m [View v m1 a]
4808−+
4809−+getEdited id= do
4810−+ r <- getEdited1 id
4811−+ let (_,ws)= unzip r
4812−+ return ws
4813−
4814−-getEdited id= do
4815−- r <- getEdited1 id
4816−- let (_,ws)= unzip r
4817−- return ws
4818−-
4819−--- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter
4820−-delEdited
4821−+-- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter
4822−+delEdited
4823− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4824− :: (Typeable v, Typeable a, MonadIO m, Typeable m1,
4825− #else
4826−@@ -197,312 +197,312 @@
4827− #endif
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
4834−-
4835−- return $ ws `asTypeOf` witness
4836−- liftIO $ mapM flushCached ks
4837−- let stored'= M.delete id stored
4838−- setSessionData . Medit $ stored'
4839−-
4840−-
4841−-
4842−--- setEdited id ([] `asTypeOf` (zip (repeat "") witness))
4843−-
4844−-setEdited id ws= do
4845−- Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
4846−- let stored'= M.insert id ws stored
4847−- setSessionData . Medit $ stored'
4848−-
4849−-
4850−-addEdited id w= do
4851−- ws <- getEdited1 id
4852−- setEdited id (w:ws)
4853−-
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
4858−+
4859−+ return $ ws `asTypeOf` witness
4860−+ liftIO $ mapM flushCached ks
4861−+ let stored'= M.delete id stored
4862−+ setSessionData . Medit $ stored'
4863−+
4864−+
4865−+
4866−+-- setEdited id ([] `asTypeOf` (zip (repeat "") witness))
4867−+
4868−+setEdited id ws= do
4869−+ Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
4870−+ let stored'= M.insert id ws stored
4871−+ setSessionData . Medit $ stored'
4872−+
4873−+
4874−+addEdited id w= do
4875−+ ws <- getEdited1 id
4876−+ setEdited id (w:ws)
4877−+
4878− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4879− modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v, Typeable Identity, Typeable m)
4880−-#else
4881−-modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)
4882−+#else
4883−+modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)
4884− #endif
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 <> "');"
4895−- where
4896−- typ :: View v Identity a -> a
4897−- typ = undefined
4898−-
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'
4902−---
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.
4905−---
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.
4909−---
4910−--- > id1<- genNewId
4911−--- > let sel= "$('#" <> fromString id1 <> "')"
4912−--- > callAjax <- ajax . const $ prependWidget sel wn
4913−--- > let installevents= "$(document).ready(function(){\
4914−--- > \$('#clickelem').click(function(){"++callAjax "''"++"});})"
4915−--- >
4916−--- > requires [JScriptFile jqueryScript [installevents] ]
4917−--- > ws <- getEdited sel
4918−--- > r <- (div <<< manyOf ws) <! [("id",id1)]
4919−--- > delEdited sel ws'
4920−--- > return r
4921−-
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 <> "');"
4932−+ where
4933−+ typ :: View v Identity a -> a
4934−+ typ = undefined
4935−+
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'
4939−+--
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.
4942−+--
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.
4946−+--
4947−+-- > id1<- genNewId
4948−+-- > let sel= "$('#" <> fromString id1 <> "')"
4949−+-- > callAjax <- ajax . const $ prependWidget sel wn
4950−+-- > let installevents= "$(document).ready(function(){\
4951−+-- > \$('#clickelem').click(function(){"++callAjax "''"++"});})"
4952−+-- >
4953−+-- > requires [JScriptFile jqueryScript [installevents] ]
4954−+-- > ws <- getEdited sel
4955−+-- > r <- (div <<< manyOf ws) <! [("id",id1)]
4956−+-- > delEdited sel ws'
4957−+-- > return r
4958−+
4959− prependWidget
4960− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4961− :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m)
4962−-#else
4963−+#else
4964− :: (Typeable a, MonadIO m, Executable m, FormInput v)
4965−-#endif
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
4970−-
4971−--- | Like 'prependWidget' but append the widget instead of prepend.
4972−-appendWidget
4973−+#endif
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
4978−+
4979−+-- | Like 'prependWidget' but append the widget instead of prepend.
4980−+appendWidget
4981− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4982− :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) =>
4983− #else
4984− :: (Typeable a, MonadIO m, Executable m, FormInput v) =>
4985− #endif
4986−- B.ByteString -> View v Identity a -> View v m B.ByteString
4987−-appendWidget sel w= modifyWidget sel "append" w
4988−-
4989−--- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element
4990−-setWidget
4991−+ B.ByteString -> View v Identity a -> View v m B.ByteString
4992−+appendWidget sel w= modifyWidget sel "append" w
4993−+
4994−+-- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element
4995−+setWidget
4996− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
4997− :: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable m, Typeable Identity) =>
4998− #else
4999− :: (Typeable a, MonadIO m, Executable m, FormInput v) =>
5000−-#endif
5001−- B.ByteString -> View v Identity a -> View v m B.ByteString
5002−-setWidget sel w= modifyWidget sel "html" w
5003−-
5004−-
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.
5009−---
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:
5012−---
5013−--- > r <- ask $ addLink
5014−--- > ++> br
5015−--- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid"
5016−--- > <++ br
5017−--- > <** submitButton "send"
5018−--- >
5019−--- > ask $ p << (show r ++ " returned")
5020−--- > ++> wlink () (p << text " back to menu")
5021−--- > mainmenu
5022−--- > where
5023−--- > addLink = a ! At.id "addid"
5024−--- > ! href "#"
5025−--- > $ text "add"
5026−--- > delBox = input ! type_ "checkbox"
5027−--- > ! checked ""
5028−--- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"
5029−--- > getString1 mx= El.div <<< delBox ++> getString mx <++ br
5030−-
5031−-wEditList :: (Typeable a,Read a
5032−+#endif
5033−+ B.ByteString -> View v Identity a -> View v m B.ByteString
5034−+setWidget sel w= modifyWidget sel "html" w
5035−+
5036−+
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.
5041−+--
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:
5044−+--
5045−+-- > r <- ask $ addLink
5046−+-- > ++> br
5047−+-- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid"
5048−+-- > <++ br
5049−+-- > <** submitButton "send"
5050−+-- >
5051−+-- > ask $ p << (show r ++ " returned")
5052−+-- > ++> wlink () (p << text " back to menu")
5053−+-- > mainmenu
5054−+-- > where
5055−+-- > addLink = a ! At.id "addid"
5056−+-- > ! href "#"
5057−+-- > $ text "add"
5058−+-- > delBox = input ! type_ "checkbox"
5059−+-- > ! checked ""
5060−+-- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"
5061−+-- > getString1 mx= El.div <<< delBox ++> getString mx <++ br
5062−+
5063−+wEditList :: (Typeable a,Read a
5064− ,FormInput view
5065− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
5066− ,Functor m,MonadIO m, Executable m, Typeable m, Typeable Identity)
5067−-#else
5068−+#else
5069− ,Functor m,MonadIO m, Executable m)
5070−-#endif
5071−- => (view ->view) -- ^ The holder tag
5072−- -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string
5073−- -> [String] -- ^ The initial list of values.
5074−- -> String -- ^ The id of the button or link that will create a new list element when clicked
5075−- -> View view m [a]
5076−-wEditList holderview w xs addId = do
5077−- let ws= map (w . Just) xs
5078−- wn= w Nothing
5079−- id1<- genNewId
5080−- let sel= "$('#" <> fromString id1 <> "')"
5081−- callAjax <- ajax . const $ prependWidget sel wn
5082−- let installevents= "$(document).ready(function(){$('#"++addId++"').click(function(){"++callAjax "''"++"});})"
5083−-
5084−- requires [JScriptFile jqueryScript [installevents] ]
5085−-
5086−- ws' <- getEdited sel
5087−-
5088−- r <- (holderview <<< (allOf $ ws' ++ map changeMonad ws)) <! [("id",id1)]
5089−- delEdited sel ws'
5090−- return r
5091−-
5092−-
5093−-
5094−-
5095−--- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box.
5096−-wautocomplete
5097−- :: (Show a, MonadIO m, FormInput v)
5098−- => Maybe String -- ^ Initial value
5099−- -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings
5100−- -> View v m String
5101−-wautocomplete mv autocomplete = do
5102−- text1 <- genNewId
5103−- ajaxc <- ajax $ \u -> do
5104−- r <- liftIO $ autocomplete u
5105−- return $ jaddtoautocomp text1 r
5106−-
5107−-
5108−- requires [JScriptFile jqueryScript [] -- [events]
5109−- ,CSSFile jqueryCSS
5110−- ,JScriptFile jqueryUI []]
5111−-
5112−-
5113−- getString mv <! [("type", "text")
5114−- ,("id", text1)
5115−- ,("oninput", ajaxc $ "$('#"++text1++"').attr('value')" )
5116−- ,("autocomplete", "off")]
5117−-
5118−-
5119−- where
5120−- jaddtoautocomp text1 us= "$('#"<>fromString text1<>"').autocomplete({ source: " <> fromString( show us) <> " });"
5121−-
5122−-
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).
5127−---
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):
5131−---
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)
5138−-wautocompleteEdit
5139−+#endif
5140−+ => (view ->view) -- ^ The holder tag
5141−+ -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string
5142−+ -> [String] -- ^ The initial list of values.
5143−+ -> String -- ^ The id of the button or link that will create a new list element when clicked
5144−+ -> View view m [a]
5145−+wEditList holderview w xs addId = do
5146−+ let ws= map (w . Just) xs
5147−+ wn= w Nothing
5148−+ id1<- genNewId
5149−+ let sel= "$('#" <> fromString id1 <> "')"
5150−+ callAjax <- ajax . const $ prependWidget sel wn
5151−+ let installevents= "$(document).ready(function(){$('#"++addId++"').click(function(){"++callAjax "''"++"});})"
5152−+
5153−+ requires [JScriptFile jqueryScript [installevents] ]
5154−+
5155−+ ws' <- getEdited sel
5156−+
5157−+ r <- (holderview <<< (allOf $ ws' ++ map changeMonad ws)) <! [("id",id1)]
5158−+ delEdited sel ws'
5159−+ return r
5160−+
5161−+
5162−+
5163−+
5164−+-- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box.
5165−+wautocomplete
5166−+ :: (Show a, MonadIO m, FormInput v)
5167−+ => Maybe String -- ^ Initial value
5168−+ -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings
5169−+ -> View v m String
5170−+wautocomplete mv autocomplete = do
5171−+ text1 <- genNewId
5172−+ ajaxc <- ajax $ \u -> do
5173−+ r <- liftIO $ autocomplete u
5174−+ return $ jaddtoautocomp text1 r
5175−+
5176−+
5177−+ requires [JScriptFile jqueryScript [] -- [events]
5178−+ ,CSSFile jqueryCSS
5179−+ ,JScriptFile jqueryUI []]
5180−+
5181−+
5182−+ getString mv <! [("type", "text")
5183−+ ,("id", text1)
5184−+ ,("oninput", ajaxc $ "$('#"++text1++"').attr('value')" )
5185−+ ,("autocomplete", "off")]
5186−+
5187−+
5188−+ where
5189−+ jaddtoautocomp text1 us= "$('#"<>fromString text1<>"').autocomplete({ source: " <> fromString( show us) <> " });"
5190−+
5191−+
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).
5196−+--
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):
5200−+--
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)
5207−+wautocompleteEdit
5208− :: (Typeable a, MonadIO m,Functor m, Executable m
5209− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
5210− , FormInput v, Typeable m, Typeable Identity)
5211−-#else
5212−+#else
5213− , FormInput v)
5214−-#endif
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
5221−- id1 <- genNewId
5222−- let textx= id1++"text"
5223−- let sel= "$('#" <> fromString id1 <> "')"
5224−- ajaxc <- ajax $ \(c:u) ->
5225−- case c of
5226−- 'f' -> prependWidget sel (elem $ Just u)
5227−- _ -> do
5228−- r <- liftIO $ autocomplete u
5229−- return $ jaddtoautocomp textx r
5230−-
5231−-
5232−- requires [JScriptFile jqueryScript [events textx ajaxc]
5233−- ,CSSFile jqueryCSS
5234−- ,JScriptFile jqueryUI []]
5235−-
5236−- ws' <- getEdited sel
5237−-
5238−- r<- (ftag "div" mempty `attrs` [("id", id1)]
5239−- ++> allOf (ws' ++ (map (changeMonad . elem . Just) values)))
5240−- <++ ftag "input" mempty
5241−- `attrs` [("type", "text")
5242−- ,("id", textx)
5243−- ,("placeholder", phold)
5244−- ,("oninput", ajaxc $ "'n'+$('#"++textx++"').val()" )
5245−- ,("autocomplete", "off")]
5246−- delEdited sel ws'
5247−- return r
5248−- where
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('');\
5258−- \}\
5259−- \});\
5260−- \});"
5261−-
5262−- jaddtoautocomp textx us= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> " });"
5263−+#endif
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
5270−+ id1 <- genNewId
5271−+ let textx= id1++"text"
5272−+ let sel= "$('#" <> fromString id1 <> "')"
5273−+ ajaxc <- ajax $ \(c:u) ->
5274−+ case c of
5275−+ 'f' -> prependWidget sel (elem $ Just u)
5276−+ _ -> do
5277−+ r <- liftIO $ autocomplete u
5278−+ return $ jaddtoautocomp textx r
5279−+
5280−+
5281−+ requires [JScriptFile jqueryScript [events textx ajaxc]
5282−+ ,CSSFile jqueryCSS
5283−+ ,JScriptFile jqueryUI []]
5284−+
5285−+ ws' <- getEdited sel
5286−+
5287−+ r<- (ftag "div" mempty `attrs` [("id", id1)]
5288−+ ++> allOf (ws' ++ (map (changeMonad . elem . Just) values)))
5289−+ <++ ftag "input" mempty
5290−+ `attrs` [("type", "text")
5291−+ ,("id", textx)
5292−+ ,("placeholder", phold)
5293−+ ,("oninput", ajaxc $ "'n'+$('#"++textx++"').val()" )
5294−+ ,("autocomplete", "off")]
5295−+ delEdited sel ws'
5296−+ return r
5297−+ where
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('');\
5307−+ \}\
5308−+ \});\
5309−+ \});"
5310−+
5311−+ jaddtoautocomp textx us= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> " });"
5312−
5313−
5314− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
5315− deriving instance Typeable Identity
5316− #endif
5317−-
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.
5320−+
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.
5323− wautocompleteList
5324− #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
5325− :: (Functor m, MonadIO m, Executable m, FormInput v, Typeable m, Typeable Identity) =>
5326−-#else
5327−+#else
5328− :: (Functor m, MonadIO m, Executable m, FormInput v) =>
5329−-#endif
5330−- String -> (String -> IO [String]) -> [String] -> View v m [String]
5331−-wautocompleteList phold serverproc values=
5332−- wautocompleteEdit phold serverproc wrender1 values
5333−- where
5334−- wrender1 x= ftag "div" <<< ftag "input" mempty
5335−- `attrs` [("type","checkbox")
5336−- ,("checked","")
5337−- ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
5338−- ++> ftag "span" (fromStr $ fromJust x )
5339−- ++> whidden( fromJust x)
5340−-
5341−-------- Templating and localization ---------
5342−-
5343−-data TField = TField {tfieldKey :: Key, tfieldContent :: B.ByteString} deriving (Read, Show,Typeable)
5344−-
5345−-instance Indexable TField where
5346−- key (TField k _)= k
5347−- defPath _= "texts/"
5348−-
5349−-
5350−-instance Serializable TField where
5351−- serialize (TField k content) = content
5352−- deserialKey k content= TField k content -- applyDeserializers [des1,des2] k bs
5353−-
5354−-
5355−- setPersist = \_ -> Just filePersist
5356−-
5357−-
5358−-
5359−-writetField k s= atomically $ writeDBRef (getDBRef k) $ TField k $ toByteString s
5360−-
5361−-
5362−-readtField text k= atomically $ do
5363−- let ref = getDBRef k
5364−- mr <- readDBRef ref
5365−- case mr of
5366−- Just (TField k v) -> if v /= mempty then return $ fromStrNoEncode $ toString v else return text
5367−- Nothing -> return text
5368−-
5369−+#endif
5370−+ String -> (String -> IO [String]) -> [String] -> View v m [String]
5371−+wautocompleteList phold serverproc values=
5372−+ wautocompleteEdit phold serverproc wrender1 values
5373−+ where
5374−+ wrender1 x= ftag "div" <<< ftag "input" mempty
5375−+ `attrs` [("type","checkbox")
5376−+ ,("checked","")
5377−+ ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
5378−+ ++> ftag "span" (fromStr $ fromJust x )
5379−+ ++> whidden( fromJust x)
5380−+
5381−+------- Templating and localization ---------
5382−+
5383−+data TField = TField {tfieldKey :: Key, tfieldContent :: B.ByteString} deriving (Read, Show,Typeable)
5384−+
5385−+instance Indexable TField where
5386−+ key (TField k _)= k
5387−+ defPath _= "texts/"
5388−+
5389−+
5390−+instance Serializable TField where
5391−+ serialize (TField k content) = content
5392−+ deserialKey k content= TField k content -- applyDeserializers [des1,des2] k bs
5393−+
5394−+
5395−+ setPersist = \_ -> Just filePersist
5396−+
5397−+
5398−+
5399−+writetField k s= atomically $ writeDBRef (getDBRef k) $ TField k $ toByteString s
5400−+
5401−+
5402−+readtField text k= atomically $ do
5403−+ let ref = getDBRef k
5404−+ mr <- readDBRef ref
5405−+ case mr of
5406−+ Just (TField k v) -> if v /= mempty then return $ fromStrNoEncode $ toString v else return text
5407−+ Nothing -> return text
5408−+
5409− -- | Creates a rich text editor aroun a text field or a text area widget.
5410− -- This code:
5411− --
5412−@@ -512,221 +512,224 @@
5413− -- > <** submitButton "enter"
5414− --
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
5419−- id <- genNewId
5420−-
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);\
5427−- \})};\n"
5428−- install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"
5429−-
5430−- requires [JScriptFile nicEditUrl [installHtmlField,install]]
5431−- w <! [("id",id)]
5432−-
5433−-
5434−-
5435−-
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.
5439−---
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.
5443−---
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.
5447−---
5448−-
5449−-tFieldEd
5450−- :: (Functor m, MonadIO m, Executable m,
5451−- FormInput v) =>
5452−- UserStr -> Key -> v -> View v m ()
5453−-tFieldEd muser k text= wfreeze k 0 $ do
5454−- content <- liftIO $ readtField text k
5455−- nam <- genNewId
5456−- let ipanel= nam++"panel"
5457−- name= nam++"-"++k
5458−- install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
5459−- getTexts :: (Token -> IO ())
5460−- getTexts token = do
5461−- let (k,s):_ = tenv token
5462−- liftIO $ do
5463−- writetField k $ (fromStrNoEncode s `asTypeOf` text)
5464−- flushCached k
5465−- sendFlush token $ HttpData [] [] ""
5466−- return()
5467−-
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
5476−+ id <- genNewId
5477−+
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);\
5484−+ \})};\n"
5485−+ install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"
5486−+
5487−+ requires [JScript installHtmlField ,JScriptFile nicEditUrl [install]]
5488−+ w <! [("id",id)]
5489−+
5490−+
5491−+
5492−+
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.
5496−+--
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.
5500−+--
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.
5504−+--
5505−+
5506−+tFieldEd
5507−+ :: (Functor m, MonadIO m, Executable m,
5508−+ FormInput v) =>
5509−+ UserStr -> Key -> v -> View v m ()
5510−+tFieldEd muser k text= wfreeze k 0 $ do
5511−+ content <- liftIO $ readtField text k
5512−+ nam <- genNewId
5513−+ let ipanel= nam++"panel"
5514−+ name= nam++"-"++k
5515−+ install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
5516−+ getTexts :: (Token -> IO ())
5517−+ getTexts token = do
5518−+ let (k,s):_ = tenv token
5519−+ liftIO $ do
5520−+ writetField k $ (fromStrNoEncode s `asTypeOf` text)
5521−+ flushCached k
5522−+ sendFlush token $ HttpData [] [] ""
5523−+ return()
5524−+
5525−+ requires [JScriptFile nicEditUrl [install]
5526−+ ,JScript ajaxSendText
5527−+ ,JScript installEditField
5528−+ ,ServerProc ("_texts", transient getTexts)]
5529−
5530− us <- getCurrentUser
5531− when(us== muser) noCache
5532−-
5533−- (ftag "div" mempty `attrs` [("id",ipanel)]) ++>
5534−- notValid (ftag "span" content `attrs` [("id", name)])
5535−-
5536−-
5537−-
5538−-installEditField=
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);\
5546−- \}});\
5547−- \myNicEditor.addInstance(name);\
5548−- \myNicEditor.setPanel(ipanel);\
5549−- \})};\n"
5550−-
5551−-ajaxSendText = "\nfunction ajaxSendText(id,content){\
5552−- \var arr= id.split('-');\
5553−- \var k= arr[1];\
5554−- \$.ajax({\
5555−- \type: 'POST',\
5556−- \url: '/_texts',\
5557−- \data: k + '='+ encodeURIComponent(content),\
5558−- \success: function (resp) {},\
5559−- \error: function (xhr, status, error) {\
5560−- \var msg = $('<div>' + xhr + '</div>');\
5561−- \id1.html(msg);\
5562−- \}\
5563−- \});\
5564−- \return false;\
5565−- \};\n"
5566−-
5567−--- | a text field. Read the cached field value and present it without edition.
5568−-tField :: (MonadIO m,Functor m, Executable m, FormInput v)
5569−- => Key
5570−- -> View v m ()
5571−-tField k = wfreeze k 0 $ do
5572−- content <- liftIO $ readtField (fromStrNoEncode "not found") k
5573−- notValid content
5574−-
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
5578−- lang <- getLang
5579−- tFieldEd muser (k ++ ('-':lang)) content
5580−-
5581−-
5582−-
5583−--- | A multilanguage version of tField
5584−-mField k= do
5585−- lang <- getLang
5586−- tField $ k ++ ('-':lang)
5587−-
5588−-newtype IteratedId= IteratedId String deriving Typeable
5589−-
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.
5598−---
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.
5601−---
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.
5605−---
5606−--- Additionally, contrary to some javascript frameworks, the pages generated with this
5607−--- mechanism are searchable by web crawlers.
5608−-
5609−-witerate
5610−- :: (MonadIO m, Functor m, FormInput v) =>
5611−- View v m a -> View v m a
5612−-witerate w= do
5613−- name <- genNewId
5614−- setSessionData $ IteratedId name
5615−- st <- get
5616−- let t= mfkillTime st
5617−- let installAutoEval=
5618−- "$(document).ready(function(){\
5619−- \autoEvalLink('"++name++"',0);\
5620−- \autoEvalForm('"++name++"');\
5621−- \})\n"
5622−+
5623−+ (ftag "div" mempty `attrs` [("id",ipanel)]) ++>
5624−+ notValid (ftag "span" content `attrs` [("id", name)])
5625−+
5626−+
5627−+
5628−+installEditField=
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);\
5635−+ \}});\
5636−+ \myNicEditor.addInstance(name);\
5637−+ \myNicEditor.setPanel(ipanel);\
5638−+ \}};\n"
5639−+
5640−+ajaxSendText = "\nfunction ajaxSendText(id,content){\
5641−+ \var arr= id.split('-');\
5642−+ \var k= arr[1];\
5643−+ \$.ajax({\
5644−+ \type: 'POST',\
5645−+ \url: '/_texts',\
5646−+ \data: k + '='+ encodeURIComponent(content),\
5647−+ \success: function (resp) {},\
5648−+ \error: function (xhr, status, error) {\
5649−+ \var msg = $('<div>' + xhr + '</div>');\
5650−+ \id1.html(msg);\
5651−+ \}\
5652−+ \});\
5653−+ \return false;\
5654−+ \};\n"
5655−+
5656−+-- | a text field. Read the cached field value and present it without edition.
5657−+tField :: (MonadIO m,Functor m, Executable m, FormInput v)
5658−+ => Key
5659−+ -> View v m ()
5660−+tField k = wfreeze k 0 $ do
5661−+ content <- liftIO $ readtField (fromStrNoEncode "not found") k
5662−+ notValid content
5663−+
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
5667−+ lang <- getLang
5668−+ tFieldEd muser (k ++ ('-':lang)) content
5669−+
5670−+
5671−+
5672−+-- | A multilanguage version of tField
5673−+mField k= do
5674−+ lang <- getLang
5675−+ tField $ k ++ ('-':lang)
5676−+
5677−+data IteratedId = IteratedId String String deriving (Typeable, Show)
5678−+
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.
5687−+--
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.
5690−+--
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.
5694−+--
5695−+-- Additionally, contrary to some javascript frameworks, the pages generated with this
5696−+-- mechanism are searchable by web crawlers.
5697−+
5698−+witerate
5699−+ :: (MonadIO m, Functor m, FormInput v) =>
5700−+ View v m a -> View v m a
5701−+witerate w= do
5702−+ name <- genNewId
5703−+ setSessionData $ IteratedId name mempty
5704−+ st <- get
5705−+ let t= mfkillTime st
5706−+ let installAutoEval=
5707−+ "$(document).ready(function(){\
5708−+ \autoEvalLink('"++name++"',0);\
5709−+ \autoEvalForm('"++name++"');\
5710−+ \})\n"
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 []
5717− ,mfHttpHeaders=[]}
5718−- w)
5719−-
5720−- ret <- case r of
5721−- Nothing -> do
5722−- requires [JScript autoEvalLink
5723−- ,JScript autoEvalForm
5724−- ,JScript $ timeoutscript t
5725−+ w)
5726−+
5727−+ ret <- case r of
5728−+ Nothing -> do
5729−+ requires [JScript autoEvalLink
5730−+ ,JScript autoEvalForm
5731−+ ,JScript $ timeoutscript t
5732− ,JScriptFile jqueryScript [installAutoEval]
5733−- ,JScript setId]
5734−-
5735−- (ftag "div" <<< w') <! [("id",name)]
5736−-
5737−- Just sind -> View $ do
5738−- let t= mfToken st
5739−- modify $ \s -> s{mfRequirements=[],mfHttpHeaders=[]} -- !> "just"
5740−- resetCachePolicy
5741−- FormElm _ mr <- runView w'
5742−- setCachePolicy
5743−- reqs <- return . map ( \(Requirement r) -> unsafeCoerce r) =<< gets mfRequirements
5744−- let js = jsRequirements True reqs
5745−-
5746−- st' <- get
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
5752−-
5753−- delSessionData $ IteratedId name
5754−+ ,JScript setId]
5755−+
5756−+ (ftag "div" <<< w') <! [("id",name)]
5757−+
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
5762−+
5763−+-- View $ do
5764−+-- let t= mfToken st
5765−+-- modify $ \s -> s{mfRequirements=[],mfHttpHeaders=[]} -- !> "just"
5766−+-- resetCachePolicy
5767−+-- FormElm _ mr <- runView w'
5768−+-- setCachePolicy
5769−+--
5770−+-- reqs <- installAllRequirements
5771−+--
5772−+-- st' <- get
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
5778−+
5779−+ delSessionData $ IteratedId name mempty
5780− return ret
5781−
5782−
5783−-
5784−-autoEvalLink = "\nfunction autoEvalLink(id,ind){\
5785−- \var id1= $('#'+id);\
5786−+
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 = {\
5802− \type: 'GET',\
5803−- \url: actionurl+'?auto'+id+'='+ind,\
5804−- \data: pdata,\
5805−- \success: function (resp) {\
5806−+ \url: actionurl+'?auto'+id+'='+ind,\
5807−+ \data: pdata,\
5808−+ \success: function (resp) {\
5809− \eval(resp);\
5810− \autoEvalLink(id,ind);\
5811−- \autoEvalForm(id);\
5812−- \},\
5813−- \error: function (xhr, status, error) {\
5814−- \var msg = $('<div>' + xhr + '</div>');\
5815−- \id1.html(msg);\
5816−- \}\
5817−- \};\
5818−- \$.ajax(dialogOpts);\
5819−- \return false;\
5820−- \});\
5821−- \}\n"
5822−+ \autoEvalForm(id);\
5823−+ \},\
5824−+ \error: function (xhr, status, error) {\
5825−+ \var msg = $('<div>' + xhr + '</div>');\
5826−+ \id1.html(msg);\
5827−+ \}\
5828−+ \};\
5829−+ \$.ajax(dialogOpts);\
5830−+ \return false;\
5831−+ \});\
5832−+ \}\n"
5833−
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);\
5845− \return false;\
5846−- \}else {\
5847−+ \}else {\
5848− \noajax= true;\
5849− \return true;\
5850− \}\
5851−@@ -751,7 +754,7 @@
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 @@
5861− \}\
5862− \function postForm(id,url,pdata){\
5863− \var id1= $('#'+id);\
5864−- \$.ajax({\
5865−- \type: 'POST',\
5866−- \url: url,\
5867−- \data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\
5868−- \success: function (resp) {\
5869−+ \$.ajax({\
5870−+ \type: 'POST',\
5871−+ \url: url,\
5872−+ \data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\
5873−+ \success: function (resp) {\
5874− \eval(resp);\
5875− \autoEvalLink(id,0);\
5876−- \autoEvalForm(id);\
5877−+ \autoEvalForm(id);\
5878− \},\
5879−- \error: function (xhr, status, error) {\
5880−- \var msg = $('<div>' + xhr + '</div>');\
5881−- \id1.html(msg);\
5882−+ \error: function (xhr, status, error) {\
5883−+ \var msg = $('<div>' + xhr + '</div>');\
5884−+ \id1.html(msg);\
5885− \}\
5886−- \});\
5887−+ \});\
5888− \}"
5889−
5890−-
5891−-
5892−-setId= "function setId(id,v){document.getElementById(id).innerHTML= v;};\n"
5893−-
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.
5897−-dField
5898−- :: (Monad m, FormInput view) =>
5899−- View view m b -> View view m b
5900−-dField w= View $ do
5901−- id <- genNewId
5902−- FormElm render mx <- runView w
5903−- st <- get
5904−- let env = mfEnv st
5905−-
5906−- IteratedId name <- getSessionData `onNothing` return (IteratedId noid)
5907−- let r = lookup ("auto"++name) env
5908−+
5909−+
5910−+setId= "function setId(id,v){document.getElementById(id).innerHTML= v;};\n"
5911−+
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.
5915−+dField
5916−+ :: (Monad m, FormInput view) =>
5917−+ View view m b -> View view m b
5918−+dField w= View $ do
5919−+ id <- genNewId
5920−+ FormElm render mx <- runView w
5921−+ st <- get
5922−+ let env = mfEnv st
5923−+
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)
5927−- then do
5928−--- requires [JScriptFile jqueryScript ["$(document).ready(function() {setId('"++id++"','" ++ toString (toByteString render)++"')});\n"]]
5929−- return $ FormElm((ftag "span" render) `attrs` [("id",id)]) mx
5930−- else do
5931−- requires [JScript $ "setId('"++id++"','" ++ toString (toByteString $ render)++"');\n"]
5932−- return $ FormElm mempty mx
5933−-
5934−-noid= "noid"
5935−-
5936−+ then return $ FormElm((ftag "span" render) `attrs` [("id",id)]) mx
5937−+ else do
5938−+ setSessionData $ IteratedId name $ scripts <> "setId('"++id++"','" ++ toString (toByteString $ render)++"');"
5939−+ return $ FormElm mempty mx
5940−+
5941−+noid= "noid"
5942−+
5943−
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
5946− -- template
5947− --
5948− -- the first parameter is the user that has permissions for edition. the second is a key that
5949−--- identifies the template.
5950−-edTemplate
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
5954−- nam <- genNewId
5955−-
5956−- let ipanel= nam++"panel"
5957−- name= nam++"-"++k
5958−- install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
5959−-
5960−-
5961−- requires [JScriptFile nicEditUrl [install]
5962−- ,JScript ajaxSendText
5963−- ,JScript installEditField
5964−- ,JScriptFile jqueryScript []
5965−- ,ServerProc ("_texts", transient getTexts)]
5966−+-- identifies the template.
5967−+edTemplate
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
5971−+ nam <- genNewId
5972−+
5973−+ let ipanel= nam++"panel"
5974−+ name= nam++"-"++k
5975−+ install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
5976−+
5977−+
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
5987−-
5988−- return $ FormElm (ftag "div" mempty `attrs` [("id",ipanel)] <>
5989−- ftag "span" content `attrs` [("id", name)])
5990−- mx
5991−- where
5992−- getTexts :: (Token -> IO ())
5993−- getTexts token= do
5994−- let (k,s):_ = tenv token
5995−- liftIO $ do
5996−- writetField k $ (fromStrNoEncode s `asTypeOf` viewFormat w)
5997−- flushCached k
5998−- sendFlush token $ HttpData [] [] ""
5999−- return()
6000−-
6001−- viewFormat :: View v m a -> v
6002−- viewFormat= undefined -- is a type function
6003−-
6004−+ when(us== muser) noCache
6005−+ FormElm text mx <- runView w
6006−+ content <- liftIO $ readtField text k
6007−+
6008−+ return $ FormElm (ftag "div" mempty `attrs` [("id",ipanel)] <>
6009−+ ftag "span" content `attrs` [("id", name)])
6010−+ mx
6011−+ where
6012−+ getTexts :: Token -> IO () -- low level server process
6013−+ getTexts token= do
6014−+ let (k,s):_ = tenv token
6015−+ liftIO $ do
6016−+ writetField k $ (fromStrNoEncode s `asTypeOf` viewFormat w)
6017−+ flushCached k
6018−+ sendFlush token $ HttpData [] [] "" --empty response
6019−+
6020−+ return()
6021−+
6022−+
6023−+ viewFormat :: View v m a -> v
6024−+ viewFormat= undefined -- is a type function
6025−+
6026− -- | Does the same than template but without the edition facility
6027−-template
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
6034−-
6035−-
6036−-
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
6043−- id <- genNewId
6044−- let setit= "$(document).ready(function() {\
6045−- \$( '#"++id++"' ).datepicker "++ conf ++";\
6046−- \});"
6047−-
6048−- requires
6049−- [CSSFile jqueryCSS
6050−- ,JScriptFile jqueryScript []
6051−- ,JScriptFile jqueryUI [setit]]
6052−-
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)
6057−-
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.
6061−---
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
6065−- id <- genNewId
6066−- let setit= "$(document).ready(function() {\
6067−- \$('#"++id++"').dialog "++ conf ++";\
6068−- \var idform= $('#"++id++" form');\
6069−- \idform.submit(function(){$(this).dialog(\"close\")})\
6070−- \});"
6071−-
6072−- modify $ \st -> st{needForm= HasForm}
6073−- requires
6074−- [CSSFile jqueryCSS
6075−- ,JScriptFile jqueryScript []
6076−- ,JScriptFile jqueryUI [setit]]
6077−-
6078−- (ftag "div" <<< insertForm w) <! [("id",id),("title", title)]
6079−-
6080−-
6081−-
6082−-
6083−-
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.
6089−---
6090−--- autoRefresh encloses the widget in a form tag if it includes form elements.
6091−---
6092−--- If there are more than one autoRefresh, they must be enclosed within 'pageFlow' elements
6093−-autoRefresh
6094−- :: (MonadIO m,
6095−- FormInput v)
6096−- => View v m a
6097−- -> View v m a
6098−-autoRefresh = update "html"
6099−-
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.
6104−---
6105−--- That behaviour is common at the last sentence of the 'autoRefresh' block.
6106−---
6107−--- This is a cascade menu example.
6108−---
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)
6113−--- > <|>...
6114−--- > maybe other content
6115−--- >
6116−--- > case r of
6117−--- > OptionA1 -> pageA1
6118−--- > OptionA2 -> pageA2
6119−---
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.
6123−---
6124−--- NOTE: the noAutoRefresh attribute should be added to the <a/> or <form/> tags.
6125−-noAutoRefresh= [("class","_noAutoRefresh")]
6126−-
6127−--- | does the same than `autoRefresh` but append the result of each request to the bottom of the widget
6128−---
6129−--- all the comments and remarks of `autoRefresh` apply here
6130−-appendUpdate :: (MonadIO m,
6131−- FormInput v)
6132−- => View v m a
6133−- -> View v m a
6134−-appendUpdate= update "append"
6135−-
6136−--- | does the same than `autoRefresh` but prepend the result of each request before the current widget content
6137−---
6138−--- all the comments and remarks of `autoRefresh` apply here
6139−-prependUpdate :: (MonadIO m,
6140−- FormInput v)
6141−- => View v m a
6142−- -> View v m a
6143−-prependUpdate= update "prepend"
6144−-
6145−-update :: (MonadIO m, FormInput v)
6146−- => B.ByteString
6147−- -> View v m a
6148−- -> View v m a
6149−-update method w= do
6150−- id <- genNewId
6151−+template
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
6158−+
6159−+
6160−+
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
6167−+ id <- genNewId
6168−+ let setit= "$(document).ready(function() {\
6169−+ \$( '#"++id++"' ).datepicker "++ conf ++";\
6170−+ \});"
6171−+
6172−+ requires
6173−+ [CSSFile jqueryCSS
6174−+ ,JScriptFile jqueryScript []
6175−+ ,JScriptFile jqueryUI [setit]]
6176−+
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)
6181−+
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.
6185−+--
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
6189−+ id <- genNewId
6190−+ let setit= "$(document).ready(function() {\
6191−+ \$('#"++id++"').dialog "++ conf ++";\
6192−+ \var idform= $('#"++id++" form');\
6193−+ \idform.submit(function(){$(this).dialog(\"close\")})\
6194−+ \});"
6195−+
6196−+ modify $ \st -> st{needForm= HasForm}
6197−+ requires
6198−+ [CSSFile jqueryCSS
6199−+ ,JScriptFile jqueryScript []
6200−+ ,JScriptFile jqueryUI [setit]]
6201−+
6202−+ (ftag "div" <<< insertForm w) <! [("id",id),("title", title)]
6203−+
6204−+
6205−+
6206−+
6207−+
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.
6213−+--
6214−+-- autoRefresh encloses the widget in a form tag if it includes form elements.
6215−+--
6216−+-- If there are more than one autoRefresh, they must be enclosed within 'pageFlow' elements
6217−+autoRefresh
6218−+ :: (MonadIO m,
6219−+ FormInput v)
6220−+ => View v m a
6221−+ -> View v m a
6222−+autoRefresh = update "html"
6223−+
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.
6228−+--
6229−+-- That behaviour is common at the last sentence of the 'autoRefresh' block.
6230−+--
6231−+-- This is a cascade menu example.
6232−+--
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)
6237−+-- > <|>...
6238−+-- > maybe other content
6239−+-- >
6240−+-- > case r of
6241−+-- > OptionA1 -> pageA1
6242−+-- > OptionA2 -> pageA2
6243−+--
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.
6247−+--
6248−+-- NOTE: the noAutoRefresh attribute should be added to the <a/> or <form/> tags.
6249−+noAutoRefresh= [("class","_noAutoRefresh")]
6250−+
6251−+-- | does the same than `autoRefresh` but append the result of each request to the bottom of the widget
6252−+--
6253−+-- all the comments and remarks of `autoRefresh` apply here
6254−+appendUpdate :: (MonadIO m,
6255−+ FormInput v)
6256−+ => View v m a
6257−+ -> View v m a
6258−+appendUpdate= update "append"
6259−+
6260−+-- | does the same than `autoRefresh` but prepend the result of each request before the current widget content
6261−+--
6262−+-- all the comments and remarks of `autoRefresh` apply here
6263−+prependUpdate :: (MonadIO m,
6264−+ FormInput v)
6265−+ => View v m a
6266−+ -> View v m a
6267−+prependUpdate= update "prepend"
6268−+
6269−+update :: (MonadIO m, FormInput v)
6270−+ => String
6271−+ -> View v m a
6272−+ -> View v m a
6273−+update method w= do
6274−+ id <- genNewId
6275− st <- get
6276−-
6277−- let t = mfkillTime st -1
6278−-
6279−- installscript=
6280−- "$(document).ready(function(){\
6281−- \ajaxGetLink('"++id++"');\
6282−- \ajaxPostForm('"++id++"');\
6283−+
6284−+ let t = mfkillTime st -1
6285−+
6286−+ installscript=
6287−+ "$(document).ready(function(){\
6288−+ \ajaxGetLink('"++id++"');\
6289−+ \ajaxPostForm('"++id++"');\
6290− \});"
6291− st <- get
6292− let insync = inSync st
6293−- let env= mfEnv st
6294−- let r= lookup ("auto"++id) env
6295−+ let env= mfEnv st
6296−+ let r= lookup ("auto"++id) env
6297− if r == Nothing
6298−- then do
6299−- requires [JScript $ timeoutscript t
6300−- ,JScript ajaxGetLink
6301−- ,JScript ajaxPostForm
6302−- ,JScriptFile jqueryScript [installscript]]
6303−- (ftag "div" <<< insertForm w) <! [("id",id)]
6304−-
6305−- else View $ do
6306−- let t= mfToken st -- !> "JUST"
6307−- modify $ \s -> s{mfHttpHeaders=[]} -- !> "just"
6308−- resetCachePolicy
6309−- FormElm form mr <- runView $ insertForm w
6310−- setCachePolicy
6311−- st' <- get
6312−- let HttpData ctype c s= toHttpData $ method <> " " <> toByteString form
6313−-
6314−- (liftIO . sendFlush t $ HttpData (ctype ++
6315−- mfHttpHeaders st') (mfCookies st' ++ c) s)
6316−- put st'{mfAutorefresh=True,newAsk=True}
6317−-
6318−- return $ FormElm mempty Nothing
6319−-
6320−- where
6321−- -- | adapted from http://www.codeproject.com/Articles/341151/Simple-AJAX-POST-Form-and-AJAX-Fetch-Link-to-Modal
6322−+ then do
6323−+ requires [JScript $ timeoutscript t
6324−+ ,JScript ajaxGetLink
6325−+ ,JScript ajaxPostForm
6326−+ ,JScriptFile jqueryScript [installscript]]
6327−+ (ftag "div" <<< insertForm w) <! [("id",id)]
6328−+
6329−+ else refresh $ fromStr (method <> " ") ++> insertForm w
6330−+-- View $ do
6331−+-- let t= mfToken st -- !> "JUST"
6332−+-- modify $ \s -> s{mfHttpHeaders=[]} -- !> "just"
6333−+-- resetCachePolicy
6334−+-- FormElm form mr <- runView $ insertForm w
6335−+-- setCachePolicy
6336−+-- st' <- get
6337−+-- let HttpData ctype c s= toHttpData $ method <> " " <> toByteString form
6338−+--
6339−+-- (liftIO . sendFlush t $ HttpData (ctype ++
6340−+-- mfHttpHeaders st') (mfCookies st' ++ c) s)
6341−+-- put st'{mfAutorefresh=True,newAsk=True}
6342−+--
6343−+-- return $ FormElm mempty Nothing
6344−+
6345−+ where
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 = {\
6364− \type: 'GET',\
6365−- \url: actionurl+'?auto'+id+'=true',\
6366−- \data: pdata,\
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',\
6374−+ \data: pdata,\
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);\
6384− \ajaxGetLink(id);\
6385−- \ajaxPostForm(id);\
6386−- \},\
6387−- \error: function (xhr, status, error) {\
6388−- \var msg = $('<div>' + xhr + '</div>');\
6389−- \id1.html(msg);\
6390−- \}\
6391−- \};\
6392−- \$.ajax(dialogOpts);\
6393−- \return false;\
6394−- \});\
6395−- \}\n"
6396−+ \ajaxPostForm(id);\
6397−+ \},\
6398−+ \error: function (xhr, status, error) {\
6399−+ \var msg = $('<div>' + xhr + '</div>');\
6400−+ \id1.html(msg);\
6401−+ \}\
6402−+ \};\
6403−+ \$.ajax(dialogOpts);\
6404−+ \return false;\
6405−+ \});\
6406−+ \}\n"
6407−
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);\
6421− \return false;\
6422−- \}else {\
6423−+ \}else {\
6424− \noajax= true;\
6425− \return true;\
6426− \}\
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);\
6436− \return false;})\
6437− \}\
6438− \function postForm(id,url,pdata){\
6439−- \var id1= $('#'+id);\
6440−- \$.ajax({\
6441−- \type: 'POST',\
6442−- \url: url,\
6443−- \data: pdata,\
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);\
6451−+ \$.ajax({\
6452−+ \type: 'POST',\
6453−+ \url: url,\
6454−+ \data: pdata,\
6455−+ \success: function (resp) {\
6456−+ \var ind= resp.indexOf(' ');\
6457−+ \var dat = resp.substr(ind);\
6458−+ \var method= resp.substr(0,ind);\
6459−+ \if(method== 'html')id1.html(dat);\
6460−+ \else if (method == 'append') id1.append(dat);\
6461− \else if (method == 'prepend') id1.prepend(dat);\
6462− \else $(':root').html(resp);\
6463−- \ajaxGetLink(id);\
6464−- \ajaxPostForm(id);\
6465−- \},\
6466−- \error: function (xhr, status, error) {\
6467−- \var msg = $('<div>' + xhr + '</div>');\
6468−- \id1.html(msg);\
6469−- \}\
6470−- \});\
6471−- \};"
6472−-
6473−-
6474−-
6475−-
6476−-timeoutscript t=
6477−- "\nvar hadtimeout=false;\
6478−- \if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n"
6479−-
6480−-
6481−-data UpdateMethod= Append | Prepend | Html deriving Show
6482−-
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.
6486−---
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'.
6492−---
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.
6497−---
6498−---
6499−--- This example is a counter increased each second:
6500−---
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
6508−---
6509−---
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.
6514−---
6515−--- It is recommended to add a timeout to the push widget, like in the example:
6516−---
6517−--- > pushSample= do
6518−--- > tv <- liftIO $ newTVarIO $ Just "init"
6519−--- > page $ push Append 1000 (disp tv) <** input tv
6520−--- >
6521−--- > where
6522−--- > disp tv= do
6523−--- > setTimeouts 100 0
6524−--- > line <- tget tv
6525−--- > p << line ++> noWidget
6526−--- >
6527−--- > input tv= autoRefresh $ do
6528−--- > line <- getString Nothing <** submitButton "Enter"
6529−--- > tput tv line
6530−--- >
6531−--- > tput tv x = atomic $ writeTVar tv ( Just x) !> "WRITE"
6532−--- >
6533−--- > tget tv= atomic $ do
6534−--- > mr <- readTVar tv
6535−--- > case mr of
6536−--- > Nothing -> retry
6537−--- > Just r -> do
6538−--- > writeTVar tv Nothing
6539−--- > return r
6540−-
6541−-push :: FormInput v
6542−- => UpdateMethod
6543−- -> Int
6544−- -> View v IO ()
6545−- -> View v IO ()
6546−-push method' wait w= push' . map toLower $ show method'
6547−- where
6548−- push' method= do
6549−- id <- genNewId
6550−- st <- get
6551−- let token= mfToken st
6552−-
6553−- procname= "_push" ++ tind token ++ id
6554−- installscript=
6555−- "$(document).ready(function(){\n"
6556−- ++ "ajaxPush('"++id++"',"++show wait++");"
6557−- ++ "})\n"
6558−-
6559−- new <- gets newAsk
6560−-
6561−- when new $ do
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]]
6567−-
6568−- (ftag "div" <<< noWidget) <! [("id",id)]
6569−- <++ ftag "div" mempty `attrs` [("id",id++"status")]
6570−-
6571−- where
6572−- w' = do
6573−- modify $ \s -> s{inSync= True,newAsk=True}
6574−- w
6575−-
6576−-
6577−-
6578−- ajaxPush procname=" function ajaxPush(id,waititime){\
6579−- \var cnt=0; \
6580−- \var id1= $('#'+id);\
6581−- \var idstatus= $('#'+id+'status');\
6582−- \var ida= $('#'+id+' a');\
6583−- \var actionurl='/"++procname++"';\
6584−- \var dialogOpts = {\
6585−- \cache: false,\
6586−- \type: 'GET',\
6587−- \url: actionurl,\
6588−- \data: '',\
6589−- \success: function (resp) {\
6590−- \idstatus.html('')\
6591−- \cnt=0;\
6592−- \id1."++method++"(resp);\
6593−- \ajaxPush1();\
6594−- \},\
6595−- \error: function (xhr, status, error) {\
6596−- \cnt= cnt + 1;\
6597−- \if (false) \
6598−- \idstatus.html('no more retries');\
6599−- \else {\
6600−- \idstatus.html('waiting');\
6601−- \setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\
6602−- \}\
6603−- \}\
6604−- \};\
6605−- \function ajaxPush1(){\
6606−- \$.ajax(dialogOpts);\
6607−- \return false;\
6608−- \}\
6609−- \ajaxPush1();\
6610−- \}"
6611−-
6612−-
6613−-
6614−-
6615−--- | show the jQuery spinner widget. the first parameter is the configuration . Use \"()\" by default.
6616−--- See http://jqueryui.com/spinner
6617−-getSpinner
6618−- :: (MonadIO m, Read a,Show a, Typeable a, FormInput view) =>
6619−- String -> Maybe a -> View view m a
6620−-getSpinner conf mv= do
6621−- id <- genNewId
6622−- let setit= "$(document).ready(function() {\
6623−- \var spinner = $( '#"++id++"' ).spinner "++conf++";\
6624−- \spinner.spinner( \"enable\" );\
6625−- \});"
6626−- requires
6627−- [CSSFile jqueryCSS
6628−- ,JScriptFile jqueryScript []
6629−- ,JScriptFile jqueryUI [setit]]
6630−-
6631−- getTextBox mv <! [("id",id)]
6632−+ \ajaxGetLink(id);\
6633−+ \ajaxPostForm(id);\
6634−+ \},\
6635−+ \error: function (xhr, status, error) {\
6636−+ \var msg = $('<div>' + xhr + '</div>');\
6637−+ \id1.html(msg);\
6638−+ \}\
6639−+ \});\
6640−+ \};"
6641−+
6642−+
6643−+
6644−+
6645−+timeoutscript t=
6646−+ "\nvar hadtimeout=false;\
6647−+ \if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n"
6648−+
6649−+
6650−+data UpdateMethod= Append | Prepend | Html deriving Show
6651−+
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.
6655−+--
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'.
6661−+--
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.
6666−+--
6667−+--
6668−+-- This example is a counter increased each second:
6669−+--
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
6677−+--
6678−+--
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.
6683−+--
6684−+-- It is recommended to add a timeout to the push widget, like in the example:
6685−+--
6686−+-- > pushSample= do
6687−+-- > tv <- liftIO $ newTVarIO $ Just "init"
6688−+-- > page $ push Append 1000 (disp tv) <** input tv
6689−+-- >
6690−+-- > where
6691−+-- > disp tv= do
6692−+-- > setTimeouts 100 0
6693−+-- > line <- tget tv
6694−+-- > p << line ++> noWidget
6695−+-- >
6696−+-- > input tv= autoRefresh $ do
6697−+-- > line <- getString Nothing <** submitButton "Enter"
6698−+-- > tput tv line
6699−+-- >
6700−+-- > tput tv x = atomic $ writeTVar tv ( Just x) !> "WRITE"
6701−+-- >
6702−+-- > tget tv= atomic $ do
6703−+-- > mr <- readTVar tv
6704−+-- > case mr of
6705−+-- > Nothing -> retry
6706−+-- > Just r -> do
6707−+-- > writeTVar tv Nothing
6708−+-- > return r
6709−+
6710−+push :: FormInput v
6711−+ => UpdateMethod
6712−+ -> Int
6713−+ -> View v IO ()
6714−+ -> View v IO ()
6715−+push method' wait w= push' . map toLower $ show method'
6716−+ where
6717−+ push' method= do
6718−+ id <- genNewId
6719−+ st <- get
6720−+ let token= mfToken st
6721−+
6722−+ procname= "_push" ++ tind token ++ id
6723−+ installscript=
6724−+ "$(document).ready(function(){\n"
6725−+ ++ "ajaxPush('"++id++"',"++show wait++");"
6726−+ ++ "})\n"
6727−+
6728−+ new <- gets newAsk
6729−+
6730−+ when new $ do
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]]
6736−+
6737−+ (ftag "div" <<< noWidget) <! [("id",id)]
6738−+ <++ ftag "div" mempty `attrs` [("id",id++"status")]
6739−+
6740−+ where
6741−+ w' = do
6742−+ modify $ \s -> s{inSync= True,newAsk=True}
6743−+ w
6744−+
6745−+
6746−+
6747−+ ajaxPush procname=" function ajaxPush(id,waititime){\
6748−+ \var cnt=0; \
6749−+ \var id1= $('#'+id);\
6750−+ \var idstatus= $('#'+id+'status');\
6751−+ \var ida= $('#'+id+' a');\
6752−+ \var actionurl='/"++procname++"';\
6753−+ \var dialogOpts = {\
6754−+ \cache: false,\
6755−+ \type: 'GET',\
6756−+ \url: actionurl,\
6757−+ \data: '',\
6758−+ \success: function (resp) {\
6759−+ \idstatus.html('');\
6760−+ \cnt=0;\
6761−+ \id1."++method++"(resp);\
6762−+ \ajaxPush1();\
6763−+ \},\
6764−+ \error: function (xhr, status, error) {\
6765−+ \cnt= cnt + 1;\
6766−+ \if (false) \
6767−+ \idstatus.html('no more retries');\
6768−+ \else {\
6769−+ \idstatus.html('waiting');\
6770−+ \setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\
6771−+ \}\
6772−+ \}\
6773−+ \};\
6774−+ \function ajaxPush1(){\
6775−+ \$.ajax(dialogOpts);\
6776−+ \return false;\
6777−+ \}\
6778−+ \ajaxPush1();\
6779−+ \}"
6780−+
6781−+
6782−+
6783−+
6784−+-- | show the jQuery spinner widget. the first parameter is the configuration . Use \"()\" by default.
6785−+-- See http://jqueryui.com/spinner
6786−+getSpinner
6787−+ :: (MonadIO m, Read a,Show a, Typeable a, FormInput view) =>
6788−+ String -> Maybe a -> View view m a
6789−+getSpinner conf mv= do
6790−+ id <- genNewId
6791−+ let setit= "$(document).ready(function() {\
6792−+ \var spinner = $( '#"++id++"' ).spinner "++conf++";\
6793−+ \spinner.spinner( \"enable\" );\
6794−+ \});"
6795−+ requires
6796−+ [CSSFile jqueryCSS
6797−+ ,JScriptFile jqueryScript []
6798−+ ,JScriptFile jqueryUI [setit]]
6799−+
6800−+ getTextBox mv <! [("id",id)]
6801−+
6802−
6803−-
6804−
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 @@
6808− --
6809− -- lazy temprendering $ img ! href imageurl ++> noWidget
6810− lazy :: (FormInput v,Functor m,MonadIO m) => v -> View v m a -> View v m a
6811−-lazy v w= do
6812−- id <- genNewId
6813−+lazy v w= do
6814−+ id <- genNewId
6815− st <- get
6816− let path = currentPath st
6817−- env = mfEnv st
6818−- r= lookup ("auto"++id) env
6819−- t = mfkillTime st -1
6820−+ env = mfEnv st
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');\
6827− \});"
6828−
6829−--- installscript2= "$(window).one('scroll',function(){\
6830−--- \function lazyexec(){lazy('"++id++"','"++ path ++"',lazyexec)};\
6831−--- \lazyexec()});"
6832−-
6833−-
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
6844−-
6845−- else View $ do
6846−- resetCachePolicy
6847−- st' <- get
6848−- FormElm form mx <- runView w
6849−- setCachePolicy
6850−- let t= mfToken st'
6851−- reqs <- installAllRequirements
6852−- let HttpData ctype c s= toHttpData $ toByteString form
6853−- liftIO . sendFlush t $ HttpData (ctype ++
6854−- mfHttpHeaders st') (mfCookies st' ++ c)
6855−- $ toByteString reqs <> s -- !> (unpack $ toByteString reqs)
6856−- put st'{mfAutorefresh=True,inSync= True}
6857−-
6858−- return $ FormElm mempty mx
6859−-
6860−+
6861−+ else refresh w
6862−
6863− where
6864−
6865−-
6866−-
6867− scrollposition= "$.fn.scrollposition= function(){\
6868− \var pos= $(this).position();\
6869− \if (typeof(pos)==='undefined') {return 1;}\
6870−@@ -1339,24 +1324,37 @@
6871− \lastCall = now;\
6872− \if(id1.scrollposition() > 0){\
6873− \$(window).one('scroll',f);}\
6874−- \else{\
6875−- \var dialogOpts = {\
6876−+ \else{\
6877−+ \var dialogOpts = {\
6878− \type: 'GET',\
6879−- \url: actionurl+'?auto'+id+'=true',\
6880−- \success: function (resp) {\
6881−+ \url: actionurl+'?auto'+id+'=true',\
6882−+ \success: function (resp) {\
6883− \id1.html(resp);\
6884−- \$(window).trigger('scroll');\
6885−+ \$(window).trigger('scroll');\
6886− \},\
6887−- \error: function (xhr, status, error) {\
6888−- \var msg = $('<div>' + xhr + '</div>');\
6889−+ \error: function (xhr, status, error) {\
6890−+ \var msg = $('<div>' + xhr + '</div>');\
6891− \id1.html(msg);\
6892−- \}\
6893−- \};\
6894−- \$.ajax(dialogOpts);\
6895−+ \}\
6896−+ \};\
6897−+ \$.ajax(dialogOpts);\
6898− \}}};"
6899−
6900−+refresh w= View $ do
6901−+ resetCachePolicy
6902−+ modify $ \st -> st{mfAutorefresh=True,inSync= True}
6903−+ FormElm form mx <- runView w -- !> show (mfInstalledScripts st')
6904−+ setCachePolicy
6905−+ st' <- get
6906−+ let t= mfToken st'
6907−+ reqs <- installAllRequirements
6908−+ let HttpData ctype c s= toHttpData $ toByteString form
6909−+ liftIO . sendFlush t $ HttpData (ctype ++
6910−+ mfHttpHeaders st') (mfCookies st' ++ c)
6911−+ $ s <> toByteString reqs
6912−+ return $ FormElm mempty mx
6913−
6914−-waitAndExecute= "function waitAndExecute(sym,f) {\
6915−- \if (eval(sym)) {f();}\
6916−- \else {setTimeout(function() {waitAndExecute(sym,f)}, 50);}\
6917−- \}\n"
6918−+--waitAndExecute= "function waitAndExecute(sym,f) {\
6919−+-- \if (eval(sym)) {f();}\
6920−+-- \else {setTimeout(function() {waitAndExecute(sym,f)}, 50);}\
6921−+-- \}\n"
6922−diff -ru orig/src/MFlow/Forms/XHtml.hs new/src/MFlow/Forms/XHtml.hs
6923−--- orig/src/MFlow/Forms/XHtml.hs 2014-06-10 05:51:26.973015856 +0300
6924−+++ new/src/MFlow/Forms/XHtml.hs 2014-06-10 05:51:25.000000000 +0300
6925−@@ -1,66 +1,66 @@
6926−------------------------------------------------------------------------------
6927−---
6928−--- Module : Control.MessageFlow.Forms.XHtml
6929−--- Copyright : Alberto Gónez Corona
6930−--- License : BSD3
6931−---
6932−--- Maintainer : agocorona@gmail.com
6933−--- Stability : experimental
6934−---
6935−------------------------------------------------------------------------------
6936−-{- | Instances of `FormInput` for the 'Text.XHtml' module of the xhtml package
6937−--}
6938−-
6939−-{-# OPTIONS -XMultiParamTypeClasses
6940−- -XFlexibleInstances
6941−- -XUndecidableInstances
6942−- -XTypeSynonymInstances
6943−- -XFlexibleContexts
6944−- -XTypeOperators
6945−- #-}
6946−-
6947−-
6948−-module MFlow.Forms.XHtml where
6949−-
6950−-import MFlow (HttpData(..))
6951−-import MFlow.Forms
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
6958−-
6959−-instance Monad m => ADDATTRS (View Html m a) where
6960−- widget ! atrs= widget `wmodify` \fs mx -> return ((head fs ! atrs:tail fs), mx)
6961−-
6962−-
6963−-
6964−-instance FormInput Html where
6965−- toByteString = pack. showHtmlFragment
6966−- toHttpData = HttpData [contentHtml] [] . toByteString
6967−- ftag t= tag t
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
6972−-
6973−- fselect name list = select ![ X.name name] << list
6974−- foption name v msel= X.option ! ([value name] ++ selected msel) << v
6975−- where
6976−- selected msel = if msel then [X.selected] else []
6977−-
6978−- attrs tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs)
6979−-
6980−-
6981−-
6982−- formAction action form = X.form ! [X.action action, method "post"] << form
6983−- fromStr = stringToHtml
6984−- fromStrNoEncode= primHtml
6985−-
6986−- flink v str = toHtml $ hotlink ( v) << str
6987−-
6988−-instance Typeable Html where
6989−- typeOf = \_ -> mkTyConApp (mkTyCon3 "xhtml" "Text.XHtml.Strict" "Html") []
6990−-
6991−-
6992−+-----------------------------------------------------------------------------
6993−+--
6994−+-- Module : Control.MessageFlow.Forms.XHtml
6995−+-- Copyright : Alberto Gónez Corona
6996−+-- License : BSD3
6997−+--
6998−+-- Maintainer : agocorona@gmail.com
6999−+-- Stability : experimental
7000−+--
7001−+-----------------------------------------------------------------------------
7002−+{- | Instances of `FormInput` for the 'Text.XHtml' module of the xhtml package
7003−+-}
7004−+
7005−+{-# OPTIONS -XMultiParamTypeClasses
7006−+ -XFlexibleInstances
7007−+ -XUndecidableInstances
7008−+ -XTypeSynonymInstances
7009−+ -XFlexibleContexts
7010−+ -XTypeOperators
7011−+ #-}
7012−+
7013−+
7014−+module MFlow.Forms.XHtml where
7015−+
7016−+import MFlow (HttpData(..))
7017−+import MFlow.Forms
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
7024−+
7025−+instance Monad m => ADDATTRS (View Html m a) where
7026−+ widget ! atrs= widget `wmodify` \fs mx -> return ((head fs ! atrs:tail fs), mx)
7027−+
7028−+
7029−+
7030−+instance FormInput Html where
7031−+ toByteString = pack. showHtmlFragment
7032−+ toHttpData = HttpData [contentHtml] [] . toByteString
7033−+ ftag t= tag t
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
7038−+
7039−+ fselect name list = select ![ X.name name] << list
7040−+ foption name v msel= X.option ! ([value name] ++ selected msel) << v
7041−+ where
7042−+ selected msel = if msel then [X.selected] else []
7043−+
7044−+ attrs tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs)
7045−+
7046−+
7047−+
7048−+ formAction action form = X.form ! [X.action action, method "post"] << form
7049−+ fromStr = stringToHtml
7050−+ fromStrNoEncode= primHtml
7051−+
7052−+ flink v str = toHtml $ hotlink ( v) << str
7053−+
7054−+instance Typeable Html where
7055−+ typeOf = \_ -> mkTyConApp (mkTyCon3 "xhtml" "Text.XHtml.Strict" "Html") []
7056−+
7057−+
7058−diff -ru orig/src/MFlow/Forms.hs new/src/MFlow/Forms.hs
7059−--- orig/src/MFlow/Forms.hs 2014-06-10 05:51:26.961015857 +0300
7060−+++ new/src/MFlow/Forms.hs 2014-06-10 05:51:25.000000000 +0300
7061−@@ -1,1039 +1,1047 @@
7062−-{-# OPTIONS -XDeriveDataTypeable
7063−- -XUndecidableInstances
7064−- -XExistentialQuantification
7065−- -XMultiParamTypeClasses
7066−- -XTypeSynonymInstances
7067−- -XFlexibleInstances
7068−- -XScopedTypeVariables
7069−- -XFunctionalDependencies
7070−- -XFlexibleContexts
7071−- -XRecordWildCards
7072−- -XIncoherentInstances
7073−- -XTypeFamilies
7074−- -XTypeOperators
7075−- -XOverloadedStrings
7076−- -XTemplateHaskell
7077−- -XNoMonomorphismRestriction
7078−-
7079−-#-}
7080−-
7081−-{- |
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.
7084−-
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.
7088−-
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.
7094−-
7095−-
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
7100−-
7101−-The MFlow architecture is scalable, since the state is serializable and small
7102−-
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.
7106−-
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.
7110−-
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.
7113−-
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
7116−-
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>
7119−-
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.
7123−-
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.
7128−-
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.
7132−-
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.
7140−-
7141−-* APPLICATION SERVER
7142−-
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.
7146−-
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.
7150−-
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)
7155−-
7156−-* WIDGETS
7157−-
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.
7162−-
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.
7168−-
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.
7174−-
7175−-* NEW IN THIS RELEASE
7176−-
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'.
7181−-
7182−-* IN PREVIOUS RELEASES
7183−-
7184−-{@AutoRefresh@] Using `autoRefresh`, Dynamic widgets can refresh themselves with new information without forcing a refresh of the whole page
7185−-
7186−-[@Push@] With `push` a widget can push new content to the browser when something in the server happens
7187−-
7188−-[@Error traces@] using the monadloc package, now each runtime error (in a monadic statement) has a complete execution trace.
7189−-
7190−-
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.
7193−-
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.
7197−-
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)
7201−-
7202−-[@JQuery widgets@] with MFlow interface: 'getSpinner', 'datePicker', 'wdialog'
7203−-
7204−-[@WAI interface@] Now MFlow works with Snap and other WAI developments. Include "MFlow.Wai" or "MFlow.Wai.Blaze.Html.All" to use it.
7205−-
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
7207−-
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').
7210−-
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.
7213−-
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'
7216−-
7217−-[@content-management@] for templating and online edition of the content template. See 'tFieldEd' 'tFieldGen' and 'tField'
7218−-
7219−-[@multilanguage@] see 'mField' and 'mFieldEd'
7220−-
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.
7224−-
7225−-
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>)
7229−-
7230−-
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.
7234−-
7235−-
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.
7240−-
7241−-
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.
7244−-
7245−-Example:
7246−-
7247−-@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@
7248−-
7249−-
7250−-[@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator
7251−-
7252−-
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.
7257−-
7258−-[@File Server@] With file caching. See "MFlow.FileServer"
7259−-
7260−-
7261−--}
7262−-
7263−-module MFlow.Forms(
7264−-
7265−--- * Basic definitions
7266−--- FormLet(..),
7267−-FlowM, View(..), FormElm(..), FormInput(..)
7268−-
7269−--- * Users
7270−-, Auth(..), userRegister, setAuthMethod, userValidate, isLogged, setAdminUser, getAdminName
7271−-,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, paranoidLogout
7272−-,encryptedLogout, userWidget, paranoidUserWidget, encryptedUserWidget, login, paranoidLogin, encryptedLogin,
7273−-userName,
7274−--- * User interaction
7275−-ask, page, askt, clearEnv, wstateless, pageFlow,
7276−--- * formLets
7277−--- | They usually produce the HTML form elements (depending on the FormInput instance used)
7278−--- It is possible to modify their attributes with the `<!` operator.
7279−--- They are combined with applicative ombinators and some additional ones
7280−--- formatting can be added with the formatting combinators.
7281−--- modifiers change their presentation and behaviour
7282−-getString,getInt,getInteger, getTextBox
7283−-,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,
7284−-getRadio, setRadio, setRadioActive, wlabel, getCheckBoxes, genCheckBoxes, setCheckBox,
7285−-submitButton,resetButton, whidden, wlink, absLink, getKeyValueParam,
7286−+{-# OPTIONS -XDeriveDataTypeable
7287−+ -XUndecidableInstances
7288−+ -XExistentialQuantification
7289−+ -XMultiParamTypeClasses
7290−+ -XTypeSynonymInstances
7291−+ -XFlexibleInstances
7292−+ -XScopedTypeVariables
7293−+ -XFunctionalDependencies
7294−+ -XFlexibleContexts
7295−+ -XRecordWildCards
7296−+ -XIncoherentInstances
7297−+ -XTypeFamilies
7298−+ -XTypeOperators
7299−+ -XOverloadedStrings
7300−+ -XTemplateHaskell
7301−+ -XNoMonomorphismRestriction
7302−+
7303−+#-}
7304−+
7305−+{- |
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.
7308−+
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.
7312−+
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.
7318−+
7319−+
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
7324−+
7325−+The MFlow architecture is scalable, since the state is serializable and small
7326−+
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.
7330−+
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.
7334−+
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.
7337−+
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
7340−+
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>
7343−+
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.
7347−+
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.
7352−+
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.
7356−+
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.
7364−+
7365−+* APPLICATION SERVER
7366−+
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.
7370−+
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.
7374−+
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)
7379−+
7380−+* WIDGETS
7381−+
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.
7386−+
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.
7392−+
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.
7398−+
7399−+* NEW IN THIS RELEASE
7400−+
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'.
7405−+
7406−+* IN PREVIOUS RELEASES
7407−+
7408−+{@AutoRefresh@] Using `autoRefresh`, Dynamic widgets can refresh themselves with new information without forcing a refresh of the whole page
7409−+
7410−+[@Push@] With `push` a widget can push new content to the browser when something in the server happens
7411−+
7412−+[@Error traces@] using the monadloc package, now each runtime error (in a monadic statement) has a complete execution trace.
7413−+
7414−+
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.
7417−+
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.
7421−+
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)
7425−+
7426−+[@JQuery widgets@] with MFlow interface: 'getSpinner', 'datePicker', 'wdialog'
7427−+
7428−+[@WAI interface@] Now MFlow works with Snap and other WAI developments. Include "MFlow.Wai" or "MFlow.Wai.Blaze.Html.All" to use it.
7429−+
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
7431−+
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').
7434−+
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.
7437−+
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'
7440−+
7441−+[@content-management@] for templating and online edition of the content template. See 'tFieldEd' 'tFieldGen' and 'tField'
7442−+
7443−+[@multilanguage@] see 'mField' and 'mFieldEd'
7444−+
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.
7448−+
7449−+
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>)
7453−+
7454−+
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.
7458−+
7459−+
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.
7464−+
7465−+
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.
7468−+
7469−+Example:
7470−+
7471−+@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@
7472−+
7473−+
7474−+[@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator
7475−+
7476−+
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.
7481−+
7482−+[@File Server@] With file caching. See "MFlow.FileServer"
7483−+
7484−+
7485−+-}
7486−+
7487−+module MFlow.Forms(
7488−+
7489−+-- * Basic definitions
7490−+-- FormLet(..),
7491−+FlowM, View(..), FormElm(..), FormInput(..)
7492−+
7493−+-- * Users
7494−+, Auth(..), userRegister, setAuthMethod, userValidate, isLogged, setAdminUser, getAdminName
7495−+,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, paranoidLogout
7496−+,encryptedLogout, userWidget, paranoidUserWidget, encryptedUserWidget, login, paranoidLogin, encryptedLogin,
7497−+userName,
7498−+-- * User interaction
7499−+ask, page, askt, clearEnv, wstateless, pageFlow,
7500−+-- * formLets
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,
7513−-
7514−--- * Caching widgets
7515−-cachedWidget, wcached, wfreeze,
7516−-
7517−--- * Widget combinators
7518−-(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)
7519−-
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
7522−-----
7523−----- The purpose is to combine heterogeneous formats into byteString-formatted widgets that
7524−----- can be cached with `cachedWidget`
7525−---,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
7526−-
7527−--- * Formatting combinators
7528−-,(<<<),(++>),(<++),(<!)
7529−-
7530−----- * Normalized (convert to ByteString) formatting combinators
7531−----- | Some combinators that convert the formatting of their arguments to lazy byteString
7532−-----(.<<.),(.<++.),(.++>.)
7533−-
7534−--- * ByteString tags
7535−-,btag,bhtml,bbody
7536−-
7537−--- * Normalization
7538−-,flatten, normalize
7539−-
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
7545−-
7546−+-- * FormLet modifiers
7547−+,validate, noWidget, stop, waction, wcallback, wmodify,
7548−+
7549−+-- * Caching widgets
7550−+cachedWidget, wcached, wfreeze,
7551−+
7552−+-- * Widget combinators
7553−+(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)
7554−+
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
7557−+----
7558−+---- The purpose is to combine heterogeneous formats into byteString-formatted widgets that
7559−+---- can be cached with `cachedWidget`
7560−+--,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
7561−+
7562−+-- * Formatting combinators
7563−+,(<<<),(++>),(<++),(<!)
7564−+
7565−+---- * Normalized (convert to ByteString) formatting combinators
7566−+---- | Some combinators that convert the formatting of their arguments to lazy byteString
7567−+----(.<<.),(.<++.),(.++>.)
7568−+
7569−+-- * ByteString tags
7570−+,btag,bhtml,bbody
7571−+
7572−+-- * Normalization
7573−+,flatten, normalize
7574−+
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
7580−+
7581− -- * Setting parameters
7582−-,setHttpHeader
7583−-,setHeader
7584−-,addHeader
7585−-,getHeader
7586−-,setSessionData
7587−+,setHttpHeader
7588−+,setHeader
7589−+,addHeader
7590−+,getHeader
7591−+,setSessionData
7592− ,getSessionData
7593−-,getSData
7594−-,delSessionData
7595−-,setTimeouts
7596−-
7597−--- * Cookies
7598−-,setCookie
7599−-,setParanoidCookie
7600−-,setEncryptedCookie
7601−--- * Ajax
7602−-,ajax
7603−-,ajaxSend
7604−-,ajaxSend_
7605−--- * Requirements
7606−-,Requirements(..)
7607−-,WebRequirement(..)
7608−-,requires
7609−+,getSData
7610−+,delSessionData
7611−+,setTimeouts
7612−+
7613−+-- * Cookies
7614−+,setCookie
7615−+,setParanoidCookie
7616−+,setEncryptedCookie
7617−+-- * Ajax
7618−+,ajax
7619−+,ajaxSend
7620−+,ajaxSend_
7621−+-- * Requirements
7622−+,Requirements(..)
7623−+,WebRequirement(..)
7624−+,requires
7625− -- * Utility
7626−-,getSessionId
7627−-,getLang
7628−-,genNewId
7629−-,getNextId
7630−-,changeMonad
7631−-,FailBack
7632−-,fromFailBack
7633−-,toFailBack
7634−-
7635−-)
7636−-where
7637−-
7638−-import Data.RefSerialize hiding ((<|>),empty)
7639−-import Data.TCache
7640−-import Data.TCache.Memoization
7641−-import MFlow
7642−-import MFlow.Forms.Internals
7643−-import MFlow.Cookies
7644−+,getSessionId
7645−+,getLang
7646−+,genNewId
7647−+,getNextId
7648−+,changeMonad
7649−+,FailBack
7650−+,fromFailBack
7651−+,toFailBack
7652−+
7653−+)
7654−+where
7655−+
7656−+import Data.RefSerialize hiding ((<|>),empty)
7657−+import Data.TCache
7658−+import Data.TCache.Memoization
7659−+import MFlow
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
7667−-import Data.List
7668−---import qualified Data.CaseInsensitive as CI
7669−-import Data.Typeable
7670−-import Data.Monoid
7671−-import Control.Monad.State.Strict
7672−-import Data.Maybe
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)
7680−-import Data.IORef
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
7686−-
7687−--- | Validates a form or widget result against a validating procedure
7688−---
7689−--- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@
7690−-validate
7691−- :: (FormInput view, Monad m) =>
7692−- View view m a
7693−- -> (a -> WState view m (Maybe view))
7694−- -> View view m a
7695−-validate formt val= View $ do
7696−- FormElm form mx <- runView formt
7697−- case mx of
7698−- Just x -> do
7699−- me <- val x
7700−- modify (\s -> s{inSync= True})
7701−- case me of
7702−- Just str ->
7703−- return $ FormElm ( form <> inred str) Nothing
7704−- Nothing -> return $ FormElm form mx
7705−- _ -> return $ FormElm form mx
7706−-
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
7710−--- calling page.
7711−--- It is useful when the widget is inside widget containers that may treat it as a black box.
7712−---
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`
7715−-waction
7716−- :: (FormInput view, Monad m)
7717−- => View view m a
7718−- -> (a -> FlowM view m b)
7719−- -> View view m b
7720−-waction f ac = do
7721−- x <- f
7722−- s <- get
7723−- let env = mfEnv s
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}
7728−- return r
7729−- where
7730−- flowToView x=
7731−- View $ do
7732−- r <- runSup $ runFlowM x
7733−- case r of
7734−- NoBack x ->
7735−- return (FormElm mempty $ Just x)
7736−- BackPoint x->
7737−- return (FormElm mempty $ Just x)
7738−- GoBack-> do
7739−- modify $ \s ->s{notSyncInAction= True}
7740−- return (FormElm mempty Nothing)
7741−-
7742−--- | change the rendering and the return value of a page. This is superseeded by page flows.
7743−-wmodify :: (Monad m, FormInput v)
7744−- => View v m a
7745−- -> (v -> Maybe a -> WState v m (v, Maybe b))
7746−- -> View v m b
7747−-wmodify formt act = View $ do
7748−- FormElm f mx <- runView formt
7749−- (f',mx') <- act f mx
7750−- return $ FormElm f' mx'
7751−-
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
7756−- `validate`
7757−- \s -> if null s then return (Just $ fromStr "")
7758−- else return Nothing
7759−-
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
7764−-
7765−--- | Display a text box and return a Int (if the value entered is not an Int, fails the validation)
7766−-getInt :: (FormInput view, MonadIO m) =>
7767−- Maybe Int -> View view m Int
7768−-getInt = getTextBox
7769−-
7770−--- | Display a password box
7771−-getPassword :: (FormInput view,
7772−- Monad m) =>
7773−- View view m String
7774−-getPassword = getParam Nothing "password" Nothing
7775−-
7776−-newtype Radio a= Radio a
7777−-
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
7784−- st <- get
7785−- put st{needForm= HasElems}
7786−- let env = mfEnv st
7787−- mn <- getParam1 n env
7788−- let str = if typeOf v == typeOf(undefined :: String)
7789−- then unsafeCoerce v else show v
7790−- return $ FormElm (finput n "radio" str
7791−- ( isValidated mn && v== fromValidated mn) (Just "this.form.submit()"))
7792−- (fmap Radio $ valToMaybe mn)
7793−-
7794−-
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
7801−- st <- get
7802−- put st{needForm= HasElems}
7803−- let env = mfEnv st
7804−- mn <- getParam1 n env
7805−- let str = if typeOf v == typeOf(undefined :: String)
7806−- then unsafeCoerce v else show v
7807−- return $ FormElm (finput n "radio" str
7808−- ( isValidated mn && v== fromValidated mn) Nothing)
7809−- (fmap Radio $ valToMaybe mn)
7810−-
7811−--- | encloses a set of Radio boxes. Return the option selected
7812−-getRadio
7813−- :: (Monad m, Functor m, FormInput view) =>
7814−- [String -> View view m (Radio a)] -> View view m a
7815−-getRadio rs= do
7816−- id <- genNewId
7817−- Radio r <- firstOf $ map (\r -> r id) rs
7818−- return r
7819−-
7820−-data CheckBoxes = CheckBoxes [String]
7821−-
7822−-instance Monoid CheckBoxes where
7823−- mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
7824−- mempty= CheckBoxes []
7825−-
7826−---instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where
7827−--- mappend x y= mappend <$> x <*> y
7828−--- mempty= return (CheckBoxes [])
7829−-
7830−-
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
7835−- n <- genNewId
7836−- st <- get
7837−- put st{needForm= HasElems}
7838−- let env = mfEnv st
7839−- strs= map snd $ filter ((==) n . fst) env
7840−- mn= if null strs then Nothing else Just $ head strs
7841−- val = inSync st
7842−- let ret= case val of -- !> show val of
7843−- True -> Just $ CheckBoxes strs -- !> show strs
7844−- False -> Nothing
7845−- return $ FormElm
7846−- ( finput n "checkbox" v
7847−- ( checked || (isJust mn && v== fromJust mn)) Nothing)
7848−- ret
7849−-
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
7854−- n <- genNewId
7855−- st <- get
7856−- put st{needForm= HasElems}
7857−- let env = mfEnv st
7858−- strs= map snd $ filter ((==) n . fst) env
7859−- mn= if null strs then Nothing else Just $ head strs
7860−-
7861−- val <- gets inSync
7862−- let ret= case val of
7863−- True -> Just $ CheckBoxes strs
7864−- False -> Nothing
7865−- return $ FormElm (ftag "span" v `attrs`[("id",n)]) ret
7866−-
7867−-whidden :: (Monad m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
7868−-whidden x= View $ do
7869−- n <- genNewId
7870−- env <- gets mfEnv
7871−- let showx= case cast x of
7872−- Just x' -> x'
7873−- Nothing -> show x
7874−- r <- getParam1 n env
7875−- return . FormElm (finput n "hidden" showx False Nothing) $ valToMaybe r
7876−-
7877−-getCheckBoxes :: (FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]
7878−-getCheckBoxes boxes = View $ do
7879−- n <- genNewId
7880−- st <- get
7881−- let env = mfEnv st
7882−- let form= finput n "hidden" "" False Nothing
7883−- mr <- getParam1 n env
7884−-
7885−- let env = mfEnv st
7886−- modify $ \st -> st{needForm= HasElems}
7887−- FormElm form2 mr2 <- runView boxes
7888−- return $ FormElm (form <> form2) $
7889−- case (mr `asTypeOf` Validated ("" :: String),mr2) of
7890−- (NoParam,_) -> Nothing
7891−- (Validated _,Nothing) -> Just []
7892−- (Validated _, Just (CheckBoxes rs)) -> Just rs
7893−-
7894−-
7895−-
7896−-
7897−-
7898−-getTextBox
7899−- :: (FormInput view,
7900−- Monad m,
7901−- Typeable a,
7902−- Show a,
7903−- Read a) =>
7904−- Maybe a -> View view m a
7905−-getTextBox ms = getParam Nothing "text" ms
7906−-
7907−-
7908−-getParam
7909−- :: (FormInput view,
7910−- Monad m,
7911−- Typeable a,
7912−- Show a,
7913−- Read a) =>
7914−- Maybe String -> String -> Maybe a -> View view m a
7915−-getParam look type1 mvalue = View $ do
7916−- tolook <- case look of
7917−- Nothing -> genNewId
7918−- Just n -> return n
7919−- let nvalue x = case x of
7920−- Nothing -> ""
7921−- Just v ->
7922−- case cast v of
7923−- Just v' -> v'
7924−- Nothing -> show v
7925−- st <- get
7926−- let env = mfEnv st
7927−- put st{needForm= HasElems}
7928−- r <- getParam1 tolook env
7929−- case r of
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
7933−-
7934−-
7935−-
7936−---getCurrentName :: MonadState (MFlowState view) m => m String
7937−---getCurrentName= do
7938−--- st <- get
7939−--- let parm = mfSequence st
7940−--- return $ "p"++show parm
7941−-
7942−-
7943−--- | Display a multiline text box and return its content
7944−-getMultilineText :: (FormInput view
7945−- , Monad m)
7946−- => T.Text
7947−- -> View view m T.Text
7948−-getMultilineText nvalue = View $ do
7949−- tolook <- genNewId
7950−- env <- gets mfEnv
7951−- r <- getParam1 tolook env
7952−- case r of
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
7956−-
7957−-
7958−---instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where
7959−--- digest mv = getBool b "True" "False"
7960−--- where
7961−--- b= case mv of
7962−--- Nothing -> Nothing
7963−--- Just bool -> Just $ case bool of
7964−--- True -> "True"
7965−--- False -> "False"
7966−-
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
7976−-
7977−-
7978−-
7979−--- | Display a dropdown box with the options in the first parameter is optionally selected
7980−--- . It returns the selected option.
7981−-getSelect :: (FormInput view,
7982−- Monad m,Typeable a, Read a) =>
7983−- View view m (MFOption a) -> View view m a
7984−-getSelect opts = View $ do
7985−- tolook <- genNewId
7986−- st <- get
7987−- let env = mfEnv st
7988−- put st{needForm= HasElems}
7989−- r <- getParam1 tolook env
7990−- setSessionData $ fmap MFOption $ valToMaybe r
7991−- FormElm form mr <- (runView opts)
7992−-
7993−- return $ FormElm (fselect tolook form) $ valToMaybe r
7994−-
7995−-
7996−-newtype MFOption a= MFOption a deriving Typeable
7997−-
7998−-instance (FormInput view,Monad m, Functor m) => Monoid (View view m (MFOption a)) where
7999−- mappend = (<|>)
8000−- mempty = Control.Applicative.empty
8001−-
8002−--- | Set the option for getSelect. Options are concatenated with `<|>`
8003−-setOption
8004−- :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
8005−- a -> view -> View view m (MFOption a)
8006−-setOption n v = do
8007−- mo <- getSessionData
8008−- case mo of
8009−- Nothing -> setOption1 n v False
8010−- Just Nothing -> setOption1 n v False
8011−- Just (Just (MFOption o)) -> setOption1 n v $ n == o
8012−-
8013−--- | Set the selected option for getSelect. Options are concatenated with `<|>`
8014−-setSelectedOption
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
8019−- case mo of
8020−- Nothing -> setOption1 n v True
8021−- Just Nothing -> setOption1 n v True
8022−- Just (Just o) -> setOption1 n v $ n == o
8023−-
8024−-
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
8029−- st <- get
8030−- let env = mfEnv st
8031−- put st{needForm= HasElems}
8032−- let n = if typeOf nam == typeOf(undefined :: String)
8033−- then unsafeCoerce nam
8034−- else show nam
8035−-
8036−- return . FormElm (foption n val check) . Just $ MFOption nam
8037−-
8038−---fileUpload :: (FormInput view,
8039−--- Monad m) =>
8040−--- View view m T.Text
8041−---fileUpload= getParam Nothing "file" Nothing
8042−-
8043−-
8044−--- | Enclose Widgets within some formating.
8045−--- @view@ is intended to be instantiated to a particular format
8046−---
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.
8050−---
8051−--- This is a widget, which is a table with some links. it returns an Int
8052−---
8053−--- > import MFlow.Forms.Blaze.Html
8054−--- >
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")
8059−--- > ++> (tbody
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))))
8064−--- > )
8065−-(<<<) :: (Monad m, Monoid view)
8066−- => (view ->view)
8067−- -> View view m a
8068−- -> View view m a
8069−-(<<<) v form= View $ do
8070−- FormElm f mx <- runView form
8071−- return $ FormElm (v f) mx
8072−-
8073−-
8074−-infixr 5 <<<
8075−-
8076−-
8077−-
8078−-
8079−-
8080−-
8081−--- | Append formatting code to a widget
8082−---
8083−--- @ getString "hi" <++ H1 << "hi there"@
8084−---
8085−--- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
8086−-(<++) :: (Monad m, Monoid v)
8087−- => View v m a
8088−- -> v
8089−- -> View v m a
8090−-(<++) form v= View $ do
8091−- FormElm f mx <- runView form
8092−- return $ FormElm ( f <> v) mx
8093−-
8094−-infixr 6 ++>
8095−-infixr 6 <++
8096−--- | Prepend formatting code to a widget
8097−---
8098−--- @bold << "enter name" ++> getString Nothing @
8099−---
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
8104−- View $ do
8105−- FormElm f mx <- runView w
8106−- return $ FormElm (html <> f) mx
8107−-
8108−-
8109−-
8110−--- | Add attributes to the topmost tag of a widget
8111−---
8112−--- it has a fixity @infix 8@
8113−-infixl 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
8117−--- case fs of
8118−--- [hfs] -> return $ FormElm [hfs `attrs` attribs] mx
8119−--- _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs
8120−-
8121−-
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
8127−---
8128−--- @ userFormLine=
8129−--- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\")
8130−--- \<\+\> fromStr \" password again\" \+\> getPassword \<\* submitButton \"register\"
8131−--- @
8132−-userFormLine :: (FormInput view, Functor m, Monad m)
8133−- => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr)
8134−-userFormLine=
8135−- ((,) <$> getString (Just "enter user") <! [("size","5")]
8136−- <*> getPassword <! [("size","5")]
8137−- <** submitButton "login")
8138−- <+> (fromStr " password again" ++> getPassword <! [("size","5")]
8139−- <** submitButton "register")
8140−-
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)
8144−-userLogin=
8145−- ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")]
8146−- <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]
8147−- <** submitButton "login")
8148−- <+> (noWidget
8149−- <* noWidget)
8150−-
8151−-
8152−-
8153−--- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets.
8154−---
8155−--- It returns a non valid value.
8156−-noWidget :: (FormInput view,
8157−- Monad m, Functor m) =>
8158−- View view m a
8159−-noWidget= Control.Applicative.empty
8160−+import qualified Data.String as S
8161−+import qualified Data.Text as T
8162−+import Data.Text.Encoding
8163−+import Data.List
8164−+--import qualified Data.CaseInsensitive as CI
8165−+import Data.Typeable
8166−+import Data.Monoid
8167−+import Control.Monad.State.Strict
8168−+import Data.Maybe
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)
8176−+import Data.IORef
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
8182−+
8183−+-- | Validates a form or widget result against a validating procedure
8184−+--
8185−+-- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@
8186−+validate
8187−+ :: (FormInput view, Monad m) =>
8188−+ View view m a
8189−+ -> (a -> WState view m (Maybe view))
8190−+ -> View view m a
8191−+validate formt val= View $ do
8192−+ FormElm form mx <- runView formt
8193−+ case mx of
8194−+ Just x -> do
8195−+ me <- val x
8196−+ modify (\s -> s{inSync= True})
8197−+ case me of
8198−+ Just str ->
8199−+ return $ FormElm ( form <> inred str) Nothing
8200−+ Nothing -> return $ FormElm form mx
8201−+ _ -> return $ FormElm form mx
8202−+
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
8206−+-- calling page.
8207−+-- It is useful when the widget is inside widget containers that may treat it as a black box.
8208−+--
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`
8211−+waction
8212−+ :: (FormInput view, Monad m)
8213−+ => View view m a
8214−+ -> (a -> FlowM view m b)
8215−+ -> View view m b
8216−+waction f ac = do
8217−+ x <- f
8218−+ s <- get
8219−+ let env = mfEnv s
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}
8224−+ return r
8225−+ where
8226−+ flowToView x=
8227−+ View $ do
8228−+ r <- runSup $ runFlowM x
8229−+ case r of
8230−+ NoBack x ->
8231−+ return (FormElm mempty $ Just x)
8232−+ BackPoint x->
8233−+ return (FormElm mempty $ Just x)
8234−+ GoBack-> do
8235−+ modify $ \s ->s{notSyncInAction= True}
8236−+ return (FormElm mempty Nothing)
8237−+
8238−+-- | change the rendering and the return value of a page. This is superseeded by page flows.
8239−+wmodify :: (Monad m, FormInput v)
8240−+ => View v m a
8241−+ -> (v -> Maybe a -> WState v m (v, Maybe b))
8242−+ -> View v m b
8243−+wmodify formt act = View $ do
8244−+ FormElm f mx <- runView formt
8245−+ (f',mx') <- act f mx
8246−+ return $ FormElm f' mx'
8247−+
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
8252−+ `validate`
8253−+ \s -> if null s then return (Just $ fromStr "")
8254−+ else return Nothing
8255−+
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
8260−+
8261−+-- | Display a text box and return a Int (if the value entered is not an Int, fails the validation)
8262−+getInt :: (FormInput view, MonadIO m) =>
8263−+ Maybe Int -> View view m Int
8264−+getInt = getTextBox
8265−+
8266−+-- | Display a password box
8267−+getPassword :: (FormInput view,
8268−+ Monad m) =>
8269−+ View view m String
8270−+getPassword = getParam Nothing "password" Nothing
8271−+
8272−+newtype Radio a= Radio a
8273−+
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
8280−+ st <- get
8281−+ put st{needForm= HasElems }
8282−+ let env = mfEnv st
8283−+ mn <- getParam1 n env
8284−+ let str = if typeOf v == typeOf(undefined :: String)
8285−+ then unsafeCoerce v else show v
8286−+ return $ FormElm (finput n "radio" str
8287−+ ( isValidated mn && v== fromValidated mn) (Just "this.form.submit()"))
8288−+ (fmap Radio $ valToMaybe mn)
8289−+
8290−+
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
8297−+ st <- get
8298−+ put st{needForm= HasElems}
8299−+ let env = mfEnv st
8300−+ mn <- getParam1 n env
8301−+ let str = if typeOf v == typeOf(undefined :: String)
8302−+ then unsafeCoerce v else show v
8303−+ return $ FormElm (finput n "radio" str
8304−+ ( isValidated mn && v== fromValidated mn) Nothing)
8305−+ (fmap Radio $ valToMaybe mn)
8306−+
8307−+-- | encloses a set of Radio boxes. Return the option selected
8308−+getRadio
8309−+ :: (Monad m, Functor m, FormInput view) =>
8310−+ [String -> View view m (Radio a)] -> View view m a
8311−+getRadio rs= do
8312−+ id <- genNewId
8313−+ Radio r <- firstOf $ map (\r -> r id) rs
8314−+ return r
8315−+
8316−+data CheckBoxes = CheckBoxes [String]
8317−+
8318−+instance Monoid CheckBoxes where
8319−+ mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
8320−+ mempty= CheckBoxes []
8321−+
8322−+--instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where
8323−+-- mappend x y= mappend <$> x <*> y
8324−+-- mempty= return (CheckBoxes [])
8325−+
8326−+
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
8331−+ n <- genNewId
8332−+ st <- get
8333−+ put st{needForm= HasElems}
8334−+ let env = mfEnv st
8335−+ strs= map snd $ filter ((==) n . fst) env
8336−+ mn= if null strs then Nothing else Just $ head strs
8337−+ val = inSync st
8338−+ let ret= case val of -- !> show val of
8339−+ True -> Just $ CheckBoxes strs -- !> show strs
8340−+ False -> Nothing
8341−+ return $ FormElm
8342−+ ( finput n "checkbox" v
8343−+ ( checked || (isJust mn && v== fromJust mn)) Nothing)
8344−+ ret
8345−+
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
8350−+ n <- genNewId
8351−+ st <- get
8352−+ put st{needForm= HasElems}
8353−+ let env = mfEnv st
8354−+ strs= map snd $ filter ((==) n . fst) env
8355−+ mn= if null strs then Nothing else Just $ head strs
8356−+
8357−+ val <- gets inSync
8358−+ let ret= case val of
8359−+ True -> Just $ CheckBoxes strs
8360−+ False -> Nothing
8361−+ return $ FormElm (ftag "span" v `attrs`[("id",n)]) ret
8362−+
8363−+whidden :: (Monad m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
8364−+whidden x= View $ do
8365−+ n <- genNewId
8366−+ env <- gets mfEnv
8367−+ let showx= case cast x of
8368−+ Just x' -> x'
8369−+ Nothing -> show x
8370−+ r <- getParam1 n env
8371−+ return . FormElm (finput n "hidden" showx False Nothing) $ valToMaybe r
8372−+
8373−+getCheckBoxes :: (FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]
8374−+getCheckBoxes boxes = View $ do
8375−+ n <- genNewId
8376−+ st <- get
8377−+ let env = mfEnv st
8378−+ let form= finput n "hidden" "" False Nothing
8379−+ mr <- getParam1 n env
8380−+
8381−+ let env = mfEnv st
8382−+ modify $ \st -> st{needForm= HasElems}
8383−+ FormElm form2 mr2 <- runView boxes
8384−+ return $ FormElm (form <> form2) $
8385−+ case (mr `asTypeOf` Validated ("" :: String),mr2) of
8386−+ (NoParam,_) -> Nothing
8387−+ (Validated _,Nothing) -> Just []
8388−+ (Validated _, Just (CheckBoxes rs)) -> Just rs
8389−+
8390−+
8391−+
8392−+
8393−+
8394−+getTextBox
8395−+ :: (FormInput view,
8396−+ Monad m,
8397−+ Typeable a,
8398−+ Show a,
8399−+ Read a) =>
8400−+ Maybe a -> View view m a
8401−+getTextBox ms = getParam Nothing "text" ms
8402−+
8403−+
8404−+getParam
8405−+ :: (FormInput view,
8406−+ Monad m,
8407−+ Typeable a,
8408−+ Show a,
8409−+ Read a) =>
8410−+ Maybe String -> String -> Maybe a -> View view m a
8411−+getParam look type1 mvalue = View $ do
8412−+ tolook <- case look of
8413−+ Nothing -> genNewId
8414−+ Just n -> return n
8415−+ let nvalue x = case x of
8416−+ Nothing -> ""
8417−+ Just v ->
8418−+ case cast v of
8419−+ Just v' -> v'
8420−+ Nothing -> show v
8421−+ st <- get
8422−+ let env = mfEnv st
8423−+ put st{needForm= HasElems}
8424−+ r <- getParam1 tolook env
8425−+ case r of
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
8429−+
8430−+
8431−+
8432−+--getCurrentName :: MonadState (MFlowState view) m => m String
8433−+--getCurrentName= do
8434−+-- st <- get
8435−+-- let parm = mfSequence st
8436−+-- return $ "p"++show parm
8437−+
8438−+
8439−+-- | Display a multiline text box and return its content
8440−+getMultilineText :: (FormInput view
8441−+ , Monad m)
8442−+ => T.Text
8443−+ -> View view m T.Text
8444−+getMultilineText nvalue = View $ do
8445−+ tolook <- genNewId
8446−+ env <- gets mfEnv
8447−+ r <- getParam1 tolook env
8448−+ case r of
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
8452−+
8453−+
8454−+--instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where
8455−+-- digest mv = getBool b "True" "False"
8456−+-- where
8457−+-- b= case mv of
8458−+-- Nothing -> Nothing
8459−+-- Just bool -> Just $ case bool of
8460−+-- True -> "True"
8461−+-- False -> "False"
8462−+
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
8472−+
8473−+
8474−+
8475−+-- | Display a dropdown box with the options in the first parameter is optionally selected
8476−+-- . It returns the selected option.
8477−+getSelect :: (FormInput view,
8478−+ Monad m,Typeable a, Read a) =>
8479−+ View view m (MFOption a) -> View view m a
8480−+getSelect opts = View $ do
8481−+ tolook <- genNewId
8482−+ st <- get
8483−+ let env = mfEnv st
8484−+ put st{needForm= HasElems}
8485−+ r <- getParam1 tolook env
8486−+ setSessionData $ fmap MFOption $ valToMaybe r
8487−+ FormElm form mr <- (runView opts)
8488−+
8489−+ return $ FormElm (fselect tolook form) $ valToMaybe r
8490−+
8491−+
8492−+newtype MFOption a= MFOption a deriving Typeable
8493−+
8494−+instance (FormInput view,Monad m, Functor m) => Monoid (View view m (MFOption a)) where
8495−+ mappend = (<|>)
8496−+ mempty = Control.Applicative.empty
8497−+
8498−+-- | Set the option for getSelect. Options are concatenated with `<|>`
8499−+setOption
8500−+ :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
8501−+ a -> view -> View view m (MFOption a)
8502−+setOption n v = do
8503−+ mo <- getSessionData
8504−+ case mo of
8505−+ Nothing -> setOption1 n v False
8506−+ Just Nothing -> setOption1 n v False
8507−+ Just (Just (MFOption o)) -> setOption1 n v $ n == o
8508−+
8509−+-- | Set the selected option for getSelect. Options are concatenated with `<|>`
8510−+setSelectedOption
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
8515−+ case mo of
8516−+ Nothing -> setOption1 n v True
8517−+ Just Nothing -> setOption1 n v True
8518−+ Just (Just o) -> setOption1 n v $ n == o
8519−+
8520−+
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
8525−+ st <- get
8526−+ let env = mfEnv st
8527−+ put st{needForm= HasElems}
8528−+ let n = if typeOf nam == typeOf(undefined :: String)
8529−+ then unsafeCoerce nam
8530−+ else show nam
8531−+
8532−+ return . FormElm (foption n val check) . Just $ MFOption nam
8533−+
8534−+-- | upload a file to a temporary file in the server
8535−+--
8536−+-- The user can move, rename it etc.
8537−+fileUpload :: (FormInput view,
8538−+ Monad m,Functor m) =>
8539−+ View view m (String
8540−+ ,String
8541−+ ,String
8542−+ ) -- ^ ( original file, file type, temporal uploaded)
8543−+fileUpload=
8544−+ getParam Nothing "file" Nothing <** modify ( \st -> st{mfFileUpload = True})
8545−+
8546−+
8547−+
8548−+-- | Enclose Widgets within some formating.
8549−+-- @view@ is intended to be instantiated to a particular format
8550−+--
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.
8554−+--
8555−+-- This is a widget, which is a table with some links. it returns an Int
8556−+--
8557−+-- > import MFlow.Forms.Blaze.Html
8558−+-- >
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")
8563−+-- > ++> (tbody
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))))
8568−+-- > )
8569−+(<<<) :: (Monad m, Monoid view)
8570−+ => (view ->view)
8571−+ -> View view m a
8572−+ -> View view m a
8573−+(<<<) v form= View $ do
8574−+ FormElm f mx <- runView form
8575−+ return $ FormElm (v f) mx
8576−+
8577−+
8578−+infixr 5 <<<
8579−+
8580−+
8581−+
8582−+
8583−+
8584−+
8585−+-- | Append formatting code to a widget
8586−+--
8587−+-- @ getString "hi" '<++' H1 '<<' "hi there"@
8588−+--
8589−+-- It has a infix prority: @infixr 6@ higher than '<<<' and most other operators.
8590−+(<++) :: (Monad m, Monoid v)
8591−+ => View v m a
8592−+ -> v
8593−+ -> View v m a
8594−+(<++) form v= View $ do
8595−+ FormElm f mx <- runView form
8596−+ return $ FormElm ( f <> v) mx
8597−+
8598−+infixr 6 ++>
8599−+infixr 6 <++
8600−+-- | Prepend formatting code to a widget
8601−+--
8602−+-- @bold '<<' "enter name" '++>' 'getString' 'Nothing' @
8603−+--
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
8608−+ View $ do
8609−+ FormElm f mx <- runView w
8610−+ return $ FormElm (html <> f) mx
8611−+
8612−+
8613−+
8614−+-- | Add attributes to the topmost tag of a widget
8615−+--
8616−+-- It has a fixity @infix 8@
8617−+infixl 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
8621−+-- case fs of
8622−+-- [hfs] -> return $ FormElm [hfs `attrs` attribs] mx
8623−+-- _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs
8624−+
8625−+
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
8631−+--
8632−+-- @ userFormLine=
8633−+-- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\")
8634−+-- \<\+\> fromStr \" password again\" \+\> getPassword \<\* submitButton \"register\"
8635−+-- @
8636−+userFormLine :: (FormInput view, Functor m, Monad m)
8637−+ => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr)
8638−+userFormLine=
8639−+ ((,) <$> getString (Just "enter user") <! [("size","5")]
8640−+ <*> getPassword <! [("size","5")]
8641−+ <** submitButton "login")
8642−+ <+> (fromStr " password again" ++> getPassword <! [("size","5")]
8643−+ <** submitButton "register")
8644−+
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)
8648−+userLogin=
8649−+ ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")]
8650−+ <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]
8651−+ <** submitButton "login")
8652−+ <+> (noWidget
8653−+ <* noWidget)
8654−+
8655−+
8656−+
8657−+-- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets.
8658−+--
8659−+-- It returns a non valid value.
8660−+noWidget :: (FormInput view,
8661−+ Monad m, Functor m) =>
8662−+ View view m a
8663−+noWidget= Control.Applicative.empty
8664−
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) =>
8670− View view m a
8671− stop= Control.Applicative.empty
8672−-
8673−--- | Render a Show-able value and return it
8674−-wrender
8675−- :: (Monad m, Functor m, Show a, FormInput view) =>
8676−- a -> View view m a
8677−-wrender x = (fromStr $ show x) ++> return x
8678−-
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 ()
8682−-
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
8686−-
8687−--- | Wether the user is logged or is anonymous
8688−-isLogged :: MonadState (MFlowState v) m => m Bool
8689−-isLogged= do
8690−- rus <- return . tuser =<< gets mfToken
8691−- return . not $ rus == anonymous
8692−-
8693−--- | return the result if going forward
8694−---
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
8699−- back <- goingBack
8700−- if back then noWidget else return x
8701−-
8702−--- | forces backtracking if the widget validates, because a previous page handle this widget response
8703−--- . This is useful for recurrent cached widgets or `absLink`s that are present in multiple pages. For example
8704−--- in the case of menus or common options. The active elements of this widget must be cached with no timeout.
8705−-retry :: Monad m => View v m a -> View v m ()
8706−-retry w = View $ do
8707−- FormElm v mx <- runView w
8708−- when (isJust mx) $ modify $ \st -> st{inSync = False}
8709−- return $ FormElm v Nothing
8710−-
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
8715−--- user logged.
8716−-
8717−-userWidget :: ( MonadIO m, Functor m
8718−- , FormInput view)
8719−- => Maybe String
8720−- -> View view m (Maybe (UserStr,PasswdStr), Maybe String)
8721−- -> View view m String
8722−-userWidget muser formuser = userWidget' muser formuser login1
8723−-
8724−--- | Uses 4 different keys to encrypt the 4 parts of a MFlow cookie.
8725−-
8726−-paranoidUserWidget muser formuser = userWidget' muser formuser paranoidLogin1
8727−-
8728−--- | Uses a single key to encrypt the MFlow cookie.
8729−-
8730−-encryptedUserWidget muser formuser = userWidget' muser formuser encryptedLogin1
8731−-
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
8737−- where
8738−- val _ (Nothing,_) = return . Just $ fromStr "Plese fill in the user/passwd to login, or user/passwd/passwd to register"
8739−-
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"
8744−-
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"
8751−-
8752−--- val _ _ = return . Just $ fromStr "Please fill in the fields for login or register"
8753−-
8754−-login1
8755−- :: (MonadIO m, MonadState (MFlowState view) m) =>
8756−- (Maybe (UserStr, PasswdStr), Maybe t) -> m UserStr
8757−-login1 uname = login1' uname login
8758−-
8759−-paranoidLogin1 uname = login1' uname paranoidLogin
8760−-
8761−-encryptedLogin1 uname = login1' uname encryptedLogin
8762−-
8763−-login1' (Just (uname,_), Nothing) loginFunc= loginFunc uname >> return uname
8764−-login1' (Just us@(u,p), Just _) loginFunc= do -- register button pressed
8765−- userRegister u p
8766−- loginFunc u
8767−- return u
8768−-
8769−--- | change the user
8770−---
8771−--- It is supposed that the user has been validated
8772−-
8773−-login uname = login' uname setCookie
8774−-
8775−-paranoidLogin uname = login' uname setParanoidCookie
8776−-
8777−-encryptedLogin uname = login' uname setEncryptedCookie
8778−-
8779−-login'
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
8784−- back <- goingBack
8785−- if back then return () else do
8786−- st <- get
8787−- let t = mfToken st
8788−- u = tuser t
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)
8796−-
8797−-logout = logout' setCookie
8798−-
8799−-paranoidLogout = logout' setParanoidCookie
8800−-
8801−-encryptedLogout = logout' setEncryptedCookie
8802−-
8803−-
8804−--- | logout. The user is reset to the `anonymous` user
8805−-logout'
8806−- :: (Num a1,S.IsString a, MonadIO m,
8807−- MonadState (MFlowState view) m) =>
8808−- (String -> [Char] -> a -> Maybe a1 -> m ()) -> m ()
8809−+
8810−+-- | Render a Show-able value and return it
8811−+wrender
8812−+ :: (Monad m, Functor m, Show a, FormInput view) =>
8813−+ a -> View view m a
8814−+wrender x = (fromStr $ show x) ++> return x
8815−+
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 ()
8819−+
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
8823−+
8824−+-- | Wether the user is logged or is anonymous
8825−+isLogged :: MonadState (MFlowState v) m => m Bool
8826−+isLogged= do
8827−+ rus <- return . tuser =<< gets mfToken
8828−+ return . not $ rus == anonymous
8829−+
8830−+-- | return the result if going forward
8831−+--
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
8836−+ back <- goingBack
8837−+ if back then noWidget else return x
8838−+
8839−+-- | forces backtracking if the widget validates, because a previous page handle this widget response
8840−+-- . This is useful for recurrent cached widgets or `absLink`s that are present in multiple pages. For example
8841−+-- in the case of menus or common options. The active elements of this widget must be cached with no timeout.
8842−+retry :: Monad m => View v m a -> View v m ()
8843−+retry w = View $ do
8844−+ FormElm v mx <- runView w
8845−+ when (isJust mx) $ modify $ \st -> st{inSync = False}
8846−+ return $ FormElm v Nothing
8847−+
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
8852−+-- user logged.
8853−+
8854−+userWidget :: ( MonadIO m, Functor m
8855−+ , FormInput view)
8856−+ => Maybe String
8857−+ -> View view m (Maybe (UserStr,PasswdStr), Maybe String)
8858−+ -> View view m String
8859−+userWidget muser formuser = userWidget' muser formuser login1
8860−+
8861−+-- | Uses 4 different keys to encrypt the 4 parts of a MFlow cookie.
8862−+
8863−+paranoidUserWidget muser formuser = userWidget' muser formuser paranoidLogin1
8864−+
8865−+-- | Uses a single key to encrypt the MFlow cookie.
8866−+
8867−+encryptedUserWidget muser formuser = userWidget' muser formuser encryptedLogin1
8868−+
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
8874−+ where
8875−+ val _ (Nothing,_) = return . Just $ fromStr "Plese fill in the user/passwd to login, or user/passwd/passwd to register"
8876−+
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"
8881−+
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"
8888−+
8889−+-- val _ _ = return . Just $ fromStr "Please fill in the fields for login or register"
8890−+
8891−+login1
8892−+ :: (MonadIO m, MonadState (MFlowState view) m) =>
8893−+ (Maybe (UserStr, PasswdStr), Maybe t) -> m UserStr
8894−+login1 uname = login1' uname login
8895−+
8896−+paranoidLogin1 uname = login1' uname paranoidLogin
8897−+
8898−+encryptedLogin1 uname = login1' uname encryptedLogin
8899−+
8900−+login1' (Just (uname,_), Nothing) loginFunc= loginFunc uname >> return uname
8901−+login1' (Just us@(u,p), Just _) loginFunc= do -- register button pressed
8902−+ userRegister u p
8903−+ loginFunc u
8904−+ return u
8905−+
8906−+-- | change the user
8907−+--
8908−+-- It is supposed that the user has been validated
8909−+
8910−+login uname = login' uname setCookie
8911−+
8912−+paranoidLogin uname = login' uname setParanoidCookie
8913−+
8914−+encryptedLogin uname = login' uname setEncryptedCookie
8915−+
8916−+login'
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
8921−+ back <- goingBack
8922−+ if back then return () else do
8923−+ st <- get
8924−+ let t = mfToken st
8925−+ u = tuser t
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)
8933−+
8934−+logout = logout' setCookie
8935−+
8936−+paranoidLogout = logout' setParanoidCookie
8937−+
8938−+encryptedLogout = logout' setEncryptedCookie
8939−+
8940−+
8941−+-- | logout. The user is reset to the `anonymous` user
8942−+logout'
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
8947−- public
8948−- back <- goingBack
8949−- if back then return () else do
8950−- st <- get
8951−- let t = mfToken st
8952−- t'= t{tuser= anonymous}
8953−- when (tuser t /= anonymous) $ do
8954−--- moveState (twfname t) t t'
8955−- put st{mfToken= t'}
8956−--- liftIO $ deleteTokenInList t
8957−- liftIO $ addTokenToList t'
8958−- setCookieFunc cookieuser anonymous "/" (Just $ -1000)
8959−-
8960−--- | If not logged, perform login. otherwise return the user
8961−---
8962−--- @getUserSimple= getUser Nothing userFormLine@
8963−-getUserSimple :: ( FormInput view, Typeable view)
8964−- => FlowM view IO String
8965−-getUserSimple= getUser Nothing userFormLine
8966−-
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.
8972−---
8973−--- @getUser mu form= ask $ userWidget mu form@
8974−-getUser :: ( FormInput view, Typeable view)
8975−- => Maybe String
8976−- -> View view IO (Maybe (UserStr,PasswdStr), Maybe String)
8977−- -> FlowM view IO String
8978−-getUser mu form= ask $ userWidget mu form
8979−-
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
8986−-
8987−-
8988−-
8989−--- | for compatibility with the same procedure in 'MFLow.Forms.Test.askt'.
8990−--- This is the non testing version
8991−---
8992−--- > askt v w= ask w
8993−---
8994−--- hide one or the other
8995−-askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a
8996−-askt v w = ask w
8997−-
8998−-
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
9002−---
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
9007−---
9008−--- 'ask' also synchronizes the execution of the flow with the user page navigation by
9009−-
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.
9013−---
9014−--- * Advancing in the flow by matching a single requests with one or more sucessive ask statements
9015−---
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
9020−+ public
9021−+ back <- goingBack
9022−+ if back then return () else do
9023−+ st <- get
9024−+ let t = mfToken st
9025−+ t'= t{tuser= anonymous}
9026−+ when (tuser t /= anonymous) $ do
9027−+-- moveState (twfname t) t t'
9028−+ put st{mfToken= t'}
9029−+-- liftIO $ deleteTokenInList t
9030−+ liftIO $ addTokenToList t'
9031−+ setCookieFunc cookieuser anonymous "/" (Just $ -1000)
9032−+
9033−+-- | If not logged, perform login. otherwise return the user
9034−+--
9035−+-- @getUserSimple= getUser Nothing userFormLine@
9036−+getUserSimple :: ( FormInput view, Typeable view)
9037−+ => FlowM view IO String
9038−+getUserSimple= getUser Nothing userFormLine
9039−+
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.
9045−+--
9046−+-- @getUser mu form= ask $ userWidget mu form@
9047−+getUser :: ( FormInput view, Typeable view)
9048−+ => Maybe String
9049−+ -> View view IO (Maybe (UserStr,PasswdStr), Maybe String)
9050−+ -> FlowM view IO String
9051−+getUser mu form= ask $ userWidget mu form
9052−+
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
9059−+
9060−+
9061−+
9062−+-- | for compatibility with the same procedure in 'MFLow.Forms.Test.askt'.
9063−+-- This is the non testing version
9064−+--
9065−+-- > askt v w= ask w
9066−+--
9067−+-- hide one or the other
9068−+askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a
9069−+askt v w = ask w
9070−+
9071−+
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
9075−+--
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
9080−+--
9081−+-- 'ask' also synchronizes the execution of the flow with the user page navigation by
9082−+
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.
9086−+--
9087−+-- * Advancing in the flow by matching a single requests with one or more sucessive ask statements
9088−+--
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
9093− ask w = do
9094−- resetCachePolicy
9095−+ resetCachePolicy
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
9101−- -- AJAX
9102−- let env= mfEnv st1
9103−- mv1= lookup "ajax" env
9104−- majax1= mfAjax st1
9105−-
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
9110−- ask w
9111−- -- END AJAX
9112−-
9113−+ ,mfHttpHeaders =[],mfAutorefresh= False }
9114−+ if not . null $ mfTrace st1 then fail "" else do
9115−+ -- AJAX
9116−+ let env= mfEnv st1
9117−+ mv1= lookup "ajax" env
9118−+ majax1= mfAjax st1
9119−+
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
9124−+ ask w
9125−+ -- END AJAX
9126−+
9127− _ -> do
9128−
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))
9133− else do
9134−-
9135−- let st= st1{needForm= NoElems, inSync= False, mfRequirements= [], linkMatched= False}
9136−- put st
9137−- FormElm forms mx <- FlowM . lift $ runView w
9138−- setCachePolicy
9139−- st' <- get
9140−- if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w
9141−-
9142−- else
9143−- case mx of
9144−- Just x -> do
9145−- put st'{newAsk= True, mfEnv=[]}
9146−- breturn x -- !> ("BRETURN "++ show (mfPagePath st') )
9147−-
9148−- Nothing ->
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'])
9155−+
9156−+ let st= st1{needForm= NoElems, inSync= False, linkMatched= False
9157−+ ,mfRequirements= []
9158−+ ,mfInstalledScripts= if newAsk st1 then [] else mfInstalledScripts st1}
9159−+ put st
9160−+ FormElm forms mx <- FlowM . lift $ runView w
9161−+ setCachePolicy
9162−+ st' <- get
9163−+ if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w
9164−+
9165−+ else
9166−+ case mx of
9167−+ Just x -> do
9168−+ put st'{newAsk= True, mfEnv=[]}
9169−+ breturn x -- !> ("BRETURN "++ show (mfPagePath st') )
9170−+
9171−+ Nothing ->
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
9180−- ask w
9181−- else do
9182−+ FlowM $ lift nextMessage
9183−+ ask w
9184−+ else do
9185− reqs <- FlowM $ lift installAllRequirements -- !> "REPEAT"
9186−-
9187−- let header= mfHeader st'
9188−- t= mfToken st'
9189−- cont <- case (needForm1 st') of
9190−- True -> do
9191−- frm <- formPrefix st' forms False -- !> ("formPrefix="++ show(mfPagePath st'))
9192−- return . header $ reqs <> frm
9193−- _ -> return . header $ reqs <> forms
9194−-
9195−- let HttpData ctype c s= toHttpData cont
9196−- liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s
9197−-
9198−-
9199−- resetState st st'
9200−+ st' <- get
9201−+ let header= mfHeader st'
9202−+ t= mfToken st'
9203−+ cont <- case (needForm st') of
9204−+ HasElems -> do
9205−+ frm <- formPrefix st' forms False -- !> ("formPrefix="++ show(mfPagePath st'))
9206−+ return . header $ reqs <> frm
9207−+ _ -> return . header $ reqs <> forms
9208−+
9209−+ let HttpData ctype c s= toHttpData cont
9210−+ liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s
9211−+
9212−+ resetState st st'
9213− FlowM $ lift nextMessage -- !> "NEXTMESSAGE"
9214−- ask w
9215−- where
9216−- resetState st st'=
9217−- put st{mfCookies=[]
9218−- -- ,mfHttpHeaders=[]
9219−- ,newAsk= False
9220−- ,mfToken= mfToken st'
9221−- ,mfPageFlow= mfPageFlow st'
9222−- ,mfAjax= mfAjax st'
9223−--- ,mfSeqCache= mfSeqCache st'
9224−- ,mfData= mfData st' }
9225−-
9226−-
9227−--- | A synonym of ask.
9228−---
9229−--- Maybe more appropiate for pages with long interactions with the user
9230−--- while the result has little importance.
9231−-page
9232−- :: (FormInput view) =>
9233−- View view IO a -> FlowM view IO a
9234−-page= ask
9235−-
9236−-nextMessage :: MonadIO m => WState view m ()
9237−-nextMessage = do
9238−- st <- get
9239−- let t= mfToken st
9240−- t1= mfkillTime st
9241−- t2= mfSessionTime st
9242−- msg <- liftIO ( receiveReqTimeout t1 t2 t)
9243−- let req= getParams msg
9244−- env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow)
9245−- npath= pwfPath msg
9246−- path= mfPath st
9247−- inPageFlow= mfPagePath st `isPrefixOf` npath
9248−-
9249−- put st{ mfPath= npath
9250−-
9251−-
9252−- , mfPageFlow= inPageFlow
9253−-
9254−- , mfEnv= env }
9255−-
9256−-
9257−- where
9258−-
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
9262−- | otherwise= n
9263−-
9264−- updateParams :: Bool -> Params -> Params -> Params
9265−- updateParams False _ req= req
9266−- updateParams True env req=
9267−- let params= takeWhile isparam env
9268−- fs= fst $ head req
9269−- parms= (case findIndex (\p -> fst p == fs) params of
9270−- Nothing -> params
9271−- Just i -> Data.List.take i params)
9272−- ++ req
9273−- in parms
9274−--- !> "IN PAGE FLOW" !> ("parms=" ++ show parms )
9275−--- !> ("env=" ++ show env)
9276−--- !> ("req=" ++ show req)
9277−-
9278−-
9279−-
9280−-isparam ('p': r:_,_)= isNumber r
9281−-isparam ('c': r:_,_)= isNumber r
9282−-isparam _= False
9283−-
9284−--- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a
9285−--- higuer level form of the latter
9286−-wstateless
9287−- :: (Typeable view, FormInput view) =>
9288−- View view IO () -> Flow
9289−-wstateless w = runFlow . transientNav . ask $ w **> (stop `asTypeOf` w)
9290−-
9291−-
9292−-
9293−-
9294−-
9295−-
9296−--- | Wrap a widget with form element within a form-action element.
9297−--- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad, unless
9298−--- there are more than one form in the page.
9299−-wform :: (Monad m, FormInput view)
9300−- => View view m b -> View view m b
9301−-wform x = View $ do
9302−- FormElm form mr <- (runView $ x )
9303−- st <- get
9304−- form1 <- formPrefix st form True
9305−- put st{needForm=HasForm}
9306−- return $ FormElm form1 mr
9307−-
9308−-
9309−-
9310−-
9311−-resetButton :: (FormInput view, Monad m) => String -> View view m ()
9312−+ ask w
9313−+ where
9314−+ resetState st st'=
9315−+ put st{mfCookies=[]
9316−+ ,mfInstalledScripts= mfInstalledScripts st'
9317−+ ,newAsk= False
9318−+ ,mfToken= mfToken st'
9319−+ ,mfPageFlow= mfPageFlow st'
9320−+ ,mfAjax= mfAjax st'
9321−+ ,mfData= mfData st' }
9322−+
9323−+
9324−+-- | A synonym of ask.
9325−+--
9326−+-- Maybe more appropiate for pages with long interactions with the user
9327−+-- while the result has little importance.
9328−+page
9329−+ :: (FormInput view) =>
9330−+ View view IO a -> FlowM view IO a
9331−+page= ask
9332−+
9333−+nextMessage :: MonadIO m => WState view m ()
9334−+nextMessage = do
9335−+ st <- get
9336−+ let t= mfToken st
9337−+ t1= mfkillTime st
9338−+ t2= mfSessionTime st
9339−+ msg <- liftIO ( receiveReqTimeout t1 t2 t)
9340−+ let req= getParams msg
9341−+ env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow)
9342−+ npath= pwfPath msg
9343−+ path= mfPath st
9344−+ inPageFlow= mfPagePath st `isPrefixOf` npath
9345−+
9346−+ put st{ mfPath= npath
9347−+ , mfPageFlow= inPageFlow
9348−+ , mfEnv= env }
9349−+
9350−+ where
9351−+
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
9355−+-- | otherwise= n
9356−+
9357−+ updateParams :: Bool -> Params -> Params -> Params
9358−+ updateParams False _ req= req
9359−+ updateParams True env req=
9360−+ let params= takeWhile isparam req -- env
9361−+ fs= fst $ head req
9362−+ parms= (case findIndex (\p -> fst p == fs) params of
9363−+ Nothing -> params
9364−+ Just i -> Data.List.take i params)
9365−+ ++ req
9366−+ in parms
9367−+-- !> "IN PAGE FLOW" !> ("parms=" ++ show parms )
9368−+-- !> ("env=" ++ show env)
9369−+-- !> ("req=" ++ show req)
9370−+
9371−+
9372−+
9373−+isparam ('p': r:_,_)= isNumber r
9374−+isparam ('c': r:_,_)= isNumber r
9375−+isparam _= False
9376−+
9377−+-- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a
9378−+-- higuer level form of the latter
9379−+wstateless
9380−+ :: (Typeable view, FormInput view) =>
9381−+ View view IO () -> Flow
9382−+wstateless w = runFlow . transientNav . ask $ w **> (stop `asTypeOf` w)
9383−+
9384−+
9385−+
9386−+
9387−+
9388−+
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
9394−+wform= insertForm
9395−+--wform x = View $ do
9396−+-- FormElm form mr <- (runView $ x )
9397−+-- st <- get
9398−+-- form1 <- formPrefix st form True
9399−+-- put st{needForm=HasForm}
9400−+-- return $ FormElm form1 mr
9401−+
9402−+
9403−+
9404−+
9405−+resetButton :: (FormInput view, Monad m) => String -> View view m ()
9406− resetButton label= View $ return $ FormElm (finput "reset" "reset" label False Nothing)
9407−- $ Just ()
9408−-
9409−-submitButton :: (FormInput view, Monad m) => String -> View view m String
9410−-submitButton label= getParam Nothing "submit" $ Just label
9411−-
9412−-newtype AjaxSessionId= AjaxSessionId String deriving Typeable
9413−-
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.
9416−---
9417−--- This example increases the value of a text box each time the box is clicked
9418−---
9419−--- > ask $ do
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
9427−-ajax f = do
9428−- requires[JScript ajaxScript]
9429−- t <- gets mfToken
9430−- id <- genNewId
9431−- installServerControl id $ \x-> do
9432−- setSessionData $ AjaxSessionId id
9433−- r <- f x
9434−- liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r )
9435−- return ()
9436−-
9437−-installServerControl :: (FormInput v,MonadIO m) => String -> (String -> View v m ()) -> View v m (String -> String)
9438−-installServerControl id f= do
9439−- t <- gets mfToken
9440−- st <- get
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++")"
9445−-
9446−--- | Send the javascript expression, generated by the procedure parameter as a ByteString, execute it in the browser and the result is returned back
9447−---
9448−--- The @ajaxSend@ invocation must be inside a ajax procedure or else a /No ajax session set/ error will be produced
9449−-ajaxSend
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"
9453−- env <- getEnv
9454−- t <- getToken
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 "''"
9460−- nextMessage
9461−- env <- getEnv
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
9466−- where
9467−- readEvalLoop t id v = "doServer('"<> fromString (twfname t)<>"','"<> fromString id<>"',"<>v<>");" :: ByteString
9468−-
9469−--- | Like @ajaxSend@ but the result is ignored
9470−-ajaxSend_
9471−- :: (MonadIO m, Monoid v) => View v m ByteString -> View v m ()
9472−-ajaxSend_ = ajaxSend
9473−-
9474−-wlabel
9475−- :: (Monad m, FormInput view) => view -> View view m a -> View view m a
9476−-wlabel str w = do
9477−- id <- genNewId
9478−- ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)]
9479−-
9480−-
9481−+ $ Just ()
9482−+
9483−+submitButton :: (FormInput view, Monad m) => String -> View view m String
9484−+submitButton label= getParam Nothing "submit" $ Just label
9485−+
9486−+newtype AjaxSessionId= AjaxSessionId String deriving Typeable
9487−+
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.
9490−+--
9491−+-- This example increases the value of a text box each time the box is clicked
9492−+--
9493−+-- > ask $ do
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
9501−+ajax f = do
9502−+ requires[JScript ajaxScript]
9503−+ t <- gets mfToken
9504−+ id <- genNewId
9505−+ installServerControl id $ \x-> do
9506−+ setSessionData $ AjaxSessionId id
9507−+ r <- f x
9508−+ liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r )
9509−+ return ()
9510−+
9511−+installServerControl :: (FormInput v,MonadIO m) => String -> (String -> View v m ()) -> View v m (String -> String)
9512−+installServerControl id f= do
9513−+ t <- gets mfToken
9514−+ st <- get
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++")"
9519−+
9520−+-- | Send the javascript expression, generated by the procedure parameter as a ByteString, execute it in the browser and the result is returned back
9521−+--
9522−+-- The @ajaxSend@ invocation must be inside a ajax procedure or else a /No ajax session set/ error will be produced
9523−+ajaxSend
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"
9527−+ env <- getEnv
9528−+ t <- getToken
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 "''"
9534−+ nextMessage
9535−+ env <- getEnv
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
9540−+ where
9541−+ readEvalLoop t id v = "doServer('"<> fromString (twfname t)<>"','"<> fromString id<>"',"<>v<>");" :: ByteString
9542−+
9543−+-- | Like @ajaxSend@ but the result is ignored
9544−+ajaxSend_
9545−+ :: (MonadIO m, Monoid v) => View v m ByteString -> View v m ()
9546−+ajaxSend_ = ajaxSend
9547−+
9548−+wlabel
9549−+ :: (Monad m, FormInput view) => view -> View view m a -> View view m a
9550−+wlabel str w = do
9551−+ id <- genNewId
9552−+ ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)]
9553−+
9554−+
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
9562−- verb <- getWFName
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
9567−+ verb <- getWFName
9568− st <- get
9569−-
9570−- let name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String)
9571−- then unsafeCoerce x
9572−- else show x)
9573−+
9574−+ let name = --mfPrefix st ++
9575−+ (map toLower $ if typeOf x== typeOf(undefined :: String)
9576−+ then unsafeCoerce x
9577−+ else show x)
9578− lpath = mfPath st
9579−- newPath= mfPagePath st ++ [name]
9580−-
9581−- r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
9582−- else
9583−- case newPath `isPrefixOf` lpath of
9584−- True -> do
9585−- modify $ \s -> s{inSync= True
9586−+ newPath= mfPagePath st ++ [name]
9587−+
9588−+ r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
9589−+ else
9590−+ case newPath `isPrefixOf` lpath of
9591−+ True -> do
9592−+ modify $ \s -> s{inSync= True
9593− ,linkMatched= True
9594−- ,mfPagePath= newPath }
9595−-
9596−+ ,mfPagePath= newPath }
9597−+
9598− return $ Just x
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)
9605−
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
9610−
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
9618−- verb <- getWFName
9619−+absLink x v= View $ do
9620−+ verb <- getWFName
9621− st <- get
9622−-
9623−- let name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String)
9624−- then unsafeCoerce x
9625−- else show x)
9626−+
9627−+ let name = -- mfPrefix st
9628−+ (map toLower $ if typeOf x== typeOf(undefined :: String)
9629−+ then unsafeCoerce x
9630−+ else show x)
9631−
9632− lpath = mfPath st
9633−- newPath= mfPagePath st ++ [name]
9634−- r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
9635−- else
9636−- case newPath `isPrefixOf` lpath of
9637−- True -> do
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
9641−+ else
9642−+ case newPath `isPrefixOf` lpath of
9643−+ True -> do
9644−+ modify $ \s -> s{inSync= True
9645− ,linkMatched= True
9646−- ,mfPagePath= newPath }
9647−-
9648−- return $ Just x -- !> (name ++ "<- abs" ++ "lpath=" ++show lpath)
9649−- False -> return Nothing -- !> ( "NOT MATCHED "++name++" LP= "++show lpath)
9650−-
9651−- path <- liftIO $ cachedByKey (show x) 0 . return $ currentPath st ++ ('/':name)
9652−-
9653−- return $ FormElm (flink path v) r -- !> name
9654−-
9655−-
9656−-
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
9659−--- widget.
9660−---
9661−--- At runtime the parameter is read from the environment and validated.
9662−---
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
9669−- verb <- getWFName
9670−- name <- genNewId
9671−- env <- gets mfEnv
9672−- let string x=
9673−- let showx= case cast x of
9674−- Just x' -> x'
9675−- _ -> show x
9676−- in (verb ++ "?" ++ name ++ "=" ++ showx)
9677−- toSend= expr string
9678−- r <- getParam1 name env
9679−- return $ FormElm toSend $ valToMaybe r
9680−-
9681−-
9682−-
9683−-
9684−-
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
9692−-
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 }
9696−+
9697−+ return $ Just x -- !> (name ++ "<- abs" ++ "lpath=" ++show lpath)
9698−+ False -> return Nothing -- !> ( "NOT MATCHED "++name++" LP= "++show lpath)
9699−+
9700−+ path <- liftIO $ cachedByKey (show x) 0 . return $ currentPath st ++ ('/':name)
9701−+
9702−+ return $ FormElm (flink path v) r -- !> name
9703−+
9704−+
9705−+
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
9708−+-- widget.
9709−+--
9710−+-- At runtime the parameter is read from the environment and validated.
9711−+--
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
9718−+ verb <- getWFName
9719−+ name <- genNewId
9720−+ env <- gets mfEnv
9721−+ let string x=
9722−+ let showx= case cast x of
9723−+ Just x' -> x'
9724−+ _ -> show x
9725−+ in (verb ++ "?" ++ name ++ "=" ++ showx)
9726−+ toSend= expr string
9727−+ r <- getParam1 name env
9728−+ return $ FormElm toSend $ valToMaybe r
9729−+
9730−+
9731−+
9732−+
9733−+
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
9741−+
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
9745−--- View $ do
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
9751−-
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)
9759−+-- View $ do
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
9765−+
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)
9773−
9774− -- | like manyOf, but does not validate if one or more of the widgets does not validate
9775− allOf xs= manyOf xs `validate` \rs ->
9776− if length rs== length xs
9777− then return Nothing
9778− else return $ Just mempty
9779−-
9780−-(>:>) :: (Monad m, Monoid v) => View v m a -> View v m [a] -> View v m [a]
9781−-(>:>) w ws = View $ do
9782−- FormElm fs mxs <- runView $ ws
9783−- FormElm f1 mx <- runView w
9784−- return $ FormElm (f1 <> fs)
9785−- $ case( mx,mxs) of
9786−- (Just x, Just xs) -> Just $ x:xs
9787−- (Nothing, mxs) -> mxs
9788−- (Just x, _) -> Just [x]
9789−-
9790−--- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types.
9791−---
9792−--- it has a infix priority @infixr 5@
9793−-(|*>) :: (MonadIO m, Functor m, FormInput view)
9794−- => View view m r
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
9800−+
9801−+(>:>) :: (Monad m, Monoid v) => View v m a -> View v m [a] -> View v m [a]
9802−+(>:>) w ws = View $ do
9803−+ FormElm fs mxs <- runView $ ws
9804−+ FormElm f1 mx <- runView w
9805−+ return $ FormElm (f1 <> fs)
9806−+ $ case( mx,mxs) of
9807−+ (Just x, Just xs) -> Just $ x:xs
9808−+ (Nothing, mxs) -> mxs
9809−+ (Just x, _) -> Just [x]
9810−+
9811−+-- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types.
9812−+--
9813−+-- it has a infix priority @infixr 5@
9814−+(|*>) :: (MonadIO m, Functor m, FormInput view)
9815−+ => View view m r
9816−+ -> [View view m r']
9817−+ -> View view m (Maybe r,Maybe r')
9818−+(|*>) x xs= View $ do
9819−+ fs <- mapM runView xs
9820−+ FormElm fx rx <- runView x
9821− let (fxs, rxss) = unzip $ map (\(FormElm v r) -> (v,r)) fs
9822− rs= filter isJust rxss
9823−- rxs= if null rs then Nothing else head rs
9824−- return $ FormElm (fx <> mconcat (intersperse fx fxs) <> fx)
9825−- $ case (rx,rxs) of
9826−- (Nothing, Nothing) -> Nothing
9827−- other -> Just other
9828−-
9829−-
9830−-
9831−-infixr 5 |*>
9832−-
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.
9835−-
9836−--- It has a low infix priority: @infixr 1@
9837−-(|+|) :: (Functor m, FormInput view, MonadIO m)
9838−- => View view m r
9839−- -> View view m r'
9840−- -> View view m (Maybe r, Maybe r')
9841−-(|+|) w w'= w |*> [w']
9842−-
9843−-infixr 1 |+|
9844−-
9845−-
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:
9849−---
9850−--- @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@
9851−---
9852−--- @res@ has type:
9853−---
9854−--- @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@
9855−---
9856−--- but @flatten res@ has type:
9857−---
9858−--- @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@
9859−-
9860−-flatten :: Flatten (Maybe tree) list => tree -> list
9861−-flatten res= doflat $ Just res
9862−-
9863−-class Flatten tree list where
9864−- doflat :: tree -> list
9865−-
9866−-
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)
9872−-
9873−-instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where
9874−- doflat (Just(ma,mb))= (ma,mb)
9875−- doflat Nothing= (Nothing,Nothing)
9876−-
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)
9880−-
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)
9884−-
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)
9888−-
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)
9892−-
9893−---infixr 7 .<<.
9894−----- | > (.<<.) w x = w $ toByteString x
9895−---(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString
9896−---(.<<.) w x = w ( toByteString x)
9897−---
9898−----- | > (.<+>.) x y = normalize x <+> normalize y
9899−---(.<+>.)
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
9903−---
9904−----- | > (.|*>.) x y = normalize x |*> map normalize y
9905−---(.|*>.)
9906−--- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
9907−--- View v m r
9908−--- -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')
9909−---(.|*>.) x y = normalize x |*> map normalize y
9910−---
9911−----- | > (.|+|.) x y = normalize x |+| normalize y
9912−---(.|+|.)
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
9916−---
9917−----- | > (.**>.) x y = normalize x **> normalize y
9918−---(.**>.)
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
9922−---
9923−----- | > (.<**.) x y = normalize x <** normalize y
9924−---(.<**.)
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
9928−---
9929−----- | > (.<|>.) x y= normalize x <|> normalize y
9930−---(.<|>.)
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
9934−---
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
9938−---
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
9942−-
9943−-
9944−-instance FormInput ByteString where
9945−- toByteString= id
9946−- toHttpData = HttpData [contentHtml ] []
9947−- ftag x= btag x []
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]
9952−-
9953−- fselect name options= btag "select" [("name", name)] options
9954−-
9955−- foption value content msel= btag "option" ([("value", value)] ++ selected msel) content
9956−- where
9957−- selected msel = if msel then [("selected","true")] else []
9958−-
9959−- attrs = addAttrs
9960−-
9961−-
9962−- formAction action form = btag "form" [("action", action),("method", "post")] form
9963−- fromStr = fromString
9964−- fromStrNoEncode= fromString
9965−-
9966−- flink v str = btag "a" [("href", v)] str
9967−-
9968−------- page Flows ----
9969−-
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>
9974−-pageFlow
9975−- :: (Monad m, Functor m, FormInput view) =>
9976−- String -> View view m a -> View view m a
9977−-pageFlow str widget=do
9978−- s <- get
9979−-
9980−- if mfPageFlow s == False
9981−- then do
9982−- put s{mfPrefix= str ++ mfPrefix s
9983−- ,mfSequence=0
9984−+ rxs= if null rs then Nothing else head rs
9985−+ return $ FormElm (fx <> mconcat (intersperse fx fxs) <> fx)
9986−+ $ case (rx,rxs) of
9987−+ (Nothing, Nothing) -> Nothing
9988−+ other -> Just other
9989−+
9990−+
9991−+
9992−+infixr 5 |*>
9993−+
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.
9996−+
9997−+-- It has a low infix priority: @infixr 1@
9998−+(|+|) :: (Functor m, FormInput view, MonadIO m)
9999−+ => View view m r
10000−+ -> View view m r'
10001−+ -> View view m (Maybe r, Maybe r')
10002−+(|+|) w w'= w |*> [w']
10003−+
10004−+infixr 1 |+|
10005−+
10006−+
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:
10010−+--
10011−+-- @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@
10012−+--
10013−+-- @res@ has type:
10014−+--
10015−+-- @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@
10016−+--
10017−+-- but @flatten res@ has type:
10018−+--
10019−+-- @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@
10020−+
10021−+flatten :: Flatten (Maybe tree) list => tree -> list
10022−+flatten res= doflat $ Just res
10023−+
10024−+class Flatten tree list where
10025−+ doflat :: tree -> list
10026−+
10027−+
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)
10033−+
10034−+instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where
10035−+ doflat (Just(ma,mb))= (ma,mb)
10036−+ doflat Nothing= (Nothing,Nothing)
10037−+
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)
10041−+
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)
10045−+
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)
10049−+
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)
10053−+
10054−+--infixr 7 .<<.
10055−+---- | > (.<<.) w x = w $ toByteString x
10056−+--(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString
10057−+--(.<<.) w x = w ( toByteString x)
10058−+--
10059−+---- | > (.<+>.) x y = normalize x <+> normalize y
10060−+--(.<+>.)
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
10064−+--
10065−+---- | > (.|*>.) x y = normalize x |*> map normalize y
10066−+--(.|*>.)
10067−+-- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
10068−+-- View v m r
10069−+-- -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')
10070−+--(.|*>.) x y = normalize x |*> map normalize y
10071−+--
10072−+---- | > (.|+|.) x y = normalize x |+| normalize y
10073−+--(.|+|.)
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
10077−+--
10078−+---- | > (.**>.) x y = normalize x **> normalize y
10079−+--(.**>.)
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
10083−+--
10084−+---- | > (.<**.) x y = normalize x <** normalize y
10085−+--(.<**.)
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
10089−+--
10090−+---- | > (.<|>.) x y= normalize x <|> normalize y
10091−+--(.<|>.)
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
10095−+--
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
10099−+--
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
10103−+
10104−+
10105−+instance FormInput ByteString where
10106−+ toByteString= id
10107−+ toHttpData = HttpData [contentHtml ] []
10108−+ ftag x= btag x []
10109−+ inred = btag "b" [("style", "color:red")]
10110−+ finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else []
10111−+ ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) ""
10112−+ ftextarea name text= btag "textarea" [("name", name)] $ fromChunks [encodeUtf8 text]
10113−+
10114−+ fselect name options= btag "select" [("name", name)] options
10115−+
10116−+ foption value content msel= btag "option" ([("value", value)] ++ selected msel) content
10117−+ where
10118−+ selected msel = if msel then [("selected","true")] else []
10119−+
10120−+ attrs = addAttrs
10121−+
10122−+
10123−+ formAction action method form = btag "form" [("action", action),("method", method)] form
10124−+ fromStr = fromString
10125−+ fromStrNoEncode= fromString
10126−+
10127−+ flink v str = btag "a" [("href", v)] str
10128−+
10129−+------ page Flows ----
10130−+
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>
10135−+pageFlow
10136−+ :: (Monad m, Functor m, FormInput view) =>
10137−+ String -> View view m a -> View view m a
10138−+pageFlow str widget=do
10139−+ s <- get
10140−+
10141−+ if mfPageFlow s == False
10142−+ then do
10143−+ put s{mfPrefix= str ++ mfPrefix s
10144−+ ,mfSequence=0
10145− ,mfPageFlow= True
10146−- } -- !> ("PARENT pageflow. prefix="++ str)
10147−-
10148−- r<- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
10149−+ } -- !> ("PARENT pageflow. prefix="++ str)
10150−+
10151−+ r<- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
10152− ,mfPrefix= mfPrefix s
10153−- }))
10154−+ }))
10155− modify (\s -> s{mfPageFlow=False} )
10156−- return r -- !> ("END PARENT pageflow. prefix="++ str))
10157−-
10158−-
10159−- else do
10160−- put s{mfPrefix= str++ mfPrefix s,mfSequence=0} -- !> ("PARENT pageflow. prefix="++ str) -- !> ("CHILD pageflow. prefix="++ str)
10161−-
10162−- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
10163−- ,mfPrefix= mfPrefix s}))
10164−- -- !> ("END CHILD pageflow. prefix="++ str))
10165−-
10166−-
10167−-
10168−---acum map []= map
10169−---acum map (x:xs) =
10170−--- let map' = case M.lookup x map of
10171−--- Nothing -> M.insert x 1 map
10172−--- Just n -> M.insert x (n+1) map
10173−--- in acum map' xs
10174−-
10175−+ return r -- !> ("END PARENT pageflow. prefix="++ str))
10176−+
10177−+
10178−+ else do
10179−+ put s{mfPrefix= str++ mfPrefix s,mfSequence=0} -- !> ("PARENT pageflow. prefix="++ str) -- !> ("CHILD pageflow. prefix="++ str)
10180−+
10181−+ widget <** (modify (\s' -> s'{mfSequence= mfSequence s
10182−+ ,mfPrefix= mfPrefix s}))
10183−+ -- !> ("END CHILD pageflow. prefix="++ str))
10184−+
10185−+
10186−+
10187−+--acum map []= map
10188−+--acum map (x:xs) =
10189−+-- let map' = case M.lookup x map of
10190−+-- Nothing -> M.insert x 1 map
10191−+-- Just n -> M.insert x (n+1) map
10192−+-- in acum map' xs
10193−+
10194−diff -ru orig/src/MFlow/Hack/Response.hs new/src/MFlow/Hack/Response.hs
10195−--- orig/src/MFlow/Hack/Response.hs 2014-06-10 05:51:26.969015857 +0300
10196−+++ new/src/MFlow/Hack/Response.hs 2014-06-10 05:51:25.000000000 +0300
10197−@@ -1,13 +1,13 @@
10198− {-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances
10199−- -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
10200−-module MFlow.Hack.Response where
10201−-
10202−+ -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
10203−+module MFlow.Hack.Response where
10204−+
10205− import Hack
10206−-import MFlow.Cookies
10207−+import MFlow.Cookies
10208− import Data.ByteString.Lazy.Char8 as B
10209−
10210−-import MFlow
10211−-import Data.Typeable
10212−+import MFlow
10213−+import Data.Typeable
10214− import Data.Monoid
10215− import System.IO.Unsafe
10216− import Data.Map as M
10217−@@ -18,9 +18,9 @@
10218− --(!>)= flip trace
10219−
10220−
10221−-
10222−-class ToResponse a where
10223−- toResponse :: a -> Response
10224−+
10225−+class ToResponse a where
10226−+ toResponse :: a -> Response
10227−
10228−
10229−
10230−@@ -31,28 +31,28 @@
10231− mappend (TResp x) (TResp y)=
10232− case cast y of
10233− Just y' -> TResp $ mappend x y'
10234−- Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
10235−-
10236−+ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
10237−+
10238−
10239− instance ToResponse TResp where
10240−- toResponse (TResp x)= toResponse x
10241−+ toResponse (TResp x)= toResponse x
10242− toResponse (TRespR r)= toResponse r
10243−-
10244−-instance ToResponse Response where
10245−- toResponse = id
10246−-
10247−-instance ToResponse ByteString where
10248−- toResponse x= Response{status=200, headers=[contentHtml {-,("Content-Length",show $ B.length x) -}], body= x}
10249−-
10250−-instance ToResponse String where
10251−+
10252−+instance ToResponse Response where
10253−+ toResponse = id
10254−+
10255−+instance ToResponse ByteString where
10256−+ toResponse x= Response{status=200, headers=[contentHtml {-,("Content-Length",show $ B.length x) -}], body= x}
10257−+
10258−+instance ToResponse String where
10259− toResponse x= Response{status=200, headers=[contentHtml{-,("Content-Length",show $ B.length x) -}], body= B.pack x}
10260−
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}
10264−-
10265−-instance Typeable Env where
10266−- typeOf = \_-> mkTyConApp (mkTyCon3 "hack-handler-simpleserver" "Hack" "Env") []
10267−-
10268−---instance Typeable Response where
10269−--- typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[]
10270−+ toResponse (Error NotFound str)= Response{status=404, headers=[], body= getNotFoundResponse str}
10271−+
10272−+instance Typeable Env where
10273−+ typeOf = \_-> mkTyConApp (mkTyCon3 "hack-handler-simpleserver" "Hack" "Env") []
10274−+
10275−+--instance Typeable Response where
10276−+-- typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[]
10277−diff -ru orig/src/MFlow/Hack/XHtml.hs new/src/MFlow/Hack/XHtml.hs
10278−--- orig/src/MFlow/Hack/XHtml.hs 2014-06-10 05:51:26.969015857 +0300
10279−+++ new/src/MFlow/Hack/XHtml.hs 2014-06-10 05:51:25.000000000 +0300
10280−@@ -27,14 +27,14 @@
10281− import Text.XHtml
10282− import Data.Typeable
10283− import Data.ByteString.Lazy.Char8 as B(pack,unpack, length, ByteString)
10284−-
10285−-instance ToResponse Html where
10286−+
10287−+instance ToResponse Html where
10288− toResponse x= Response{ status=200, headers=[]
10289−- , Hack.body= pack $ showHtml x}
10290−+ , Hack.body= pack $ showHtml x}
10291− --
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") []
10296− --
10297−---instance ConvertTo Html TResp where
10298−+--instance ConvertTo Html TResp where
10299− -- convert = TResp
10300−
10301−diff -ru orig/src/MFlow/Hack.hs new/src/MFlow/Hack.hs
10302−--- orig/src/MFlow/Hack.hs 2014-06-10 05:51:26.957015857 +0300
10303−+++ new/src/MFlow/Hack.hs 2014-06-10 05:51:25.000000000 +0300
10304−@@ -8,33 +8,33 @@
10305−
10306− see <http://hackage.haskell.org/package/hack>
10307− -}
10308−-
10309−+
10310− module MFlow.Hack(
10311− module MFlow.Cookies
10312− ,module MFlow
10313− ,hackMessageFlow)
10314− where
10315−-
10316−-import Data.Typeable
10317−-import Hack
10318−-
10319−-import Control.Concurrent.MVar(modifyMVar_, readMVar)
10320−-import Control.Monad(when)
10321−-
10322−-
10323−-import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString)
10324−-import Control.Concurrent(ThreadId(..))
10325−-import System.IO.Unsafe
10326−+
10327−+import Data.Typeable
10328−+import Hack
10329−+
10330−+import Control.Concurrent.MVar(modifyMVar_, readMVar)
10331−+import Control.Monad(when)
10332−+
10333−+
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
10343−-import Data.Maybe
10344−+import Data.Maybe
10345− import Data.TCache
10346−-import Data.TCache.DefaultPersistence
10347−-import Control.Workflow hiding (Indexable(..))
10348−-
10349−-import MFlow
10350−+import Data.TCache.DefaultPersistence
10351−+import Control.Workflow hiding (Indexable(..))
10352−+
10353−+import MFlow
10354− import MFlow.Cookies
10355−
10356− import MFlow.Hack.Response
10357−@@ -46,13 +46,13 @@
10358−
10359−
10360− flow= "flow"
10361−-
10362−-instance Processable Env where
10363−- pwfname env= if null sc then noScript else sc
10364−- where
10365−+
10366−+instance Processable Env where
10367−+ pwfname env= if null sc then noScript else sc
10368−+ where
10369− sc= tail $ pathInfo env
10370−- puser env = fromMaybe anonymous $ lookup cookieuser $ http env
10371−-
10372−+ puser env = fromMaybe anonymous $ lookup cookieuser $ http env
10373−+
10374− pind env= fromMaybe (error ": No FlowID") $ lookup flow $ http env
10375− getParams= http
10376− -- getServer env= serverName env
10377−@@ -60,38 +60,38 @@
10378− -- getPort env= serverPort env
10379−
10380−
10381−-
10382−----------------------------------------------
10383−-
10384−-
10385−-
10386−---
10387−---instance ConvertTo String TResp where
10388−--- convert = TResp . pack
10389−+
10390−+---------------------------------------------
10391−+
10392−+
10393−+
10394− --
10395−---instance ConvertTo ByteString TResp where
10396−+--instance ConvertTo String TResp where
10397−+-- convert = TResp . pack
10398−+--
10399−+--instance ConvertTo ByteString TResp where
10400− -- convert = TResp
10401− --
10402−---
10403−---instance ConvertTo Error TResp where
10404−+--
10405−+--instance ConvertTo Error TResp where
10406− -- convert (Error e)= TResp . pack $ errorResponse e
10407− --
10408− --instance ToResponse v =>ConvertTo (HttpData v) TResp where
10409−--- convert= TRespR
10410−+-- convert= TRespR
10411−+
10412−+
10413−+--webScheduler :: Env
10414−+-- -> ProcList
10415−+-- -> IO (TResp, ThreadId)
10416−+--webScheduler = msgScheduler
10417−+
10418−+--theDir= unsafePerformIO getCurrentDirectory
10419−+
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"
10422−
10423−-
10424−---webScheduler :: Env
10425−--- -> ProcList
10426−--- -> IO (TResp, ThreadId)
10427−---webScheduler = msgScheduler
10428−-
10429−---theDir= unsafePerformIO getCurrentDirectory
10430−-
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"
10433−-
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
10437− --
10438− -- Example:
10439− --
10440−@@ -107,112 +107,112 @@
10441− -- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs]
10442− -- @
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
10452− -- where
10453− -- f env = unsafePerformIO $ do
10454− -- paths <- getMessageFlows >>=
10455− -- return (pwfname env `elem` paths)
10456−
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
10461−-
10462−-
10463−-splitPath ""= ("","","")
10464−-splitPath str=
10465−- let
10466−- strr= reverse str
10467−- (ext, rest)= span (/= '.') strr
10468−- (mod, path)= span(/='/') $ tail rest
10469−- in (tail $ reverse path, reverse mod, reverse ext)
10470−-
10471−-
10472−-
10473−-hackMessageFlow :: Env -> IO Response
10474−-hackMessageFlow req1= do
10475−- let httpreq1= http req1
10476−- let cookies= {-# SCC "getCookies" #-} getCookies httpreq1
10477−-
10478−- (flowval , retcookies) <- case lookup ( flow) cookies of
10479−- Just fl -> return (fl, [])
10480−- Nothing -> do
10481−- fl <- newFlow
10482−+
10483−+
10484−+splitPath ""= ("","","")
10485−+splitPath str=
10486−+ let
10487−+ strr= reverse str
10488−+ (ext, rest)= span (/= '.') strr
10489−+ (mod, path)= span(/='/') $ tail rest
10490−+ in (tail $ reverse path, reverse mod, reverse ext)
10491−+
10492−+
10493−+
10494−+hackMessageFlow :: Env -> IO Response
10495−+hackMessageFlow req1= do
10496−+ let httpreq1= http req1
10497−+ let cookies= {-# SCC "getCookies" #-} getCookies httpreq1
10498−+
10499−+ (flowval , retcookies) <- case lookup ( flow) cookies of
10500−+ Just fl -> return (fl, [])
10501−+ Nothing -> do
10502−+ fl <- newFlow
10503− return ( fl, [( flow, fl, "/",(Just $ show $ 365*24*60*60))])
10504−-
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
10510−--}
10511−-
10512−- let input=
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
10516−- _ -> []
10517−-
10518−- let req = case retcookies of
10519−- [] -> req1{http= (input ++ cookies) ++ http req1} -- !> "REQ"
10520−- _ -> req1{http=(flow, flowval): ( input ++ cookies ) ++ http req1} -- !> "REQ"
10521−-
10522−-
10523−+
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
10529−+-}
10530−+
10531−+ let input=
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
10535−+ _ -> []
10536−+
10537−+ let req = case retcookies of
10538−+ [] -> req1{http= (input ++ cookies) ++ http req1} -- !> "REQ"
10539−+ _ -> req1{http=(flow, flowval): ( input ++ cookies ) ++ http req1} -- !> "REQ"
10540−+
10541−+
10542− (resp',th) <- msgScheduler req
10543−-
10544−
10545−- let resp''= toResponse resp'
10546−+
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) -}}
10550−-
10551−+ let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}}
10552−+
10553− return resp
10554−
10555−-
10556−-------persistent state in cookies (not tested)
10557−-
10558−-tvresources :: MVar (Maybe ( M.Map string string))
10559−-tvresources= unsafePerformIO $ newMVar Nothing
10560−-statCookieName= "stat"
10561−-
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) ]
10569−-
10570−-getStateCookie req= do
10571−- mr<- readMVar tvresources
10572−- case mr of
10573−- Nothing -> return Nothing
10574−- Just map -> case M.lookup (keyResource req) map of
10575−- Nothing -> return Nothing
10576−- Just str -> do
10577−- swapMVar tvresources Nothing
10578−- return $ Just (statCookieName, str , "/")
10579−-
10580−-{-
10581−-persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
10582−- where
10583−- writeResource stat= modifyMVar_ tvresources $ \mmap ->
10584−- case mmap of
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 ->
10589−- case mmap of
10590−- Just map -> return $ M.lookup (keyResource stat) map
10591−- Nothing -> return Nothing
10592−- case mstr of
10593−- Nothing -> return Nothing
10594−- Just str -> return $ deserialize str
10595−-
10596−- deleteResource stat= modifyMVar_ tvresources $ \mmap->
10597−- case mmap of
10598−- Just map -> return $ Just $ M.delete (keyResource stat) map
10599−- Nothing -> return $ Nothing
10600−+
10601−+------persistent state in cookies (not tested)
10602−+
10603−+tvresources :: MVar (Maybe ( M.Map string string))
10604−+tvresources= unsafePerformIO $ newMVar Nothing
10605−+statCookieName= "stat"
10606−+
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) ]
10614−+
10615−+getStateCookie req= do
10616−+ mr<- readMVar tvresources
10617−+ case mr of
10618−+ Nothing -> return Nothing
10619−+ Just map -> case M.lookup (keyResource req) map of
10620−+ Nothing -> return Nothing
10621−+ Just str -> do
10622−+ swapMVar tvresources Nothing
10623−+ return $ Just (statCookieName, str , "/")
10624−+
10625−+{-
10626−+persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
10627−+ where
10628−+ writeResource stat= modifyMVar_ tvresources $ \mmap ->
10629−+ case mmap of
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 ->
10634−+ case mmap of
10635−+ Just map -> return $ M.lookup (keyResource stat) map
10636−+ Nothing -> return Nothing
10637−+ case mstr of
10638−+ Nothing -> return Nothing
10639−+ Just str -> return $ deserialize str
10640−+
10641−+ deleteResource stat= modifyMVar_ tvresources $ \mmap->
10642−+ case mmap of
10643−+ Just map -> return $ Just $ M.delete (keyResource stat) map
10644−+ Nothing -> return $ Nothing
10645−
10646− -}
10647−diff -ru orig/src/MFlow/Wai/Blaze/Html/All.hs new/src/MFlow/Wai/Blaze/Html/All.hs
10648−--- orig/src/MFlow/Wai/Blaze/Html/All.hs 2014-06-10 05:51:26.969015857 +0300
10649−+++ new/src/MFlow/Wai/Blaze/Html/All.hs 2014-06-10 05:51:25.000000000 +0300
10650−@@ -1,97 +1,99 @@
10651−-----------------------------------------------------------------------------
10652−---
10653−--- Module : MFlow.Wai.Blaze.Html.All
10654−--- Copyright :
10655−--- License : BSD3
10656−---
10657−--- Maintainer : agocorona@gmail.com
10658−--- Stability : experimental
10659−--- Portability :
10660−---
10661−--- |
10662−---
10663−------------------------------------------------------------------------------
10664−-
10665−-module MFlow.Wai.Blaze.Html.All (
10666−- module Data.TCache
10667−-,module MFlow
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
10678−-,runNavigation
10679−-,runSecureNavigation
10680−-) where
10681−-
10682−-import MFlow
10683−-import MFlow.Wai
10684−-import MFlow.Forms
10685−-import MFlow.Forms.Widgets
10686−-import MFlow.Forms.Admin
10687−-import MFlow.Forms.Blaze.Html
10688−-import MFlow.Forms.WebApi
10689−-import MFlow.Forms.Cache
10690−-import Text.Blaze.Html5 hiding (map)
10691−-import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form)
10692−-import Network.Wai
10693−-import Network.Wai.Handler.Warp hiding (getPort) --(run,defaultSettings,Settings ,setPort)
10694−-import Data.TCache
10695−-import Text.Blaze.Internal(text)
10696−-
10697−-import Control.Workflow (Workflow, unsafeIOtoWF)
10698−-
10699−-
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
10707−-
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.
10711−-getPort= do
10712−- args <- getArgs
10713−- port <- case args of
10714−- port:xs -> return port
10715−- _ -> do
10716−- env <- getEnvironment
10717−- return $ fromMaybe "80" $ lookup "PORT" env
10718−- let porti= if and $ map isNumber port then fromIntegral $ read port
10719−- else 80
10720−- putStr "using port "
10721−- print porti
10722−- return porti
10723−-
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)]
10731−- porti <- getPort
10732−- wait $ run porti waiMessageFlow
10733−- --runSettings defaultSettings{settingsTimeout = 20, settingsPort= porti} waiMessageFlow
10734−-
10735−--- | Exactly the same as runNavigation, but with TLS added.
10736−--- Expects certificate.pem and key.pem in project directory.
10737−-
10738−-runSecureNavigation = runSecureNavigation' TLS.defaultTlsSettings defaultSettings
10739−-
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)]
10744−- porti <- getPort
10745−--- let s' = setPort porti s
10746−+----------------------------------------------------------------------------
10747−+--
10748−+-- Module : MFlow.Wai.Blaze.Html.All
10749−+-- Copyright :
10750−+-- License : BSD3
10751−+--
10752−+-- Maintainer : agocorona@gmail.com
10753−+-- Stability : experimental
10754−+-- Portability :
10755−+--
10756−+-- |
10757−+--
10758−+-----------------------------------------------------------------------------
10759−+
10760−+module MFlow.Wai.Blaze.Html.All (
10761−+ module Data.TCache
10762−+,module MFlow
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
10773−+,runNavigation
10774−+,runSecureNavigation
10775−+,runSecureNavigation'
10776−+) where
10777−+
10778−+import MFlow
10779−+import MFlow.Wai
10780−+import MFlow.Forms
10781−+import MFlow.Forms.Widgets
10782−+import MFlow.Forms.Admin
10783−+import MFlow.Forms.Blaze.Html
10784−+import MFlow.Forms.WebApi
10785−+import MFlow.Forms.Cache
10786−+import Text.Blaze.Html5 hiding (map)
10787−+import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form)
10788−+import Network.Wai
10789−+import Network.Wai.Handler.Warp --(run,defaultSettings,Settings ,setPort)
10790−+import Data.TCache
10791−+import Text.Blaze.Internal(text)
10792−+
10793−+import Control.Workflow (Workflow, unsafeIOtoWF)
10794−+
10795−+
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
10803−+
10804−+
10805−+getPortW= do
10806−+ args <- getArgs
10807−+ port <- case args of
10808−+ port:xs -> return port
10809−+ _ -> do
10810−+ env <- getEnvironment
10811−+ return $ fromMaybe "80" $ lookup "PORT" env
10812−+ let porti= if and $ map isNumber port then fromIntegral $ read port
10813−+ else 80
10814−+ putStr "using port "
10815−+ print porti
10816−+ return porti
10817−+
10818−+-- | run a persistent flow. It uses `getPortW` to get the port
10819−+-- The first parameter is the first element in the URL path.
10820−+-- It also set the home page
10821−+-- The port is read from the first parameter passed to the executable.
10822−+-- If no parameter, it is read from the PORT environment variable.
10823−+-- if this does not exist, the port 80 is used.
10824−+runNavigation :: String -> FlowM Html (Workflow IO) () -> IO ()
10825−+runNavigation n f= do
10826−+ unless (null n) $ setNoScript n
10827−+ addMessageFlows[(n, runFlow f)]
10828−+ porti <- getPortW
10829−+ wait $ run porti waiMessageFlow
10830−+ --runSettings defaultSettings{settingsTimeout = 20, settingsPort= porti} waiMessageFlow
10831−+
10832−+-- | Exactly the same as runNavigation, but with TLS added.
10833−+-- Expects certificate.pem and key.pem in project directory.
10834−+
10835−+runSecureNavigation = runSecureNavigation' TLS.defaultTlsSettings defaultSettings
10836−+
10837−+runSecureNavigation' :: TLSSettings -> Settings -> String -> FlowM Html (Workflow IO) () -> IO ()
10838−+runSecureNavigation' t s n f = do
10839−+ unless (null n) $ setNoScript n
10840−+ addMessageFlows[(n, runFlow f)]
10841−+ porti <- getPortW
10842−+-- let s' = setPort porti s
10843− -- wait $ TLS.runTLS t s' waiMessageFlow
10844−- wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow
10845−+ wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow
10846−diff -ru orig/src/MFlow/Wai/Response.hs new/src/MFlow/Wai/Response.hs
10847−--- orig/src/MFlow/Wai/Response.hs 2014-06-10 05:51:26.965015857 +0300
10848−+++ new/src/MFlow/Wai/Response.hs 2014-06-10 05:51:25.000000000 +0300
10849−@@ -1,62 +1,62 @@
10850−-{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances
10851−- -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
10852−-module MFlow.Wai.Response where
10853−-
10854−-import Network.Wai
10855−-import MFlow.Cookies
10856−-
10857−-import Data.ByteString.Lazy.UTF8
10858−-import MFlow
10859−-import Data.Typeable
10860−-import Data.Monoid
10861−-import System.IO.Unsafe
10862−-import Data.Map as M
10863−-import Data.CaseInsensitive
10864−-import Network.HTTP.Types
10865−-import Control.Workflow(WFErrors(..))
10866−---import Data.String
10867−---import Debug.Trace
10868−---
10869−---(!>)= flip trace
10870−-
10871−-
10872−-
10873−-class ToResponse a where
10874−- toResponse :: a -> Response
10875−-
10876−-
10877−-
10878−-data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable
10879−-
10880−-instance Monoid TResp where
10881−- mempty = TRempty
10882−- mappend (TResp x) (TResp y)=
10883−- case cast y of
10884−- Just y' -> TResp $ mappend x y'
10885−- Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
10886−-
10887−-
10888−-mkParams = Prelude.map mkparam
10889−-mkparam (x,y)= (mk x, y)
10890−-
10891−-instance ToResponse TResp where
10892−- toResponse (TResp x)= toResponse x
10893−- toResponse (TRespR r)= toResponse r
10894−-
10895−-instance ToResponse Response where
10896−- toResponse = id
10897−-
10898−-instance ToResponse ByteString where
10899−- toResponse x= responseLBS status200 [mkparam contentHtml] x
10900−-
10901−-instance ToResponse String where
10902−- toResponse x= responseLBS status200 [mkparam contentHtml] $ fromString x
10903−-
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
10907−-
10908−--- toResponse $ error "FATAL ERROR: HttpData errors should not reach here: MFlow.Forms.Response.hs "
10909−-
10910−-
10911−-
10912−+{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances
10913−+ -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
10914−+module MFlow.Wai.Response where
10915−+
10916−+import Network.Wai
10917−+import MFlow.Cookies
10918−+
10919−+import Data.ByteString.Lazy.UTF8
10920−+import MFlow
10921−+import Data.Typeable
10922−+import Data.Monoid
10923−+import System.IO.Unsafe
10924−+import Data.Map as M
10925−+import Data.CaseInsensitive
10926−+import Network.HTTP.Types
10927−+import Control.Workflow(WFErrors(..))
10928−+--import Data.String
10929−+--import Debug.Trace
10930−+--
10931−+--(!>)= flip trace
10932−+
10933−+
10934−+
10935−+class ToResponse a where
10936−+ toResponse :: a -> Response
10937−+
10938−+
10939−+
10940−+data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable
10941−+
10942−+instance Monoid TResp where
10943−+ mempty = TRempty
10944−+ mappend (TResp x) (TResp y)=
10945−+ case cast y of
10946−+ Just y' -> TResp $ mappend x y'
10947−+ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
10948−+
10949−+
10950−+mkParams = Prelude.map mkparam
10951−+mkparam (x,y)= (mk x, y)
10952−+
10953−+instance ToResponse TResp where
10954−+ toResponse (TResp x)= toResponse x
10955−+ toResponse (TRespR r)= toResponse r
10956−+
10957−+instance ToResponse Response where
10958−+ toResponse = id
10959−+
10960−+instance ToResponse ByteString where
10961−+ toResponse x= responseLBS status200 [mkparam contentHtml] x
10962−+
10963−+instance ToResponse String where
10964−+ toResponse x= responseLBS status200 [mkparam contentHtml] $ fromString x
10965−+
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
10969−+
10970−+-- toResponse $ error "FATAL ERROR: HttpData errors should not reach here: MFlow.Forms.Response.hs "
10971−+
10972−+
10973−+
10974−diff -ru orig/src/MFlow/Wai.hs new/src/MFlow/Wai.hs
10975−--- orig/src/MFlow/Wai.hs 2014-06-10 05:51:26.957015857 +0300
10976−+++ new/src/MFlow/Wai.hs 2014-06-10 05:51:25.000000000 +0300
10977−@@ -1,184 +1,209 @@
10978−-{-# LANGUAGE UndecidableInstances
10979−- , CPP
10980−- , TypeSynonymInstances
10981−- , MultiParamTypeClasses
10982−- , DeriveDataTypeable
10983−- , FlexibleInstances
10984−- , OverloadedStrings #-}
10985−-
10986−-module MFlow.Wai(
10987−- module MFlow.Cookies
10988−- ,module MFlow
10989−- ,waiMessageFlow)
10990−-where
10991−-
10992−-import Data.Typeable
10993−-import Network.Wai
10994−-
10995−-import Control.Concurrent.MVar(modifyMVar_, readMVar)
10996−-import Control.Monad(when)
10997−-
10998−-
10999−-import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail)
11000−-import Data.ByteString.Lazy(fromChunks)
11001−+{-# LANGUAGE UndecidableInstances
11002−+ , CPP
11003−+ , TypeSynonymInstances
11004−+ , MultiParamTypeClasses
11005−+ , DeriveDataTypeable
11006−+ , FlexibleInstances
11007−+ , OverloadedStrings #-}
11008−+
11009−+module MFlow.Wai(
11010−+ module MFlow.Cookies
11011−+ ,module MFlow
11012−+ ,waiMessageFlow)
11013−+where
11014−+
11015−+import Data.Typeable
11016−+import Network.Wai
11017−+
11018−+import Control.Concurrent.MVar(modifyMVar_, readMVar)
11019−+import Control.Monad(when)
11020−+
11021−+
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
11033−-import Data.Maybe
11034−-import Data.TCache
11035−-import Data.TCache.DefaultPersistence
11036−-import Control.Workflow hiding (Indexable(..))
11037−-
11038−-import MFlow
11039−-import MFlow.Cookies
11040−-import Data.Monoid
11041−-import MFlow.Wai.Response
11042−-import Network.Wai
11043−-import Network.HTTP.Types -- hiding (urlDecode)
11044−-import Data.Conduit
11045−-import Data.Conduit.Lazy
11046−-import qualified Data.Conduit.List as CList
11047−-import Data.CaseInsensitive
11048−-import System.Time
11049−-import qualified Data.Text as T
11050−-
11051−-
11052−---import Debug.Trace
11053−---(!>) = flip trace
11054−-
11055−-flow= "flow"
11056−-
11057−-instance Processable Request where
11058−- pwfPath env= if Prelude.null sc then [noScript] else Prelude.map T.unpack sc
11059−- where
11060−- sc= let p= pathInfo env
11061−- p'= reverse p
11062−- in case p' of
11063−- [] -> []
11064−- p' -> if T.null $ head p' then reverse(tail p') else p
11065−-
11066−-
11067−- puser env = fromMaybe anonymous $ fmap toString $ lookup ( mk $ fromString cookieuser) $ requestHeaders env
11068−-
11069−- pind env= fromMaybe (error ": No FlowID") $ fmap toString $ lookup (mk flow) $ requestHeaders env
11070−- getParams= mkParams1 . requestHeaders
11071−- where
11072−- mkParams1 = Prelude.map mkParam1
11073−- mkParam1 ( x,y)= (toString $ original x, toString y)
11074−-
11075−--- getServer env= serverName env
11076−--- getPath env= pathInfo env
11077−--- getPort env= serverPort env
11078−-
11079−-
11080−-splitPath ""= ("","","")
11081−-splitPath str=
11082−- let
11083−- strr= reverse str
11084−- (ext, rest)= span (/= '.') strr
11085−- (mod, path)= span(/='/') $ tail rest
11086−- in (tail $ reverse path, reverse mod, reverse ext)
11087−-
11088−-
11089−-waiMessageFlow :: Application
11090−-waiMessageFlow req1= do
11091−- let httpreq1= requestHeaders req1
11092−-
11093−- let cookies = getCookies httpreq1
11094−-
11095−- (flowval , retcookies) <- case lookup flow cookies of
11096−- Just fl -> return (fl, [])
11097−- Nothing -> do
11098−- fl <- liftIO $ newFlow
11099−- return (fl, [UnEncryptedCookie (flow, fl, "/",Nothing):: Cookie])
11100−-
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
11106−--}
11107−-
11108−- input <- case parseMethod $ requestMethod req1 of
11109−- Right POST -> do
11110−-
11111−- inp <- liftIO $ requestBody req1 $$ CList.consume
11112−-
11113−- return . parseSimpleQuery $ SB.concat inp
11114−-
11115−-
11116−-
11117−- Right GET ->
11118−- return . Prelude.map (\(x,y) -> (x,fromMaybe "" y)) $ queryString req1
11119−-
11120−-
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"
11124−-
11125−-
11126−- (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req)
11127−-
11128−- let resp= case (resp',retcookies) of
11129−- (_,[]) -> resp'
11130−- (error@(Error _),_) -> error
11131−- (HttpData hs co str,_) -> HttpData hs (co++ retcookies) str
11132−-
11133−- return $ toResponse resp
11134−-
11135−-
11136−-------persistent state in cookies (not tested)
11137−-
11138−-tvresources :: MVar (Maybe ( M.Map string string))
11139−-tvresources= unsafePerformIO $ newMVar Nothing
11140−-statCookieName= "stat"
11141−-
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) ]
11149−-
11150−-getStateCookie req= do
11151−- mr<- readMVar tvresources
11152−- case mr of
11153−- Nothing -> return Nothing
11154−- Just map -> case M.lookup (keyResource req) map of
11155−- Nothing -> return Nothing
11156−- Just str -> do
11157−- swapMVar tvresources Nothing
11158−- return $ Just (statCookieName, str , "/")
11159−-
11160−-
11161−-
11162−-
11163−-{-
11164−-persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
11165−- where
11166−- writeResource stat= modifyMVar_ tvresources $ \mmap ->
11167−- case mmap of
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 ->
11172−- case mmap of
11173−- Just map -> return $ M.lookup (keyResource stat) map
11174−- Nothing -> return Nothing
11175−- case mstr of
11176−- Nothing -> return Nothing
11177−- Just str -> return $ deserialize str
11178−-
11179−- deleteResource stat= modifyMVar_ tvresources $ \mmap->
11180−- case mmap of
11181−- Just map -> return $ Just $ M.delete (keyResource stat) map
11182−- Nothing -> return $ Nothing
11183−-
11184−--}
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
11193−+import Data.Maybe
11194−+import Data.TCache
11195−+import Data.TCache.DefaultPersistence
11196−+import Control.Workflow hiding (Indexable(..))
11197−+
11198−+import MFlow
11199−+import MFlow.Cookies
11200−+import Data.Monoid
11201−+import MFlow.Wai.Response
11202−+import Network.Wai
11203−+import Network.Wai.Parse
11204−+import qualified Data.Conduit.Binary as CB
11205−+import Control.Monad.Trans.Resource
11206−+import Network.HTTP.Types
11207−+import Data.Conduit
11208−+import Data.Conduit.Lazy
11209−+import qualified Data.Conduit.List as CList
11210−+import Data.CaseInsensitive
11211−+import System.Time
11212−+import System.Directory
11213−+import System.IO
11214−+import qualified Data.Text as T
11215−+
11216−+
11217−+import Debug.Trace
11218−+(!>) = flip trace
11219−+
11220−+flow= "flow"
11221−+
11222−+instance Processable Request where
11223−+ pwfPath env= if Prelude.null sc then [noScript] else Prelude.map T.unpack sc
11224−+ where
11225−+ sc= let p= pathInfo env
11226−+ p'= reverse p
11227−+ in case p' of
11228−+ [] -> []
11229−+ p' -> if T.null $ head p' then reverse(tail p') else p
11230−+
11231−+
11232−+ puser env = fromMaybe anonymous $ fmap toString $ lookup ( mk $ fromString cookieuser) $ requestHeaders env
11233−+
11234−+ pind env= fromMaybe (error ": No FlowID") $ fmap toString $ lookup (mk flow) $ requestHeaders env
11235−+ getParams= mkParams1 . requestHeaders
11236−+ where
11237−+ mkParams1 = Prelude.map mkParam1
11238−+ mkParam1 ( x,y)= (toString $ original x, toString y)
11239−+
11240−+toApp :: (Request -> IO Response) -> Application
11241−+#if MIN_VERSION_wai(3, 0, 0)
11242−+toApp f req sendResponse = f req >>= sendResponse
11243−+#else
11244−+toApp = id
11245−+#endif
11246−+
11247−+waiMessageFlow :: Application
11248−+waiMessageFlow = toApp $ \req1 -> do
11249−+ let httpreq1= requestHeaders req1
11250−+
11251−+ let cookies = getCookies httpreq1
11252−+
11253−+ (flowval , retcookies) <- case lookup flow cookies of
11254−+ Just fl -> return (fl, [])
11255−+ Nothing -> do
11256−+ fl <- liftIO $ newFlow
11257−+ return (fl, [UnEncryptedCookie (flow, fl, "/",Nothing):: Cookie])
11258−+
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
11264−+-}
11265−+
11266−+ (params,files) <- case parseMethod $ requestMethod req1 of
11267−+ Right GET -> do
11268−+ return (Prelude.map (\(x,y) -> (x,fromMaybe "" y)) $ queryString req1,[])
11269−+
11270−+ Right POST -> do
11271−+
11272−+ case getRequestBodyType req1 of
11273−+ Nothing -> error $ "getRequestBodyType: "
11274−+ Just rbt ->
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)
11280−+ CB.sinkHandle h
11281−+ lift $ release key
11282−+ return fp
11283−+#if MIN_VERSION_wai(3, 0, 0)
11284−+ let backend' file info getBS = do
11285−+ let src = do
11286−+ bs <- liftIO getBS
11287−+ when (not $ SB.null bs) $ do
11288−+ Data.Conduit.yield bs
11289−+ src
11290−+ src $$ backend file info
11291−+ sinkRequestBody backend' rbt (requestBody req1)
11292−+#else
11293−+ requestBody req1 $$ sinkRequestBody backend rbt
11294−+#endif
11295−+
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
11304−+
11305−+
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}
11309−+
11310−+
11311−+ (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req)
11312−+
11313−+ let resp= case (resp',retcookies) of
11314−+ (_,[]) -> resp'
11315−+ (error@(Error _),_) -> error
11316−+ (HttpData hs co str,_) -> HttpData hs (co++ retcookies) str
11317−+
11318−+ return $ toResponse resp
11319−+
11320−+
11321−+------persistent state in cookies (not tested)
11322−+
11323−+tvresources :: MVar (Maybe ( M.Map string string))
11324−+tvresources= unsafePerformIO $ newMVar Nothing
11325−+statCookieName= "stat"
11326−+
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) ]
11334−+
11335−+getStateCookie req= do
11336−+ mr<- readMVar tvresources
11337−+ case mr of
11338−+ Nothing -> return Nothing
11339−+ Just map -> case M.lookup (keyResource req) map of
11340−+ Nothing -> return Nothing
11341−+ Just str -> do
11342−+ swapMVar tvresources Nothing
11343−+ return $ Just (statCookieName, str , "/")
11344−+
11345−+
11346−+
11347−+
11348−+{-
11349−+persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
11350−+ where
11351−+ writeResource stat= modifyMVar_ tvresources $ \mmap ->
11352−+ case mmap of
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 ->
11357−+ case mmap of
11358−+ Just map -> return $ M.lookup (keyResource stat) map
11359−+ Nothing -> return Nothing
11360−+ case mstr of
11361−+ Nothing -> return Nothing
11362−+ Just str -> return $ deserialize str
11363−+
11364−+ deleteResource stat= modifyMVar_ tvresources $ \mmap->
11365−+ case mmap of
11366−+ Just map -> return $ Just $ M.delete (keyResource stat) map
11367−+ Nothing -> return $ Nothing
11368−+
11369−+-}
11370−diff -ru orig/src/MFlow.hs new/src/MFlow.hs
11371−--- orig/src/MFlow.hs 2014-06-10 05:51:26.957015857 +0300
11372−+++ new/src/MFlow.hs 2014-06-10 05:51:25.000000000 +0300
11373−@@ -1,545 +1,550 @@
11374−-{- | Non monadic low level primitives that implement the MFlow application server.
11375−-See "MFlow.Form" for the higher level interface that you may use.
11376−-
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.
11384−-
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.
11388−-
11389−-"MFlow.Hack" is an instantiation for the Hack interface in a Web context.
11390−-
11391−-"MFlow.Wai" is a instantiation for the WAI interface.
11392−-
11393−-"MFlow.Forms" implements a monadic type safe interface with composabe widgets and and applicative
11394−-combinator as well as an higher comunication interface.
11395−-
11396−-"MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format
11397−-
11398−-"MFlow.Forms.Blaze.Html" is an instantaiation for blaze-html
11399−-
11400−-"MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format
11401−-
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>
11406−-
11407−-
11408−-In order to manage resources, there are primitives that kill the process and its state after a timeout.
11409−-
11410−-All these details are hidden in the monad of "MFlow.Forms" that provides an higher level interface.
11411−-
11412−-Fragment based streaming: 'sendFragment' are provided only at this level.
11413−-
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.
11416−-
11417−--}
11418−-
11419−-
11420−-{-# LANGUAGE DeriveDataTypeable, UndecidableInstances
11421−- ,ExistentialQuantification
11422−- ,MultiParamTypeClasses
11423−- ,FunctionalDependencies
11424−- ,TypeSynonymInstances
11425−- ,FlexibleInstances
11426−- ,FlexibleContexts
11427−- ,RecordWildCards
11428−- ,OverloadedStrings
11429−- ,ScopedTypeVariables
11430−-
11431−- #-}
11432−-module MFlow (
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
11444−--- * user
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.
11448−+
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.
11456−+
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.
11460−+
11461−+"MFlow.Hack" is an instantiation for the Hack interface in a Web context.
11462−+
11463−+"MFlow.Wai" is a instantiation for the WAI interface.
11464−+
11465−+"MFlow.Forms" implements a monadic type safe interface with composabe widgets and and applicative
11466−+combinator as well as an higher comunication interface.
11467−+
11468−+"MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format
11469−+
11470−+"MFlow.Forms.Blaze.Html" is an instantaiation for blaze-html
11471−+
11472−+"MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format
11473−+
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>
11478−+
11479−+
11480−+In order to manage resources, there are primitives that kill the process and its state after a timeout.
11481−+
11482−+All these details are hidden in the monad of "MFlow.Forms" that provides an higher level interface.
11483−+
11484−+Fragment based streaming: 'sendFragment' are provided only at this level.
11485−+
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.
11488−+
11489−+-}
11490−+
11491−+
11492−+{-# LANGUAGE DeriveDataTypeable, UndecidableInstances
11493−+ ,ExistentialQuantification
11494−+ ,MultiParamTypeClasses
11495−+ ,FunctionalDependencies
11496−+ ,TypeSynonymInstances
11497−+ ,FlexibleInstances
11498−+ ,FlexibleContexts
11499−+ ,RecordWildCards
11500−+ ,OverloadedStrings
11501−+ ,ScopedTypeVariables
11502−+ ,BangPatterns
11503−+ #-}
11504−+module MFlow (
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
11516−+-- * user
11517−+, userRegister, setAdminUser, getAdminName, Auth(..),getAuthMethod, setAuthMethod
11518− -- * static files
11519− -- * config
11520−-,config, getConfig
11521−-,setFilesPath
11522−--- * internal use
11523−-,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow
11524−-,UserStr,PasswdStr, User(..),eUser
11525−-
11526−-)
11527−-where
11528−-import Control.Concurrent.MVar
11529−-import Data.IORef
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)
11536−-
11537−-import Data.Monoid
11538−-import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId)
11539−-import Data.Char(toLower)
11540−-
11541−-import Unsafe.Coerce
11542−-import System.IO.Unsafe
11543−-import Data.TCache
11544−-import Data.TCache.DefaultPersistence hiding(Indexable(..))
11545−-import Data.TCache.Memoization
11546−-import qualified Data.ByteString.Lazy.Char8 as B (head, readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks)
11547−-import Data.ByteString.Lazy.Internal (ByteString(Chunk))
11548−-import qualified Data.ByteString.Char8 as SB
11549−-import qualified Data.Map as M
11550−-import System.IO
11551−-import System.Time
11552−-import Control.Workflow
11553−-import MFlow.Cookies
11554−-import Control.Monad.Trans
11555−-import qualified Control.Exception as CE
11556−-import Data.RefSerialize hiding (empty)
11557−-import qualified Data.Text as T
11558−-import System.Posix.Internals
11559−-import Control.Exception
11560−---import Debug.Trace
11561−---(!>) = flip trace
11562−-
11563−-
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
11567−-
11568−-instance Indexable Token where
11569−- key (Token w u i _ _ _ _ _ )= i
11570−--- if u== anonymous then u ++ i -- ++ "@" ++ w
11571−--- else u -- ++ "@" ++ w
11572−-
11573−-instance Show Token where
11574−- show t = "Token " ++ key t
11575−-
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)]
11580−-
11581−- where
11582−-
11583−- (ui,str')= span(/='@') str1
11584−- i = drop (length anonymous) ui
11585−- (w,str2) = span (not . isSeparator) $ tail str'
11586−- newVar _= unsafePerformIO $ newEmptyMVar
11587−-
11588−-
11589−- readsPrec _ str= error $ "parse error in Token read from: "++ str
11590−-
11591−-instance Serializable Token where
11592−- serialize = B.pack . show
11593−- deserialize= read . B.unpack
11594−- setPersist = \_ -> Just filePersist
11595−-
11596−-iorefqmap= unsafePerformIO . newMVar $ M.empty
11597−-
11598−-addTokenToList t@Token{..} =
11599−- modifyMVar_ iorefqmap $ \ map ->
11600−- return $ M.insert ( tind ++ twfname ++ tuser ) t map
11601−-
11602−-deleteTokenInList t@Token{..} =
11603−- modifyMVar_ iorefqmap $ \ map ->
11604−- return $ M.delete (tind ++ twfname ++ tuser) map
11605−-
11606−-getToken msg= do
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
11610−- case mqs of
11611−- Nothing -> do
11612−- q <- newEmptyMVar -- `debug` (i++w++u)
11613−+,config,getConfig
11614−+,setFilesPath
11615−+-- * internal use
11616−+,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow
11617−+,UserStr,PasswdStr, User(..),eUser
11618−+
11619−+)
11620−+where
11621−+import Control.Concurrent.MVar
11622−+import Data.IORef
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)
11629−+
11630−+import Data.Monoid
11631−+import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId)
11632−+import Data.Char(toLower)
11633−+
11634−+import Unsafe.Coerce
11635−+import System.IO.Unsafe
11636−+import Data.TCache
11637−+import Data.TCache.DefaultPersistence hiding(Indexable(..))
11638−+import Data.TCache.Memoization
11639−+import qualified Data.ByteString.Lazy.Char8 as B (head, readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks)
11640−+import Data.ByteString.Lazy.Internal (ByteString(Chunk))
11641−+import qualified Data.ByteString.Char8 as SB
11642−+import qualified Data.Map as M
11643−+import System.IO
11644−+import System.Time
11645−+import Control.Workflow
11646−+import MFlow.Cookies
11647−+import Control.Monad.Trans
11648−+import qualified Control.Exception as CE
11649−+import Data.RefSerialize hiding (empty)
11650−+import qualified Data.Text as T
11651−+import System.Posix.Internals
11652−+import Control.Exception
11653−+import Crypto.PasswordStore
11654−+
11655−+
11656−+--import Debug.Trace
11657−+--(!>) = flip trace
11658−+
11659−+
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
11663−+
11664−+instance Indexable Token where
11665−+ key (Token w u i _ _ _ _ _ )= i
11666−+-- if u== anonymous then u ++ i -- ++ "@" ++ w
11667−+-- else u -- ++ "@" ++ w
11668−+
11669−+instance Show Token where
11670−+ show t = "Token " ++ key t
11671−+
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)]
11676−+
11677−+ where
11678−+
11679−+ (ui,str')= span(/='@') str1
11680−+ i = drop (length anonymous) ui
11681−+ (w,str2) = span (not . isSeparator) $ tail str'
11682−+ newVar _= unsafePerformIO $ newEmptyMVar
11683−+
11684−+
11685−+ readsPrec _ str= error $ "parse error in Token read from: "++ str
11686−+
11687−+instance Serializable Token where
11688−+ serialize = B.pack . show
11689−+ deserialize= read . B.unpack
11690−+ setPersist = \_ -> Just filePersist
11691−+
11692−+iorefqmap= unsafePerformIO . newMVar $ M.empty
11693−+
11694−+addTokenToList t@Token{..} =
11695−+ modifyMVar_ iorefqmap $ \ map ->
11696−+ return $ M.insert ( tind ++ twfname ++ tuser ) t map
11697−+
11698−+deleteTokenInList t@Token{..} =
11699−+ modifyMVar_ iorefqmap $ \ map ->
11700−+ return $ M.delete (tind ++ twfname ++ tuser) map
11701−+
11702−+getToken msg= do
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
11706−+ case mqs of
11707−+ Nothing -> do
11708−+ q <- newEmptyMVar -- `debug` (i++w++u)
11709− qr <- newEmptyMVar
11710−- pblock <- newMVar True
11711−- let token= Token w u i ppath penv pblock q qr
11712−- addTokenToList token
11713−- return token
11714−-
11715−- Just token -> return token{tpath= ppath, tenv= penv}
11716−-
11717−-
11718−-type Flow= (Token -> Workflow IO ())
11719−-
11720−-data HttpData = HttpData [(SB.ByteString,SB.ByteString)] [Cookie] ByteString | Error ByteString deriving (Typeable, Show)
11721−-
11722−-
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'
11726−-
11727−--- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname
11728−-type ProcList = WorkflowList IO Token ()
11729−-
11730−-
11731−-data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable
11732−-
11733−-type Params = [(String,String)]
11734−-
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
11742−-
11743−-instance Processable Token where
11744−- pwfname = twfname
11745−- pwfPath = tpath
11746−- puser = tuser
11747−- pind = tind
11748−- getParams = tenv
11749−-
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
11758−-
11759−-data Resp = Fragm HttpData
11760−- | EndFragm HttpData
11761−- | Resp HttpData
11762−-
11763−-
11764−-
11765−-
11766−--- | The anonymous user
11767−-anonymous= "anon#"
11768−-
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
11773−+ return token
11774−+
11775−+ Just token -> return token{tpath= ppath, tenv= penv}
11776−+
11777−+
11778−+type Flow= (Token -> Workflow IO ())
11779−+
11780−+data HttpData = HttpData [(SB.ByteString,SB.ByteString)] [Cookie] ByteString | Error ByteString deriving (Typeable, Show)
11781−+
11782−+
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'
11786−+
11787−+-- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname
11788−+type ProcList = WorkflowList IO Token ()
11789−+
11790−+
11791−+data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable
11792−+
11793−+type Params = [(String,String)]
11794−+
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
11802−+
11803−+instance Processable Token where
11804−+ pwfname = twfname
11805−+ pwfPath = tpath
11806−+ puser = tuser
11807−+ pind = tind
11808−+ getParams = tenv
11809−+
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
11818−+
11819−+data Resp = Fragm HttpData
11820−+ | EndFragm HttpData
11821−+ | Resp HttpData
11822−+
11823−+
11824−+
11825−+
11826−+-- | The anonymous user
11827−+anonymous= "anon#"
11828−+
11829−+-- | It is the path of the root flow
11830− noScriptRef= unsafePerformIO $ newIORef "noscript"
11831−-
11832−-noScript= unsafePerformIO $ readIORef noScriptRef
11833−+
11834−+noScript= unsafePerformIO $ readIORef noScriptRef
11835−
11836− -- | set the flow to be executed when the URL has no path. The home page.
11837− --
11838− -- By default it is "noscript".
11839− -- Although it is changed by `runNavigation` to his own flow name.
11840−-setNoScript scr= writeIORef noScriptRef scr
11841−-
11842−-{-
11843−-instance (Monad m, Show a) => Traceable (Workflow m a) where
11844−- debugf iox str = do
11845−- x <- iox
11846−- return $ debug x (str++" => Workflow "++ show x)
11847−--}
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)
11852−-
11853−-sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush "
11854−-
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
11858−-
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
11862−-
11863−---emptyReceive (Token queue _ _)= emptyQueue queue
11864−-receive :: Typeable a => Token -> IO a
11865−-receive t= receiveReq t >>= return . fromReq
11866−-
11867−-flushResponse t@(Token _ _ _ _ _ _ _ qresp)= tryTakeMVar qresp
11868−-
11869−-
11870−-flushRec t@(Token _ _ _ _ _ _ queue _)= tryTakeMVar queue -- !> "flushRec"
11871−-
11872−-receiveReq :: Token -> IO Req
11873−+setNoScript scr= writeIORef noScriptRef scr
11874−+
11875−+{-
11876−+instance (Monad m, Show a) => Traceable (Workflow m a) where
11877−+ debugf iox str = do
11878−+ x <- iox
11879−+ return $ debug x (str++" => Workflow "++ show x)
11880−+-}
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)
11885−+
11886−+sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush "
11887−+
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
11891−+
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
11895−+
11896−+--emptyReceive (Token queue _ _)= emptyQueue queue
11897−+receive :: Typeable a => Token -> IO a
11898−+receive t= receiveReq t >>= return . fromReq
11899−+
11900−+flushResponse t@(Token _ _ _ _ _ _ _ qresp)= tryTakeMVar qresp
11901−+
11902−+
11903−+flushRec t@(Token _ _ _ _ _ _ queue _)= tryTakeMVar queue -- !> "flushRec"
11904−+
11905−+receiveReq :: Token -> IO Req
11906− receiveReq t@(Token _ _ _ _ _ _ queue _)= do
11907− r <- readMVar queue -- !> (">>>>>> receiveReq ")
11908−- return r -- !> "receiveReq >>>>"
11909−-
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')
11914−- Just y -> y
11915−-
11916−-
11917−-receiveReqTimeout :: Int
11918−- -> Integer
11919−- -> Token
11920−- -> IO Req
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)
11924−-
11925−-
11926−-delMsgHistory t = do
11927−- let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t
11928−- delWFHistory1 statKey -- `debug` "delWFHistory"
11929−-
11930−-
11931−-
11932−--- | executes a simple request-response computation that receive the params and return a response
11933−---
11934−--- It is used with `addMessageFlows`
11935−---
11936−--- There is a higuer level version @wstateless@ in "MFLow.Forms"
11937−-stateless :: (Params -> IO HttpData) -> Flow
11938−-stateless f = transient proc
11939−- where
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)
11946−-
11947−-
11948−-
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
11951−---
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) )
11955−-
11956−-
11957−-_messageFlows :: MVar (WorkflowList IO Token ()) -- MVar (M.Map String (Token -> Workflow IO ()))
11958−-_messageFlows= unsafePerformIO $ newMVar emptyFList
11959−- where
11960−- emptyFList= M.empty :: WorkflowList IO Token ()
11961−-
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)
11965−- flt e= e
11966−-
11967−--- | return the list of the scheduler
11968−-getMessageFlows = readMVar _messageFlows
11969−-
11970−-delMessageFlow wfname= modifyMVar_ _messageFlows (\ms -> return $ M.delete wfname ms)
11971−-
11972−-
11973−-sendToMF Token{..} msg= putMVar tsendq (Req msg) -- !> "sendToMF"
11974−-
11975−---recFromMF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c
11976−-recFromMF t@Token{..} = do
11977−- m <- takeMVar trecq -- !> "recFromMF <<<<<< "
11978−- case m of
11979−- Resp r -> return r -- !> "<<<<<< recFromMF"
11980−- Fragm r -> do
11981−- result <- getStream r
11982−- return result
11983−-
11984−- where
11985−- getStream r = do
11986−- mr <- takeMVar trecq
11987−- case mr of
11988−- Fragm h -> do
11989−- rest <- unsafeInterleaveIO $ getStream h
11990−- let result= mappend r rest
11991−- return result
11992−- EndFragm h -> do
11993−- let result= mappend r h
11994−- return result
11995−-
11996−- Resp h -> do
11997−- let result= mappend r h
11998−- return result
11999−-
12000−-
12001−-
12002−-
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
12005−--- and return it.
12006−---
12007−--- It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it
12008−-msgScheduler
12009−- :: (Typeable a,Processable a)
12010−- => a -> IO (HttpData, ThreadId)
12011−-msgScheduler x = do
12012−+ return r -- !> "receiveReq >>>>"
12013−+
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')
12018−+ Just y -> y
12019−+
12020−+
12021−+receiveReqTimeout :: Int
12022−+ -> Integer
12023−+ -> Token
12024−+ -> IO Req
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)
12028−+
12029−+
12030−+delMsgHistory t = do
12031−+ let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t
12032−+ delWFHistory1 statKey -- `debug` "delWFHistory"
12033−+
12034−+
12035−+
12036−+-- | executes a simple request-response computation that receive the params and return a response
12037−+--
12038−+-- It is used with `addMessageFlows`
12039−+--
12040−+-- There is a higuer level version @wstateless@ in "MFLow.Forms"
12041−+stateless :: (Params -> IO HttpData) -> Flow
12042−+stateless f = transient proc
12043−+ where
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)
12050−+
12051−+
12052−+
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
12055−+--
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) )
12059−+
12060−+
12061−+_messageFlows :: MVar (WorkflowList IO Token ()) -- MVar (M.Map String (Token -> Workflow IO ()))
12062−+_messageFlows= unsafePerformIO $ newMVar emptyFList
12063−+ where
12064−+ emptyFList= M.empty :: WorkflowList IO Token ()
12065−+
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)
12069−+ flt e= e
12070−+
12071−+-- | return the list of the scheduler
12072−+getMessageFlows = readMVar _messageFlows
12073−+
12074−+delMessageFlow wfname= modifyMVar_ _messageFlows (\ms -> return $ M.delete wfname ms)
12075−+
12076−+
12077−+sendToMF Token{..} msg= putMVar tsendq (Req msg) -- !> "sendToMF"
12078−+
12079−+--recFromMF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c
12080−+recFromMF t@Token{..} = do
12081−+ m <- takeMVar trecq -- !> "recFromMF <<<<<< "
12082−+ case m of
12083−+ Resp r -> return r -- !> "<<<<<< recFromMF"
12084−+ Fragm r -> do
12085−+ result <- getStream r
12086−+ return result
12087−+
12088−+ where
12089−+ getStream r = do
12090−+ mr <- takeMVar trecq
12091−+ case mr of
12092−+ Fragm h -> do
12093−+ rest <- unsafeInterleaveIO $ getStream h
12094−+ let result= mappend r rest
12095−+ return result
12096−+ EndFragm h -> do
12097−+ let result= mappend r h
12098−+ return result
12099−+
12100−+ Resp h -> do
12101−+ let result= mappend r h
12102−+ return result
12103−+
12104−+
12105−+
12106−+
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
12109−+-- and return it.
12110−+--
12111−+-- It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it
12112−+msgScheduler
12113−+ :: (Typeable a,Processable a)
12114−+ => a -> IO (HttpData, ThreadId)
12115−+msgScheduler x = do
12116− token <- getToken x
12117−- th <- myThreadId
12118−+ th <- myThreadId
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
12130− where
12131−- criticalSection mv f= bracket
12132−- (takeMVar mv)
12133−- (putMVar mv)
12134−+ criticalSection mv f= bracket
12135−+ (takeMVar mv)
12136−+ (putMVar mv)
12137− $ const $ f
12138−-
12139−- --start the flow if not started yet
12140−- startMessageFlow wfname token =
12141−- forkIO $ do
12142−- wfs <- getMessageFlows
12143−- r <- startWF wfname token wfs -- !>( "init wf " ++ wfname)
12144−- case r of
12145−- Left NotFound -> do
12146−- (sendFlush token =<< serveFile (pwfname x))
12147−+
12148−+ --start the flow if not started yet
12149−+ startMessageFlow wfname token =
12150−+ forkIO $ do
12151−+ wfs <- getMessageFlows
12152−+ r <- startWF wfname token wfs -- !>( "init wf " ++ wfname)
12153−+ case r of
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
12160−-
12161−- Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname)
12162−-
12163−- Left Timeout -> do
12164−- hFlush stdout -- !> ("TIMEOUT in msgScheduler" ++ (show $ unsafePerformIO myThreadId))
12165−- deleteTokenInList token
12166−-
12167−- Left (WFException e)-> do
12168−- showError wfname token e
12169−- moveState wfname token token{tind= "error/"++tuser token}
12170−- deleteTokenInList token -- !> "DELETETOKEN"
12171−-
12172−-
12173−- Right _ -> delMsgHistory token >> return () -- !> ("finished " ++ wfname)
12174−-
12175−-
12176−-
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
12180−- logError msg
12181−- fresp <- getNotFoundResponse
12182−- let admin= getAdminName
12183−- sendFlush token . Error $ fresp (tuser== admin) $ Prelude.concat[ "<br/>"++ s | s <- lines msg]
12184−-
12185−-
12186−-errorMessage t e u path env=
12187−- "\n---------------------ERROR-------------------------\
12188−- \\nTIME=" ++ t ++"\n\n" ++
12189−- e++
12190−- "\n\nUSER= " ++ u ++
12191−- "\n\nPATH= " ++ path ++
12192−- "\n\nREQUEST:\n\n" ++
12193−- show env
12194−-
12195−-line= unsafePerformIO $ newMVar ()
12196−-
12197−-logError err= do
12198−- takeMVar line
12199−- putStrLn err
12200−- hSeek hlog SeekFromEnd 0
12201−- hPutStrLn hlog err
12202−- hFlush hlog
12203−- putMVar line ()
12204−-
12205−-logFileName= "errlog"
12206−-
12207−-
12208−-
12209−--- | The handler of the error log
12210−-hlog= unsafePerformIO $ openFile logFileName ReadWriteMode
12211−-
12212−------- USER MANAGEMENT -------
12213−-
12214−-data Auth = Auth{
12215−- uregister :: UserStr -> PasswdStr -> (IO (Maybe String)),
12216−- uvalidate :: UserStr -> PasswdStr -> (IO (Maybe String))}
12217−-
12218−-_authMethod= unsafePerformIO $ newIORef $ Auth tCacheRegister tCacheValidate
12219−-
12220−--- | set an authentication method
12221−-setAuthMethod auth= writeIORef _authMethod auth
12222−-
12223−-getAuthMethod = readIORef _authMethod
12224−-
12225−-
12226−-data User= User
12227−- { userName :: String
12228−- , upassword :: String
12229−- } deriving (Read, Show, Typeable)
12230−-
12231−-
12232−-eUser= User (error1 "username") (error1 "password")
12233−-
12234−-error1 s= error $ s ++ " undefined"
12235−-
12236−-userPrefix= "user/"
12237−-instance Indexable User where
12238−- key User{userName= user}= keyUserName user
12239−-
12240−--- | Return the key name of an user
12241−-keyUserName n= userPrefix++n
12242−-
12243−-instance Serializable User where
12244−- serialize= B.pack . show
12245−- deserialize= read . B.unpack
12246−- setPersist = \_ -> Just filePersist
12247−-
12248−--- | Register an user/password
12249−-tCacheRegister :: String -> String -> IO (Maybe String)
12250−-tCacheRegister user password = atomically $ do
12251−- withSTMResources [newuser] doit
12252−- where
12253−- newuser= User user password
12254−- doit [Just (User _ _)] = resources{toReturn= Just "user already exist"}
12255−- doit [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
12256−-
12257−-tCacheValidate :: UserStr -> PasswdStr -> IO (Maybe String)
12258−-tCacheValidate u p =
12259−- let user= eUser{userName=u}
12260−- in atomically
12261−- $ withSTMResources [user]
12262−- $ \ mu -> case mu of
12263−- [Nothing] -> resources{toReturn= err }
12264−- [Just (User _ pass )] -> resources{toReturn=
12265−- case pass==p of
12266−- True -> Nothing
12267−- False -> err
12268−- }
12269−-
12270−- where
12271−- err= Just "Username or password invalid"
12272−-
12273−-userRegister u p= liftIO $ do
12274−- Auth reg _ <- getAuthMethod :: IO Auth
12275−- reg u p
12276−-
12277−-
12278−-newtype Config= Config1 (M.Map String String) deriving (Read,Show,Typeable)
12279−-
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")]
12286−-
12287−+ showError wfname token (show e)
12288−+-- sendFlush token (Error NotFound $ "Not found: " <> pack wfname)
12289−+ deleteTokenInList token
12290−+
12291−+ Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname)
12292−+
12293−+ Left Timeout -> do
12294−+ hFlush stdout -- !> ("TIMEOUT in msgScheduler" ++ (show $ unsafePerformIO myThreadId))
12295−+ deleteTokenInList token
12296−+
12297−+ Left (WFException e)-> do
12298−+ showError wfname token e
12299−+ moveState wfname token token{tind= "error/"++tuser token}
12300−+ deleteTokenInList token -- !> "DELETETOKEN"
12301−+
12302−+
12303−+ Right _ -> delMsgHistory token >> return () -- !> ("finished " ++ wfname)
12304−+
12305−+
12306−+
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
12310−+ logError msg
12311−+ fresp <- getNotFoundResponse
12312−+ let admin= getAdminName
12313−+ sendFlush token . Error $ fresp (tuser== admin) $ Prelude.concat[ "<br/>"++ s | s <- lines msg]
12314−+
12315−+
12316−+errorMessage t e u path env=
12317−+ "\n---------------------ERROR-------------------------\
12318−+ \\nTIME=" ++ t ++"\n\n" ++
12319−+ e++
12320−+ "\n\nUSER= " ++ u ++
12321−+ "\n\nPATH= " ++ path ++
12322−+ "\n\nREQUEST:\n\n" ++
12323−+ show env
12324−+
12325−+line= unsafePerformIO $ newMVar ()
12326−+
12327−+logError err= do
12328−+ takeMVar line
12329−+ putStrLn err
12330−+ hSeek hlog SeekFromEnd 0
12331−+ hPutStrLn hlog err
12332−+ hFlush hlog
12333−+ putMVar line ()
12334−+
12335−+logFileName= "errlog"
12336−+
12337−+
12338−+
12339−+-- | The handler of the error log
12340−+hlog= unsafePerformIO $ openFile logFileName ReadWriteMode
12341−+
12342−+------ USER MANAGEMENT -------
12343−+
12344−+data Auth = Auth{
12345−+ uregister :: UserStr -> PasswdStr -> (IO (Maybe String)),
12346−+ uvalidate :: UserStr -> PasswdStr -> (IO (Maybe String))}
12347−+
12348−+_authMethod= unsafePerformIO $ newIORef $ Auth tCacheRegister tCacheValidate
12349−+
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
12353−+
12354−+getAuthMethod = readIORef _authMethod
12355−+
12356−+
12357−+data User= User
12358−+ { userName :: String
12359−+ , upassword :: String
12360−+ } deriving (Read, Show, Typeable)
12361−+
12362−+
12363−+eUser= User (error1 "username") (error1 "password")
12364−+
12365−+error1 s= error $ s ++ " undefined"
12366−+
12367−+userPrefix= "user/"
12368−+instance Indexable User where
12369−+ key User{userName= user}= keyUserName user
12370−+
12371−+-- | Return the key name of an user
12372−+keyUserName n= userPrefix++n
12373−+
12374−+instance Serializable User where
12375−+ serialize= B.pack . show
12376−+ deserialize= read . B.unpack
12377−+ setPersist = \_ -> Just filePersist
12378−+
12379−+-- | Register an user/password
12380−+tCacheRegister :: String -> String -> IO (Maybe String)
12381−+tCacheRegister user password= tCacheRegister' 14 user password
12382−+
12383−+tCacheRegister' strength user password= do
12384−+ salted_password <- makePassword (SB.pack password) strength
12385−+ atomically $ do
12386−+ let newuser = User user (SB.unpack salted_password)
12387−+ withSTMResources [newuser] $ doit newuser
12388−+ where
12389−+ doit newuser [Just (User _ _)] = resources{toReturn= Just "user already exist"}
12390−+ doit newuser [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
12391−+
12392−+
12393−+-- withSTMResources [newuser] doit
12394−+-- where
12395−+-- newuser= User user password
12396−+-- doit [Just (User _ _)] = resources{toReturn= Just "user already exist"}
12397−+-- doit [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
12398−+
12399−+tCacheValidate :: UserStr -> PasswdStr -> IO (Maybe String)
12400−+tCacheValidate u p =
12401−+ let user= eUser{userName=u}
12402−+ in atomically
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
12409−+ True -> Nothing
12410−+ False -> err
12411−+ }
12412−+ where
12413−+ err= Just "Username or password invalid"
12414−+
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
12419−+ reg u p
12420−+
12421−+
12422−+newtype Config= Config1 (M.Map String String) deriving (Read,Show,Typeable)
12423−+
12424−+
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
12430− }
12431−- deriving (Read, Show, Typeable)
12432−+ deriving (Read, Show, Typeable)
12433−
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"
12438−---
12439−---writeDefConfig0= writeFile "sal" $ show defConfig0
12440−
12441− change :: Config0 -> Config
12442− change Config{..} = Config1 $ M.fromList
12443−@@ -558,370 +563,366 @@
12444−
12445− readOld :: ByteString -> Config
12446− readOld s= (change . read . B.unpack $ s)
12447−-
12448−-keyConfig= "mflow.config"
12449−+
12450−+keyConfig= "mflow.config"
12451− instance Indexable Config where key _= keyConfig
12452−
12453−-rconf :: DBRef Config
12454−-rconf= getDBRef keyConfig
12455−-
12456−-instance Serializable Config where
12457−- serialize = B.pack . show
12458−+rconf :: DBRef Config
12459−+rconf= getDBRef keyConfig
12460−+
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
12468−
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
12474− Just s -> s
12475−
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
12483−
12484−
12485− -- user ---
12486−-
12487−-type UserStr= String
12488−-type PasswdStr= String
12489−+
12490−+type UserStr= String
12491−+type PasswdStr= String
12492−
12493−
12494− -- | set the Administrator user and password.
12495− -- It must be defined in Main , before any configuration parameter is read, before the execution
12496−--- of any flow
12497−-setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m ()
12498−-setAdminUser user password= liftIO $ do
12499−+-- of any flow
12500−+setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m ()
12501−+setAdminUser user password= liftIO $ do
12502− userRegister user password
12503− setConfig "cadmin" user
12504−--- atomically $ do
12505−--- Config1 conf <- readConfig
12506−--- writeDBRef rconf $ Config1 $ M.insert "cadmin" user conf
12507−-
12508−-
12509−-
12510−-getAdminName= getConfig "cadmin" "admin"
12511−-
12512−-
12513−---------------- ERROR RESPONSES --------
12514−-
12515−-defNotFoundResponse isAdmin msg= fresp $
12516−- case isAdmin of
12517−- True -> B.pack msg
12518−- _ -> "The administrator has been notified"
12519−- where
12520−- fresp msg=
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>"
12523−-
12524−-
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)
12528−-
12529−-notFoundResponse= unsafePerformIO $ newIORef defNotFoundResponse
12530−-
12531−--- | set the 404 "not found" response.
12532−---
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
12537−-
12538−-setNotFoundResponse ::
12539−- (Bool
12540−- -> String
12541−- -> ByteString)
12542−- -> IO ()
12543−-
12544−-setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f
12545−-getNotFoundResponse= liftIO $ readIORef notFoundResponse
12546−-
12547−---------------- BASIC BYTESTRING TAGS -------------------
12548−-
12549−-
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 <> ">"
12555−- where
12556−- pt= B.pack t
12557−- attrs []= B.empty
12558−- attrs rs= B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs
12559−-
12560−--- |
12561−--- > bhtml ats v= btag "html" ats v
12562−-bhtml :: Attribs -> ByteString -> ByteString
12563−-bhtml ats v= btag "html" ats v
12564−-
12565−-
12566−--- |
12567−--- > bbody ats v= btag "body" ats v
12568−-bbody :: Attribs -> ByteString -> ByteString
12569−-bbody ats v= btag "body" ats v
12570−-
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
12574−-
12575−-addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other
12576−-
12577−-
12578−-------------------- FILE SERVER -----------
12579−-
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
12588−-
12589−-rfilesPath= unsafePerformIO $ newIORef "files/"
12590−-
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)
12597−- case mr of
12598−- Nothing -> error "not found" -- return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible"
12599−- Just r ->
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"
12603−-
12604−- in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r
12605−- where
12606−- noperm= "no permissions"
12607−- ioerr x= \(e :: CE.IOException) -> x
12608−- setMime x= ("Content-Type",x)
12609−-
12610−---------------------- FLOW ID GENERATOR ------------
12611−-
12612−-data NFlow= NFlow !Integer deriving (Read, Show, Typeable)
12613−-
12614−-
12615−-
12616−-instance Indexable NFlow where
12617−- key _= "Flow"
12618−-
12619−-instance Serializable NFlow where
12620−- serialize= B.pack . show
12621−- deserialize= read . B.unpack
12622−- setPersist = \_ -> Just filePersist
12623−-
12624−-rflow= getDBRef . key $ NFlow undefined
12625−-
12626−-newFlow= do
12627−- TOD t _ <- getClockTime
12628−- atomically $ do
12629−- NFlow n <- readDBRef rflow `onNothing` return (NFlow 0)
12630−- writeDBRef rflow . NFlow $ n+1
12631−- return . SB.pack . show $ t + n
12632−-
12633−-
12634−-mimeTable=[
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")
12830−-
12831−- ]
12832−-
12833−+
12834−+
12835−+getAdminName= getConfig "cadmin" "admin"
12836−+
12837−+
12838−+--------------- ERROR RESPONSES --------
12839−+
12840−+defNotFoundResponse isAdmin msg= fresp $
12841−+ case isAdmin of
12842−+ True -> B.pack msg
12843−+ _ -> "The administrator has been notified"
12844−+ where
12845−+ fresp msg=
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>"
12848−+
12849−+
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)
12853−+
12854−+notFoundResponse= unsafePerformIO $ newIORef defNotFoundResponse
12855−+
12856−+-- | set the 404 "not found" response.
12857−+--
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
12862−+
12863−+setNotFoundResponse ::
12864−+ (Bool
12865−+ -> String
12866−+ -> ByteString)
12867−+ -> IO ()
12868−+
12869−+setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f
12870−+getNotFoundResponse= liftIO $ readIORef notFoundResponse
12871−+
12872−+--------------- BASIC BYTESTRING TAGS -------------------
12873−+
12874−+
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 <> ">"
12880−+ where
12881−+ pt= B.pack t
12882−+ attrs []= B.empty
12883−+ attrs rs= B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs
12884−+
12885−+-- |
12886−+-- > bhtml ats v= btag "html" ats v
12887−+bhtml :: Attribs -> ByteString -> ByteString
12888−+bhtml ats v= btag "html" ats v
12889−+
12890−+
12891−+-- |
12892−+-- > bbody ats v= btag "body" ats v
12893−+bbody :: Attribs -> ByteString -> ByteString
12894−+bbody ats v= btag "body" ats v
12895−+
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
12899−+
12900−+addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other
12901−+
12902−+
12903−+------------------- FILE SERVER -----------
12904−+
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
12913−+
12914−+rfilesPath= unsafePerformIO $ newIORef "files/"
12915−+
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)
12922−+ case mr of
12923−+ Nothing -> error "not found" -- return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible"
12924−+ Just r ->
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"
12928−+
12929−+ in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r
12930−+ where
12931−+ noperm= "no permissions"
12932−+ ioerr x= \(e :: CE.IOException) -> x
12933−+ setMime x= ("Content-Type",x)
12934−+
12935−+--------------------- FLOW ID GENERATOR ------------
12936−+
12937−+data NFlow= NFlow !Integer deriving (Read, Show, Typeable)
12938−+
12939−+
12940−+
12941−+instance Indexable NFlow where
12942−+ key _= "Flow"
12943−+
12944−+instance Serializable NFlow where
12945−+ serialize= B.pack . show
12946−+ deserialize= read . B.unpack
12947−+ setPersist = \_ -> Just filePersist
12948−+
12949−+rflow= getDBRef . key $ NFlow undefined
12950−+
12951−+newFlow= do
12952−+ TOD t _ <- getClockTime
12953−+ atomically $ do
12954−+ NFlow n <- readDBRef rflow `onNothing` return (NFlow 0)
12955−+ writeDBRef rflow . NFlow $ n+1
12956−+ return . SB.pack . show $ t + n
12957−+
12958−+
12959−+mimeTable=[
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")
13155−+
13156−+ ]
13157−+