@@ -0,0 +1,13157 @@
1+diff -ru orig/MFlow.cabal new/MFlow.cabal
2+--- orig/MFlow.cabal 2014-06-10 05:51:27.009015855 +0300
3++++ new/MFlow.cabal 2014-06-10 05:51:25.000000000 +0300
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++